CoreSubst.lhs 53.5 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Utility functions on @Core@ syntax
7
8

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
9
10
11
12
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
13
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
Ian Lynagh's avatar
Ian Lynagh committed
14
15
-- for details

16
module CoreSubst (
batterseapower's avatar
batterseapower committed
17
	-- * Main data types
18
19
	Subst(..), -- Implementation exported for supercompiler's Renaming.hs only
	TvSubstEnv, IdSubstEnv, InScopeSet,
20

batterseapower's avatar
batterseapower committed
21
        -- ** Substituting into expressions and related types
22
	deShadowBinds, substSpec, substRulesForImportedIds,
23
	substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
24
        substUnfolding, substUnfoldingSC,
25
	lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
26
        substTickish,
27

batterseapower's avatar
batterseapower committed
28
        -- ** Operations on substitutions
29
	emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
30
 	extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
31
32
        extendCvSubst, extendCvSubstList,
	extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
33
34
35
        addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
        isInScope, setInScope,
        delBndr, delBndrs,
36

batterseapower's avatar
batterseapower committed
37
	-- ** Substituting and cloning binders
38
	substBndr, substBndrs, substRecBndrs,
39
	cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
40
41

	-- ** Simple expression optimiser
42
        simpleOptPgm, simpleOptExpr, simpleOptExprWith,
43
        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
44
45
46
47
    ) where

#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
48
49
50
import CoreSyn
import CoreFVs
import CoreUtils
51
import Literal  ( Literal )
52
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
53

Simon Marlow's avatar
Simon Marlow committed
54
import qualified Type
55
56
57
58
import qualified Coercion

	-- We are defining local versions
import Type     hiding ( substTy, extendTvSubst, extendTvSubstList
59
                       , isInScope, substTyVarBndr, cloneTyVarBndr )
60
61
import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )

62
63
import TyCon       ( tyConArity )
import DataCon
64
import PrelNames   ( eqBoxDataConKey, coercibleDataConKey )
65
import OptCoercion ( optCoercion )
66
import PprCore     ( pprCoreBindings, pprRules )
67
import Module	   ( Module )
68
69
import VarSet
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
70
import Id
71
import Name	( Name )
72
import Var
Simon Marlow's avatar
Simon Marlow committed
73
74
75
76
import IdInfo
import Unique
import UniqSupply
import Maybes
77
import ErrUtils
78
import DynFlags
79
import BasicTypes ( isAlwaysActive )
80
81
import Util
import Pair
82
83
import Outputable
import PprCore		()		-- Instances
84
import FastString
85
86

import Data.List
87
88
89
90
91
92
93
94
95
96
\end{code}


%************************************************************************
%*									*
\subsection{Substitutions}
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
-- | A substitution environment, containing both 'Id' and 'TyVar' substitutions.
--
-- Some invariants apply to how you use the substitution:
--
-- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/
-- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the
-- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.
--
-- 2. #apply_once# You may apply the substitution only /once/
--
-- There are various ways of setting up the in-scope set such that the first of these invariants hold:
--
-- * Arrange that the in-scope set really is all the things in scope
--
-- * Arrange that it's the free vars of the range of the substitution
--
-- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash
114
data Subst 
Thomas Schilling's avatar
Thomas Schilling committed
115
116
117
  = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
                      -- applying the substitution
          IdSubstEnv  -- Substitution for Ids
118
          TvSubstEnv  -- Substitution from TyVars to Types
119
          CvSubstEnv  -- Substitution from CoVars to Coercions
120

batterseapower's avatar
batterseapower committed
121
	-- INVARIANT 1: See #in_scope_invariant#
122
123
124
	-- This is what lets us deal with name capture properly
	-- It's a hard invariant to check...
	--
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
125
	-- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with
126
	--		Types.TvSubstEnv
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
127
128
	--
	-- INVARIANT 3: See Note [Extending the Subst]
129
\end{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
130
131
132
133
134
135
136
137
138
139
140
141
142
143

Note [Extending the Subst]
~~~~~~~~~~~~~~~~~~~~~~~~~~
For a core Subst, which binds Ids as well, we make a different choice for Ids
than we do for TyVars.  

For TyVars, see Note [Extending the TvSubst] with Type.TvSubstEnv

For Ids, we have a different invariant
	The IdSubstEnv is extended *only* when the Unique on an Id changes
	Otherwise, we just extend the InScopeSet

In consequence:

144
145
146
147
148
149
* If the TvSubstEnv and IdSubstEnv are both empty, substExpr would be a
  no-op, so substExprSC ("short cut") does nothing.

  However, substExpr still goes ahead and substitutes.  Reason: we may
  want to replace existing Ids with new ones from the in-scope set, to
  avoid space leaks.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
150

151
* In substIdBndr, we extend the IdSubstEnv only when the unique changes
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
152

153
154
155
156
157
* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
  substExpr does nothing (Note that the above rule for substIdBndr
  maintains this property.  If the incoming envts are both empty, then
  substituting the type and IdInfo can't change anything.)

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
158
159
160
161
162
163
164
* In lookupIdSubst, we *must* look up the Id in the in-scope set, because
  it may contain non-trivial changes.  Example:
	(/\a. \x:a. ...x...) Int
  We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change
  so we only extend the in-scope set.  Then we must look up in the in-scope
  set when we find the occurrence of x.

165
* The requirement to look up the Id in the in-scope set means that we
166
  must NOT take no-op short cut when the IdSubst is empty.
167
168
169
170
171
  We must still look up every Id in the in-scope set.

* (However, we don't need to do so for expressions found in the IdSubst
  itself, whose range is assumed to be correct wrt the in-scope set.)

172
173
Why do we make a different choice for the IdSubstEnv than the
TvSubstEnv and CvSubstEnv?
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
174
175
176
177
178
179
180
181
182
183

* For Ids, we change the IdInfo all the time (e.g. deleting the
  unfolding), and adding it back later, so using the TyVar convention
  would entail extending the substitution almost all the time

* The simplifier wants to look up in the in-scope set anyway, in case it 
  can see a better unfolding from an enclosing case expression

* For TyVars, only coercion variables can possibly change, and they are 
  easy to spot
184

185
\begin{code}
batterseapower's avatar
batterseapower committed
186
-- | An environment for substituting for 'Id's
187
188
189
190
type IdSubstEnv = IdEnv CoreExpr

----------------------------
isEmptySubst :: Subst -> Bool
191
192
isEmptySubst (Subst _ id_env tv_env cv_env) 
  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
193
194

emptySubst :: Subst
195
emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
196
197

mkEmptySubst :: InScopeSet -> Subst
198
mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
199

200
201
mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
202

batterseapower's avatar
batterseapower committed
203
-- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
204
substInScope :: Subst -> InScopeSet
205
substInScope (Subst in_scope _ _ _) = in_scope
206

batterseapower's avatar
batterseapower committed
207
208
-- | Remove all substitutions for 'Id's and 'Var's that might have been built up
-- while preserving the in-scope set
209
zapSubstEnv :: Subst -> Subst
210
zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
211

batterseapower's avatar
batterseapower committed
212
213
-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
214
extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
batterseapower's avatar
batterseapower committed
215
-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
216
extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
217

batterseapower's avatar
batterseapower committed
218
-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
219
extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
220
extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
221

batterseapower's avatar
batterseapower committed
222
223
-- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
224
extendTvSubst :: Subst -> TyVar -> Type -> Subst
225
extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
226

batterseapower's avatar
batterseapower committed
227
-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
228
extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
229
extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
230

231
-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
232
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
233
extendCvSubst :: Subst -> CoVar -> Coercion -> Subst
234
235
extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)

236
-- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the
237
-- 'Subst': see also 'extendCvSubst'
238
extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst
239
extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
240

241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
-- | Add a substitution appropriate to the thing being substituted
--   (whether an expression, type, or coercion). See also
--   'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
extendSubst :: Subst -> Var -> CoreArg -> Subst
extendSubst subst var arg
  = case arg of
      Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty
      Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
      _           -> ASSERT( isId    var ) extendIdSubst subst var arg

extendSubstWithVar :: Subst -> Var -> Var -> Subst
extendSubstWithVar subst v1 v2
  | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
  | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
  | otherwise  = ASSERT( isId    v2 ) extendIdSubst subst v1 (Var v2)

-- | Add a substitution as appropriate to each of the terms being
--   substituted (whether expressions, types, or coercions). See also
--   'extendSubst'.
batterseapower's avatar
batterseapower committed
260
261
262
263
264
extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
extendSubstList subst []	      = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs

-- | Find the substitution for an 'Id' in the 'Subst'
265
lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
266
lookupIdSubst doc (Subst in_scope ids _ _) v
267
  | not (isLocalId v) = Var v
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
268
269
270
  | Just e  <- lookupVarEnv ids       v = e
  | Just v' <- lookupInScope in_scope v = Var v'
	-- Vital! See Note [Extending the Subst]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
271
272
  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v 
                            $$ ppr in_scope) 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
273
		Var v
274

batterseapower's avatar
batterseapower committed
275
-- | Find the substitution for a 'TyVar' in the 'Subst'
276
lookupTvSubst :: Subst -> TyVar -> Type
277
278
lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v

279
-- | Find the coercion substitution for a 'CoVar' in the 'Subst'
280
281
lookupCvSubst :: Subst -> CoVar -> Coercion
lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
282

283
delBndr :: Subst -> Var -> Subst
284
285
286
287
delBndr (Subst in_scope ids tvs cvs) v
  | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
  | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
288
289

delBndrs :: Subst -> [Var] -> Subst
290
291
delBndrs (Subst in_scope ids tvs cvs) vs
  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
292
      -- Easiest thing is just delete all from all!
293

294
295
296
297
-- | Simultaneously substitute for a bunch of variables
--   No left-right shadowing
--   ie the substitution for   (\x \y. e) a1 a2
--      so neither x nor y scope over a1 a2
298
299
300
301
mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
mkOpenSubst in_scope pairs = Subst in_scope
	    	          	   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
			  	   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
302
                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
303

304
305
------------------------------
isInScope :: Var -> Subst -> Bool
306
isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
307

308
309
310
-- | Add the 'Var' to the in-scope set, but do not remove
-- any existing substitutions for it
addInScopeSet :: Subst -> VarSet -> Subst
311
312
addInScopeSet (Subst in_scope ids tvs cvs) vs
  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
313
314
315

-- | Add the 'Var' to the in-scope set: as a side effect,
-- and remove any existing substitutions for it
316
extendInScope :: Subst -> Var -> Subst
317
extendInScope (Subst in_scope ids tvs cvs) v
318
  = Subst (in_scope `extendInScopeSet` v) 
319
	  (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
320

batterseapower's avatar
batterseapower committed
321
-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
322
extendInScopeList :: Subst -> [Var] -> Subst
323
extendInScopeList (Subst in_scope ids tvs cvs) vs
324
  = Subst (in_scope `extendInScopeSetList` vs) 
325
	  (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
326

batterseapower's avatar
batterseapower committed
327
-- | Optimized version of 'extendInScopeList' that can be used if you are certain 
328
-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
329
extendInScopeIds :: Subst -> [Id] -> Subst
330
extendInScopeIds (Subst in_scope ids tvs cvs) vs 
331
  = Subst (in_scope `extendInScopeSetList` vs) 
332
	  (ids `delVarEnvList` vs) tvs cvs
333
334

setInScope :: Subst -> InScopeSet -> Subst
335
setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
336
337
338
339
340
341
\end{code}

Pretty printing, for debugging only

\begin{code}
instance Outputable Subst where
342
  ppr (Subst in_scope ids tvs cvs) 
Ian Lynagh's avatar
Ian Lynagh committed
343
344
345
	=  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
	$$ ptext (sLit " IdSubst   =") <+> ppr ids
	$$ ptext (sLit " TvSubst   =") <+> ppr tvs
346
        $$ ptext (sLit " CvSubst   =") <+> ppr cvs   
347
348
349
350
351
352
353
354
355
356
357
 	 <> char '>'
\end{code}


%************************************************************************
%*									*
	Substituting expressions
%*									*
%************************************************************************

\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
358
359
-- | Apply a substititon to an entire 'CoreExpr'. Rememeber, you may only 
-- apply the substitution /once/: see "CoreSubst#apply_once"
360
361
362
--
-- Do *not* attempt to short-cut in the case of an empty substitution!
-- See Note [Extending the Subst]
363
364
365
366
367
368
369
370
371
372
373
substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
substExprSC _doc subst orig_expr
  | isEmptySubst subst = orig_expr
  | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
                         subst_expr subst orig_expr

substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr _doc subst orig_expr = subst_expr subst orig_expr

subst_expr :: Subst -> CoreExpr -> CoreExpr
subst_expr subst expr
374
375
  = go expr
  where
376
    go (Var v)	       = lookupIdSubst (text "subst_expr") subst v 
377
    go (Type ty)       = Type (substTy subst ty)
378
    go (Coercion co)   = Coercion (substCo subst co)
379
380
    go (Lit lit)       = Lit lit
    go (App fun arg)   = App (go fun) (go arg)
381
    go (Tick tickish e) = Tick (substTickish subst tickish) (go e)
382
    go (Cast e co)     = Cast (go e) (substCo subst co)
383
384
385
386
387
       -- Do not optimise even identity coercions
       -- Reason: substitution applies to the LHS of RULES, and
       --         if you "optimise" an identity coercion, you may
       --         lose a binder. We optimise the LHS of rules at
       --         construction time
388

389
    go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
390
391
392
		       where
			 (subst', bndr') = substBndr subst bndr

393
    go (Let bind body) = Let bind' (subst_expr subst' body)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
394
395
		       where
			 (subst', bind') = substBind subst bind
396
397
398
399
400

    go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
			         where
			  	 (subst', bndr') = substBndr subst bndr

401
    go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
402
403
404
				 where
				   (subst', bndrs') = substBndrs subst bndrs

batterseapower's avatar
batterseapower committed
405
406
-- | Apply a substititon to an entire 'CoreBind', additionally returning an updated 'Subst'
-- that should be used by subsequent substitutons.
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)

substBindSC subst bind 	  -- Short-cut if the substitution is empty
  | not (isEmptySubst subst)
  = substBind subst bind
  | otherwise
  = case bind of
       NonRec bndr rhs -> (subst', NonRec bndr' rhs)
          where
      	    (subst', bndr') = substBndr subst bndr
       Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
          where
            (bndrs, rhss)    = unzip pairs
      	    (subst', bndrs') = substRecBndrs subst bndrs
      	    rhss' | isEmptySubst subst' = rhss
                  | otherwise	        = map (subst_expr subst') rhss

substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr subst rhs))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
425
426
427
				  where
				    (subst', bndr') = substBndr subst bndr

428
substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
429
			    where
430
431
432
                                (bndrs, rhss)    = unzip pairs
				(subst', bndrs') = substRecBndrs subst bndrs
				rhss' = map (subst_expr subst') rhss
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
433
434
435
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
436
-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
Gabor Greif's avatar
typos    
Gabor Greif committed
437
-- by running over the bindings with an empty substitution, because substitution
batterseapower's avatar
batterseapower committed
438
439
440
441
-- returns a result that has no-shadowing guaranteed.
--
-- (Actually, within a single /type/ there might still be shadowing, because 
-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
442
443
444
--
-- [Aug 09] This function is not used in GHC at the moment, but seems so 
--          short and simple that I'm going to leave it here
445
deShadowBinds :: CoreProgram -> CoreProgram
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
446
deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
\end{code}


%************************************************************************
%*									*
	Substituting binders
%*									*
%************************************************************************

Remember that substBndr and friends are used when doing expression
substitution only.  Their only business is substitution, so they
preserve all IdInfo (suitably substituted).  For example, we *want* to
preserve occ info in rules.

\begin{code}
batterseapower's avatar
batterseapower committed
462
463
464
-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
-- the result and an updated 'Subst' that should be used by subsequent substitutons.
-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
465
466
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
467
468
469
  | isTyVar bndr  = substTyVarBndr subst bndr
  | isCoVar bndr  = substCoVarBndr subst bndr
  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
470

batterseapower's avatar
batterseapower committed
471
-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
472
473
474
substBndrs :: Subst -> [Var] -> (Subst, [Var])
substBndrs subst bndrs = mapAccumL substBndr subst bndrs

batterseapower's avatar
batterseapower committed
475
-- | Substitute in a mutually recursive group of 'Id's
476
477
478
479
substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
substRecBndrs subst bndrs 
  = (new_subst, new_bndrs)
  where		-- Here's the reason we need to pass rec_subst to subst_id
480
    (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
481
482
483
484
\end{code}


\begin{code}
485
486
substIdBndr :: SDoc 
            -> Subst		-- ^ Substitution to use for the IdInfo
batterseapower's avatar
batterseapower committed
487
488
	    -> Subst -> Id 	-- ^ Substitition and Id to transform
	    -> (Subst, Id)	-- ^ Transformed pair
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
489
				-- NB: unfolding may be zapped
490

491
substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
492
  = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
493
    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
494
495
  where
    id1 = uniqAway in_scope old_id	-- id1 is cloned if necessary
496
497
498
499
    id2 | no_type_change = id1
	| otherwise	 = setIdType id1 (substTy subst old_ty)

    old_ty = idType old_id
Simon Marlow's avatar
Simon Marlow committed
500
501
    no_type_change = isEmptyVarEnv tvs || 
                     isEmptyVarSet (Type.tyVarsOfType old_ty)
502
503
504
505

	-- new_id has the right IdInfo
	-- The lazy-set is because we're in a loop here, with 
	-- rec_subst, when dealing with a mutually-recursive group
506
    new_id = maybeModifyIdInfo mb_new_info id2
507
    mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
508
	-- NB: unfolding info may be zapped
509
510

	-- Extend the substitution if the unique has changed
511
	-- See the notes with substTyVarBndr for the delVarEnv
512
513
514
    new_env | no_change = delVarEnv env old_id
	    | otherwise = extendVarEnv env old_id (Var new_id)

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
515
516
    no_change = id1 == old_id
	-- See Note [Extending the Subst]
Thomas Schilling's avatar
Thomas Schilling committed
517
	-- it's /not/ necessary to check mb_new_info and no_type_change
518
519
520
521
522
523
\end{code}

Now a variant that unconditionally allocates a new unique.
It also unconditionally zaps the OccInfo.

\begin{code}
batterseapower's avatar
batterseapower committed
524
-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
525
-- each variable in its output.  It substitutes the IdInfo though.
526
527
528
529
cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
cloneIdBndr subst us old_id
  = clone_id subst subst (old_id, uniqFromSupply us)

batterseapower's avatar
batterseapower committed
530
531
-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
-- substitution from left to right
532
533
534
535
cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneIdBndrs subst us ids
  = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)

536
537
538
539
cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
-- Works for all kinds of variables (typically case binders)
-- not just Ids
cloneBndrs subst us vs
540
541
542
543
  = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)

cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
cloneBndr subst uniq v
544
545
546
      | isTyVar v = cloneTyVarBndr subst v uniq
      | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too

batterseapower's avatar
batterseapower committed
547
-- | Clone a mutually recursive group of 'Id's
548
549
550
551
552
553
554
555
556
557
558
559
560
cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneRecIdBndrs subst us ids
  = (subst', ids')
  where
    (subst', ids') = mapAccumL (clone_id subst') subst
			       (ids `zip` uniqsFromSupply us)

-- Just like substIdBndr, except that it always makes a new unique
-- It is given the unique to use
clone_id    :: Subst			-- Substitution for the IdInfo
	    -> Subst -> (Id, Unique)	-- Substitition and Id to transform
	    -> (Subst, Id)		-- Transformed pair

561
562
clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
  = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
563
564
565
  where
    id1	    = setVarUnique old_id uniq
    id2     = substIdType subst id1
566
    new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
567
568
    (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)
569
570
571
572
573
\end{code}


%************************************************************************
%*									*
574
		Types and Coercions
575
576
577
%*									*
%************************************************************************

578
579
580
For types and coercions we just call the corresponding functions in
Type and Coercion, but we have to repackage the substitution, from a
Subst to a TvSubst.
581
582
583

\begin{code}
substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
584
substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
585
586
  = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
	(TvSubst in_scope' tv_env', tv') 
587
588
	   -> (Subst in_scope' id_env tv_env' cv_env, tv')

589
590
591
592
593
594
cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)
cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq
  = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of
	(TvSubst in_scope' tv_env', tv') 
	   -> (Subst in_scope' id_env tv_env' cv_env, tv')

595
596
597
598
599
substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
  = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
	(CvSubst in_scope' tv_env' cv_env', cv') 
	   -> (Subst in_scope' id_env tv_env' cv_env', cv')
600

batterseapower's avatar
batterseapower committed
601
-- | See 'Type.substTy'
602
substTy :: Subst -> Type -> Type 
603
604
605
substTy subst ty = Type.substTy (getTvSubst subst) ty

getTvSubst :: Subst -> TvSubst
606
607
608
609
610
611
612
613
getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv

getCvSubst :: Subst -> CvSubst
getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv

-- | See 'Coercion.substCo'
substCo :: Subst -> Coercion -> Coercion
substCo subst co = Coercion.substCo (getCvSubst subst) co
614
615
616
617
618
619
620
621
622
623
624
\end{code}


%************************************************************************
%*									*
\section{IdInfo substitution}
%*									*
%************************************************************************

\begin{code}
substIdType :: Subst -> Id -> Id
625
626
substIdType subst@(Subst _ _ tv_env cv_env) id
  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
627
628
629
630
631
632
633
634
  | otherwise	= setIdType id (substTy subst old_ty)
		-- The tyVarsOfType is cheaper than it looks
		-- because we cache the free tyvars of the type
		-- in a Note in the id's type itself
  where
    old_ty = idType id

------------------
batterseapower's avatar
batterseapower committed
635
636
-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
637
substIdInfo subst new_id info
638
  | nothing_to_do = Nothing
639
  | otherwise     = Just (info `setSpecInfo`      substSpec subst new_id old_rules
640
			       `setUnfoldingInfo` substUnfolding subst old_unf)
641
642
  where
    old_rules 	  = specInfo info
643
644
    old_unf	  = unfoldingInfo info
    nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
645
646
647
    

------------------
648
-- | Substitutes for the 'Id's within an unfolding
649
substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
650
651
	-- Seq'ing on the returned Unfolding is enough to cause
	-- all the substitutions to happen completely
652
653
654
655
656

substUnfoldingSC subst unf 	 -- Short-cut version
  | isEmptySubst subst = unf
  | otherwise          = substUnfolding subst unf

657
658
substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
  = df { df_bndrs = bndrs', df_args = args' }
659
  where
660
661
    (subst',bndrs') = substBndrs subst bndrs
    args'           = map (substExpr (text "subst-unf:dfun") subst') args
662

663
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
664
	-- Retain an InlineRule!
665
  | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work
666
  = NoUnfolding
667
  | otherwise                 -- But keep a stable one!
668
669
  = seqExpr new_tmpl `seq`
    unf { uf_tmpl = new_tmpl }
670
  where
671
    new_tmpl = substExpr (text "subst-unf") subst tmpl
672

673
substUnfolding _ unf = unf	-- NoUnfolding, OtherCon
674
675
676
677

------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
678
substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
679
680
	   	        Var v' -> v'
			other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
681
682

------------------
batterseapower's avatar
batterseapower committed
683
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
684
substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
685
686
substSpec subst new_id (SpecInfo rules rhs_fvs)
  = seqSpecInfo new_spec `seq` new_spec
687
  where
688
689
    subst_ru_fn = const (idName new_id)
    new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
690
                        (substVarSet subst rhs_fvs)
691
692
693
694

------------------
substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
substRulesForImportedIds subst rules 
695
696
697
  = map (substRule subst not_needed) rules
  where
    not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
698
699
700
701
702
703
704
705
706

------------------
substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule

-- The subst_ru_fn argument is applied to substitute the ru_fn field
-- of the rule:
--    - Rules for *imported* Ids never change ru_fn
--    - Rules for *local* Ids are in the IdInfo for that Id,
--      and the ru_fn field is simply replaced by the new name 
707
--      of the Id
708
709
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
710
711
                                       , ru_fn = fn_name, ru_rhs = rhs
                                       , ru_local = is_local })
712
  = rule { ru_bndrs = bndrs', 
713
714
715
716
           ru_fn    = if is_local 
                        then subst_ru_fn fn_name 
                        else fn_name,
           ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
717
718
719
           ru_rhs   = simpleOptExprWith subst' rhs }
           -- Do simple optimisation on RHS, in case substitution lets
           -- you improve it.  The real simplifier never gets to look at it.
720
721
  where
    (subst', bndrs') = substBndrs subst bndrs
722

723
724
725
726
727
728
------------------
substVects :: Subst -> [CoreVect] -> [CoreVect]
substVects subst = map (substVect subst)

------------------
substVect :: Subst -> CoreVect -> CoreVect
729
730
731
732
733
substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)
substVect _subst vd@(NoVect _)       = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _)    = vd
substVect _subst vd@(VectInst _)     = vd
734

735
------------------
twanvl's avatar
twanvl committed
736
substVarSet :: Subst -> VarSet -> VarSet
737
substVarSet subst fvs
738
739
740
  = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
  where
    subst_fv subst fv 
741
742
        | isId fv   = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
        | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764

------------------
substTickish :: Subst -> Tickish Id -> Tickish Id
substTickish subst (Breakpoint n ids) = Breakpoint n (map do_one ids)
 where do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
substTickish _subst other = other

{- Note [substTickish]

A Breakpoint contains a list of Ids.  What happens if we ever want to
substitute an expression for one of these Ids?

First, we ensure that we only ever substitute trivial expressions for
these Ids, by marking them as NoOccInfo in the occurrence analyser.
Then, when substituting for the Id, we unwrap any type applications
and abstractions to get back to an Id, with getIdFromTrivialExpr.

Second, we have to ensure that we never try to substitute a literal
for an Id in a breakpoint.  We ensure this by never storing an Id with
an unlifted type in a Breakpoint - see Coverage.mkTickish.
Breakpoints can't handle free variables with unlifted types anyway.
-}
765
\end{code}
766

767
768
769
770
771
Note [Worker inlining]
~~~~~~~~~~~~~~~~~~~~~~
A worker can get sustituted away entirely.
	- it might be trivial
	- it might simply be very small
Gabor Greif's avatar
Gabor Greif committed
772
We do not treat an InlWrapper as an 'occurrence' in the occurrence 
773
774
775
776
777
778
analyser, so it's possible that the worker is not even in scope any more.

In all all these cases we simply drop the special case, returning to
InlVanilla.  The WARN is just so I can see if it happens a lot.


779
780
781
782
783
784
%************************************************************************
%*									*
	The Very Simple Optimiser
%*									*
%************************************************************************

batterseapower's avatar
batterseapower committed
785
786
787
Note [Optimise coercion boxes agressively]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

788
The simple expression optimiser needs to deal with Eq# boxes as follows:
batterseapower's avatar
batterseapower committed
789
790
 1. If the result of optimising the RHS of a non-recursive binding is an
    Eq# box, that box is substituted rather than turned into a let, just as
791
792
    if it were trivial.
       let eqv = Eq# co in e ==> e[Eq# co/eqv]
batterseapower's avatar
batterseapower committed
793
794
795

 2. If the result of optimising a case scrutinee is a Eq# box and the case
    deconstructs it in a trivial way, we evaluate the case then and there.
796
      case Eq# co of Eq# cov -> e ==> e[co/cov]
batterseapower's avatar
batterseapower committed
797
798
799
800
801
802
803
804
805
806
807
808

We do this for two reasons:

 1. Bindings/case scrutinisation of this form is often created by the
    evidence-binding mechanism and we need them to be inlined to be able
    desugar RULE LHSes that involve equalities (see e.g. T2291)

 2. The test T4356 fails Lint because it creates a coercion between types
    of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this
    inlining agressively we can collapse away the intermediate coercion between
    these two types and hence pass Lint again. (This is a sort of a hack.)

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
In fact, our implementation uses slightly liberalised versions of the second rule
rule so that the optimisations are a bit more generally applicable. Precisely:
 2a. We reduce any situation where we can spot a case-of-known-constructor

As a result, the only time we should get residual coercion boxes in the code is
when the type checker generates something like:

  \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...)

However, the case of lambda-bound equality evidence is fairly rare, so these two
rules should suffice for solving the rule LHS problem for now.

Annoyingly, we cannot use this modified rule 1a instead of 1:

 1a. If we come across a let-bound constructor application with trivial arguments,
     add an appropriate unfolding to the let binder.  We spot constructor applications
     by using exprIsConApp_maybe, so this would actually let rule 2a reduce more.

The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a
we wouldn't simplify this expression at all:

  let eqv = Eq# co
  in foo eqv (bar eqv)

The rule LHS desugarer can't deal with Let at all, so we need to push that box into
the use sites.

836
837
838
839
840
841
842
\begin{code}
simpleOptExpr :: CoreExpr -> CoreExpr
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
-- inline non-recursive bindings that are used only once, 
-- or where the RHS is trivial
--
batterseapower's avatar
batterseapower committed
843
844
845
-- We also inline bindings that bind a Eq# box: see
-- See Note [Optimise coercion boxes agressively].
--
Gabor Greif's avatar
Gabor Greif committed
846
-- The result is NOT guaranteed occurrence-analysed, because
847
848
849
850
-- in  (let x = y in ....) we substitute for x; so y's occ-info
-- may change radically

simpleOptExpr expr
851
  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
852
    simpleOptExprWith init_subst expr
853
854
855
856
857
858
859
860
861
  where
    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
	-- It's potentially important to make a proper in-scope set
	-- Consider  let x = ..y.. in \y. ...x...
	-- Then we should remember to clone y before substituting
	-- for x.  It's very unlikely to occur, because we probably
	-- won't *be* substituting for x if it occurs inside a
	-- lambda.  
	--
862
        -- It's a bit painful to call exprFreeVars, because it makes
863
864
	-- three passes instead of two (occ-anal, and go)

865
866
867
simpleOptExprWith :: Subst -> InExpr -> OutExpr
simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)

868
----------------------
869
simpleOptPgm :: DynFlags -> Module 
870
871
             -> CoreProgram -> [CoreRule] -> [CoreVect] 
             -> IO (CoreProgram, [CoreRule], [CoreVect])
872
simpleOptPgm dflags this_mod binds rules vects
873
  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
874
                       (pprCoreBindings occ_anald_binds $$ pprRules rules );
875

876
       ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
877
  where
878
    occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
879
                                       rules vects emptyVarEnv binds
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
    (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
                       
    do_one (subst, binds') bind 
      = case simple_opt_bind subst bind of
          (subst', Nothing)    -> (subst', binds')
          (subst', Just bind') -> (subst', bind':binds')

----------------------
type InVar   = Var
type OutVar  = Var
type InId    = Id
type OutId   = Id
type InExpr  = CoreExpr
type OutExpr = CoreExpr

-- In these functions the substitution maps InVar -> OutExpr

----------------------
898
899
simple_opt_expr :: Subst -> InExpr -> OutExpr
simple_opt_expr subst expr
900
901
  = go expr
  where
902
903
    in_scope_env = (substInScope subst, simpleUnfoldingFun)

904
    go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
905
    go (App e1 e2)      = simple_app subst e1 [go e2]
906
907
    go (Type ty)        = Type     (substTy subst ty)
    go (Coercion co)    = Coercion (optCoercion (getCvSubst subst) co)
908
    go (Lit lit)        = Lit lit
909
    go (Tick tickish e) = Tick (substTickish subst tickish) (go e)
910
911
    go (Cast e co)      | isReflCo co' = go e
       	                | otherwise    = Cast (go e) co' 
912
                        where
913
                          co' = optCoercion (getCvSubst subst) co
914

915
916
917
918
    go (Let bind body) = case simple_opt_bind subst bind of
                           (subst', Nothing)   -> simple_opt_expr subst' body
                           (subst', Just bind) -> Let bind (simple_opt_expr subst' body)

919
    go lam@(Lam {})     = go_lam [] subst lam
batterseapower's avatar
batterseapower committed
920
    go (Case e b ty as)
921
922
       -- See Note [Optimise coercion boxes agressively]
      | isDeadBinder b
923
      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
924
925
926
927
      , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
      = case altcon of
          DEFAULT -> go rhs
          _       -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
928
929
            where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst 
                                                 (zipEqual "simpleOptExpr" bs es)
930

batterseapower's avatar
batterseapower committed
931
      | otherwise
932
933
      = Case e' b' (substTy subst ty)
       		   (map (go_alt subst') as)
batterseapower's avatar
batterseapower committed
934
935
936
        where
          e' = go e
          (subst', b') = subst_opt_bndr subst b
937
938

    ----------------------
939
940
    go_alt subst (con, bndrs, rhs) 
      = (con, bndrs', simple_opt_expr subst' rhs)
941
      where
942
	(subst', bndrs') = subst_opt_bndrs subst bndrs
943
944

    ----------------------
945
946
947
948
949
950
951
952
953
954
955
956
    -- go_lam tries eta reduction
    go_lam bs' subst (Lam b e) 
       = go_lam (b':bs') subst' e
       where
         (subst', b') = subst_opt_bndr subst b
    go_lam bs' subst e 
       | Just etad_e <- tryEtaReduce bs e' = etad_e
       | otherwise                         = mkLams bs e'
       where
         bs = reverse bs'
         e' = simple_opt_expr subst e

957
958
959
960
961
962
963
964
965
966
967
968
----------------------
-- simple_app collects arguments for beta reduction
simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr
simple_app subst (App e1 e2) as   
  = simple_app subst e1 (simple_opt_expr subst e2 : as)
simple_app subst (Lam b e) (a:as) 
  = case maybe_substitute subst b a of
      Just ext_subst -> simple_app ext_subst e as
      Nothing        -> Let (NonRec b2 a) (simple_app subst' e as)
  where
    (subst', b') = subst_opt_bndr subst b
    b2 = add_info subst' b b'
969
970
971
972
simple_app subst (Var v) as
  | isCompulsoryUnfolding (idUnfolding v)
  -- See Note [Unfold compulsory unfoldings in LHSs]
  =  simple_app subst (unfoldingTemplate (idUnfolding v)) as
973
974
975
simple_app subst e as
  = foldl App (simple_opt_expr subst e) as

976
----------------------
977
978
979
980
981
982
simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
simple_opt_bind s b 		  -- Can add trace stuff here
  = simple_opt_bind' s b

simple_opt_bind' subst (Rec prs)
  = (subst'', res_bind)
983
  where
984
    res_bind            = Just (Rec (reverse rev_prs'))
985
986
    (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
    (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
987
988
989
    do_pr (subst, prs) ((b,r), b') 
       = case maybe_substitute subst b r2 of
           Just subst' -> (subst', prs)
990
           Nothing     -> (subst,  (b2,r2):prs)
991
992
993
       where
         b2 = add_info subst b b'
         r2 = simple_opt_expr subst r
994

995
simple_opt_bind' subst (NonRec b r)
996
997
998
999
  = simple_opt_out_bind subst (b, simple_opt_expr subst r)

----------------------
simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
1000
1001
1002
1003
1004
simple_opt_out_bind subst (b, r') 
  | Just ext_subst <- maybe_substitute subst b r'
  = (ext_subst, Nothing)
  | otherwise
  = (subst', Just (NonRec b2 r'))
1005
1006
1007
  where
    (subst', b') = subst_opt_bndr subst b
    b2 = add_info subst' b b'
1008
1009

----------------------
1010
1011
maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
    -- (maybe_substitute subst in_var out_rhs)  
1012
    --   either extends subst with (in_var -> out_rhs)
1013
1014
    --   or     returns Nothing
maybe_substitute subst b r
1015
  | Type ty <- r 	-- let a::* = TYPE ty in <body>
1016
  = ASSERT( isTyVar b )
1017
    Just (extendTvSubst subst b ty)
1018

1019
1020
1021
1022
1023
  | Coercion co <- r
  = ASSERT( isCoVar b )
    Just (extendCvSubst subst b co)

  | isId b              -- let x = e in <body>
1024
1025
  , not (isCoVar b)	-- See Note [Do not inline CoVars unconditionally]
    		 	-- in SimplUtils
1026
1027
1028
1029
  , safe_to_inline (idOccInfo b) 
  , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
  , not (isStableUnfolding (idUnfolding b))
  , not (isExportedId b)
1030
  , not (isUnLiftedType (idType b)) || exprOkForSpeculation r
1031
  = Just (extendIdSubst subst b r)
1032
1033
  
  | otherwise
1034
  = Nothing
1035
  where
1036
1037
1038
	-- Unconditionally safe to inline
    safe_to_inline :: OccInfo -> Bool
    safe_to_inline (IAmALoopBreaker {})     = False
1039
    safe_to_inline IAmDead                  = True
batterseapower's avatar
batterseapower committed
1040
1041
1042
1043
    safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial
    safe_to_inline NoOccInfo                = trivial

    trivial | exprIsTrivial r = True
1044
            | (Var fun, args) <- collectArgs r
batterseapower's avatar
batterseapower committed
1045
            , Just dc <- isDataConWorkId_maybe fun
1046
            , dc `hasKey` eqBoxDataConKey || dc `hasKey` coercibleDataConKey
1047
            , all exprIsTrivial args = True -- See Note [Optimise coercion boxes agressively]
batterseapower's avatar
batterseapower committed
1048
            | otherwise = False
1049
1050
1051
1052

----------------------
subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
subst_opt_bndr subst bndr
1053
1054
1055
  | isTyVar bndr  = substTyVarBndr subst bndr
  | isCoVar bndr  = substCoVarBndr subst bndr
  | otherwise     = subst_opt_id_bndr subst bndr
1056
1057
1058
1059
1060
1061

subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
-- Nuke all fragile IdInfo, unfolding, and RULES; 
--    it gets added back later by add_info
-- Rather like SimplEnv.substIdBndr
--
1062
-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr 
1063
1064
-- carefully does not do) because simplOptExpr invalidates it

1065
1066
subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
  = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
  where
    id1	   = uniqAway in_scope old_id
    id2    = setIdType id1 (substTy subst (idType old_id))
    new_id = zapFragileIdInfo id2	-- Zaps rules, worker-info, unfolding
					-- and fragile OccInfo
    new_in_scope = in_scope `extendInScopeSet` new_id

	-- Extend the substitution if the unique has changed,
	-- or there's some useful occurrence information
	-- See the notes with substTyVarBndr for the delSubstEnv
    new_id_subst | new_id /= old_id
	         = extendVarEnv id_subst old_id (Var new_id)
	         | otherwise 
	         = delVarEnv id_subst old_id

----------------------
subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
subst_opt_bndrs subst bndrs
  = mapAccumL subst_opt_bndr subst bndrs

----------------------
add_info :: Subst -> InVar -> OutVar -> OutVar
1089
1090
1091
add_info subst old_bndr new_bndr
 | isTyVar old_bndr = new_bndr
 | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
1092
1093
 where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)

1094
1095
1096
1097
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun id 
  | isAlwaysActive (idInlineActivation id) = idUnfolding id
  | otherwise                              = noUnfolding
1098
\end{code}
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116

Note [Inline prag in simplOpt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If there's an INLINE/NOINLINE pragma that restricts the phase in 
which the binder can be inlined, we don't inline here; after all,
we don't know what phase we're in.  Here's an example

  foo :: Int -> Int -> Int
  {-# INLINE foo #-}
  foo m n = inner m
     where
       {-# INLINE [1] inner #-}
       inner m = m+n

  bar :: Int -> Int
  bar n = foo n 1

When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
1117
1118
to remain visible until Phase 1

1119
1120
1121
1122
1123
1124
1125
Note [Unfold compulsory unfoldings in LHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When the user writes `map coerce = coerce` as a rule, the rule will only ever
match if we replace coerce by its unfolding on the LHS, because that is the
core that the rule matching engine will find. So do that for everything that
has a compulsory unfolding. Also see Note [Desugaring coerce as cast]
1126

1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
%************************************************************************
%*                                                                      *
         exprIsConApp_maybe
%*                                                                      *
%************************************************************************

Note [exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~
exprIsConApp_maybe is a very important function.  There are two principal
uses:
  * case e of { .... }
  * cls_op e, where cls_op is a class operation

In both cases you want to know if e is of form (C e1..en) where C is
a data constructor.

However e might not *look* as if 

\begin{code}
data ConCont = CC [CoreExpr] Coercion   
                  -- Substitution already applied

-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is 
-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
-- where t1..tk are the *universally-qantified* type args of 'dc'
1152
1153
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope, id_unf) expr
1154
  = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr)))
1155
1156
1157
1158
  where
    go :: Either InScopeSet Subst 
       -> CoreExpr -> ConCont 
       -> Maybe (DataCon, [Type], [CoreExpr])
1159
1160
    go subst (Tick t expr) cont
       | not (tickishIsCode t) = go subst expr cont
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
    go subst (Cast expr co1) (CC [] co2)
       = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2))
    go subst (App fun arg) (CC args co)
       = go subst fun (CC (subst_arg subst arg : args) co)
    go subst (Lam var body) (CC (arg:args) co)
       | exprIsTrivial arg          -- Don't duplicate stuff!
       = go (extend subst var arg) body (CC args co)
    go (Right sub) (Var v) cont
       = go (Left (substInScope sub)) 
            (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) 
            cont

    go (Left in_scope) (Var fun) cont@(CC args co)
        | Just con <- isDataConWorkId_maybe fun
        , count isValArg args == idArity fun
1176
        = dealWithCoercion co con args
1177
1178

        -- Look through dictionary functions; see Note [Unfolding DFuns]