6c8c90c79cd917470dc9fc019fd815a9493a0f19
[ghc.git] / compiler / coreSyn / CoreSubst.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Utility functions on @Core@ syntax
7
8 \begin{code}
9 module CoreSubst (
10         -- * Main data types
11         Subst(..), -- Implementation exported for supercompiler's Renaming.hs only
12         TvSubstEnv, IdSubstEnv, InScopeSet,
13
14         -- ** Substituting into expressions and related types
15         deShadowBinds, substSpec, substRulesForImportedIds,
16         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
17         substUnfolding, substUnfoldingSC,
18         substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
19
20         -- ** Operations on substitutions
21         emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
22         extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
23         extendCvSubst, extendCvSubstList,
24         extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
25         addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
26         isInScope, setInScope,
27         delBndr, delBndrs,
28
29         -- ** Substituting and cloning binders
30         substBndr, substBndrs, substRecBndrs,
31         cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
32
33         -- ** Simple expression optimiser
34         simpleOptPgm, simpleOptExpr, simpleOptExprWith,
35         exprIsConApp_maybe, exprIsLiteral_maybe
36     ) where
37
38 #include "HsVersions.h"
39
40 import CoreSyn
41 import CoreFVs
42 import CoreUtils
43 import Literal  ( Literal )
44 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
45
46 import qualified Type
47 import qualified Coercion
48
49         -- We are defining local versions
50 import Type     hiding ( substTy, extendTvSubst, extendTvSubstList
51                        , isInScope, substTyVarBndr, cloneTyVarBndr )
52 import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
53
54 import TcType      ( tcSplitDFunTy )
55 import TyCon       ( tyConArity )
56 import DataCon
57 import PrelNames   ( eqBoxDataConKey )
58 import OptCoercion ( optCoercion )
59 import PprCore     ( pprCoreBindings, pprRules )
60 import Module      ( Module )
61 import VarSet
62 import VarEnv
63 import Id
64 import Name     ( Name )
65 import Var
66 import IdInfo
67 import Unique
68 import UniqSupply
69 import Maybes
70 import ErrUtils
71 import DynFlags   ( DynFlags, DynFlag(..) )
72 import BasicTypes ( isAlwaysActive )
73 import Util
74 import Pair
75 import Outputable
76 import PprCore          ()              -- Instances
77 import FastString
78
79 import Data.List
80 \end{code}
81
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection{Substitutions}
86 %*                                                                      *
87 %************************************************************************
88
89 \begin{code}
90 -- | A substitution environment, containing both 'Id' and 'TyVar' substitutions.
91 --
92 -- Some invariants apply to how you use the substitution:
93 --
94 -- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/
95 -- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the
96 -- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.
97 --
98 -- 2. #apply_once# You may apply the substitution only /once/
99 --
100 -- There are various ways of setting up the in-scope set such that the first of these invariants hold:
101 --
102 -- * Arrange that the in-scope set really is all the things in scope
103 --
104 -- * Arrange that it's the free vars of the range of the substitution
105 --
106 -- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash
107 data Subst 
108   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
109                       -- applying the substitution
110           IdSubstEnv  -- Substitution for Ids
111           TvSubstEnv  -- Substitution from TyVars to Types
112           CvSubstEnv  -- Substitution from CoVars to Coercions
113
114         -- INVARIANT 1: See #in_scope_invariant#
115         -- This is what lets us deal with name capture properly
116         -- It's a hard invariant to check...
117         --
118         -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with
119         --              Types.TvSubstEnv
120         --
121         -- INVARIANT 3: See Note [Extending the Subst]
122 \end{code}
123
124 Note [Extending the Subst]
125 ~~~~~~~~~~~~~~~~~~~~~~~~~~
126 For a core Subst, which binds Ids as well, we make a different choice for Ids
127 than we do for TyVars.  
128
129 For TyVars, see Note [Extending the TvSubst] with Type.TvSubstEnv
130
131 For Ids, we have a different invariant
132         The IdSubstEnv is extended *only* when the Unique on an Id changes
133         Otherwise, we just extend the InScopeSet
134
135 In consequence:
136
137 * If the TvSubstEnv and IdSubstEnv are both empty, substExpr would be a
138   no-op, so substExprSC ("short cut") does nothing.
139
140   However, substExpr still goes ahead and substitutes.  Reason: we may
141   want to replace existing Ids with new ones from the in-scope set, to
142   avoid space leaks.
143
144 * In substIdBndr, we extend the IdSubstEnv only when the unique changes
145
146 * If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
147   substExpr does nothing (Note that the above rule for substIdBndr
148   maintains this property.  If the incoming envts are both empty, then
149   substituting the type and IdInfo can't change anything.)
150
151 * In lookupIdSubst, we *must* look up the Id in the in-scope set, because
152   it may contain non-trivial changes.  Example:
153         (/\a. \x:a. ...x...) Int
154   We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change
155   so we only extend the in-scope set.  Then we must look up in the in-scope
156   set when we find the occurrence of x.
157
158 * The requirement to look up the Id in the in-scope set means that we
159   must NOT take no-op short cut when the IdSubst is empty.
160   We must still look up every Id in the in-scope set.
161
162 * (However, we don't need to do so for expressions found in the IdSubst
163   itself, whose range is assumed to be correct wrt the in-scope set.)
164
165 Why do we make a different choice for the IdSubstEnv than the
166 TvSubstEnv and CvSubstEnv?
167
168 * For Ids, we change the IdInfo all the time (e.g. deleting the
169   unfolding), and adding it back later, so using the TyVar convention
170   would entail extending the substitution almost all the time
171
172 * The simplifier wants to look up in the in-scope set anyway, in case it 
173   can see a better unfolding from an enclosing case expression
174
175 * For TyVars, only coercion variables can possibly change, and they are 
176   easy to spot
177
178 \begin{code}
179 -- | An environment for substituting for 'Id's
180 type IdSubstEnv = IdEnv CoreExpr
181
182 ----------------------------
183 isEmptySubst :: Subst -> Bool
184 isEmptySubst (Subst _ id_env tv_env cv_env) 
185   = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
186
187 emptySubst :: Subst
188 emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
189
190 mkEmptySubst :: InScopeSet -> Subst
191 mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
192
193 mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
194 mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
195
196 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
197 substInScope :: Subst -> InScopeSet
198 substInScope (Subst in_scope _ _ _) = in_scope
199
200 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
201 -- while preserving the in-scope set
202 zapSubstEnv :: Subst -> Subst
203 zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
204
205 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
206 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
207 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
208 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
209 extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
210
211 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
212 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
213 extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
214
215 -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
216 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
217 extendTvSubst :: Subst -> TyVar -> Type -> Subst
218 extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
219
220 -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
221 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
222 extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
223
224 -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
225 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
226 extendCvSubst :: Subst -> CoVar -> Coercion -> Subst
227 extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)
228
229 -- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the
230 -- 'Subst': see also 'extendCvSubst'
231 extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst
232 extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
233
234 -- | Add a substitution appropriate to the thing being substituted
235 --   (whether an expression, type, or coercion). See also
236 --   'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
237 extendSubst :: Subst -> Var -> CoreArg -> Subst
238 extendSubst subst var arg
239   = case arg of
240       Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty
241       Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
242       _           -> ASSERT( isId    var ) extendIdSubst subst var arg
243
244 extendSubstWithVar :: Subst -> Var -> Var -> Subst
245 extendSubstWithVar subst v1 v2
246   | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
247   | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
248   | otherwise  = ASSERT( isId    v2 ) extendIdSubst subst v1 (Var v2)
249
250 -- | Add a substitution as appropriate to each of the terms being
251 --   substituted (whether expressions, types, or coercions). See also
252 --   'extendSubst'.
253 extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
254 extendSubstList subst []              = subst
255 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
256
257 -- | Find the substitution for an 'Id' in the 'Subst'
258 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
259 lookupIdSubst doc (Subst in_scope ids _ _) v
260   | not (isLocalId v) = Var v
261   | Just e  <- lookupVarEnv ids       v = e
262   | Just v' <- lookupInScope in_scope v = Var v'
263         -- Vital! See Note [Extending the Subst]
264   | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v 
265                             $$ ppr in_scope) 
266                 Var v
267
268 -- | Find the substitution for a 'TyVar' in the 'Subst'
269 lookupTvSubst :: Subst -> TyVar -> Type
270 lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
271
272 -- | Find the coercion substitution for a 'CoVar' in the 'Subst'
273 lookupCvSubst :: Subst -> CoVar -> Coercion
274 lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
275
276 delBndr :: Subst -> Var -> Subst
277 delBndr (Subst in_scope ids tvs cvs) v
278   | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
279   | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
280   | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
281
282 delBndrs :: Subst -> [Var] -> Subst
283 delBndrs (Subst in_scope ids tvs cvs) vs
284   = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
285       -- Easist thing is just delete all from all!
286
287 -- | Simultaneously substitute for a bunch of variables
288 --   No left-right shadowing
289 --   ie the substitution for   (\x \y. e) a1 a2
290 --      so neither x nor y scope over a1 a2
291 mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
292 mkOpenSubst in_scope pairs = Subst in_scope
293                                    (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
294                                    (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
295                                    (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
296
297 ------------------------------
298 isInScope :: Var -> Subst -> Bool
299 isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
300
301 -- | Add the 'Var' to the in-scope set, but do not remove
302 -- any existing substitutions for it
303 addInScopeSet :: Subst -> VarSet -> Subst
304 addInScopeSet (Subst in_scope ids tvs cvs) vs
305   = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
306
307 -- | Add the 'Var' to the in-scope set: as a side effect,
308 -- and remove any existing substitutions for it
309 extendInScope :: Subst -> Var -> Subst
310 extendInScope (Subst in_scope ids tvs cvs) v
311   = Subst (in_scope `extendInScopeSet` v) 
312           (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
313
314 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
315 extendInScopeList :: Subst -> [Var] -> Subst
316 extendInScopeList (Subst in_scope ids tvs cvs) vs
317   = Subst (in_scope `extendInScopeSetList` vs) 
318           (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
319
320 -- | Optimized version of 'extendInScopeList' that can be used if you are certain 
321 -- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
322 extendInScopeIds :: Subst -> [Id] -> Subst
323 extendInScopeIds (Subst in_scope ids tvs cvs) vs 
324   = Subst (in_scope `extendInScopeSetList` vs) 
325           (ids `delVarEnvList` vs) tvs cvs
326
327 setInScope :: Subst -> InScopeSet -> Subst
328 setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
329 \end{code}
330
331 Pretty printing, for debugging only
332
333 \begin{code}
334 instance Outputable Subst where
335   ppr (Subst in_scope ids tvs cvs) 
336         =  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
337         $$ ptext (sLit " IdSubst   =") <+> ppr ids
338         $$ ptext (sLit " TvSubst   =") <+> ppr tvs
339         $$ ptext (sLit " CvSubst   =") <+> ppr cvs   
340          <> char '>'
341 \end{code}
342
343
344 %************************************************************************
345 %*                                                                      *
346         Substituting expressions
347 %*                                                                      *
348 %************************************************************************
349
350 \begin{code}
351 -- | Apply a substititon to an entire 'CoreExpr'. Rememeber, you may only 
352 -- apply the substitution /once/: see "CoreSubst#apply_once"
353 --
354 -- Do *not* attempt to short-cut in the case of an empty substitution!
355 -- See Note [Extending the Subst]
356 substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
357 substExprSC _doc subst orig_expr
358   | isEmptySubst subst = orig_expr
359   | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
360                          subst_expr subst orig_expr
361
362 substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
363 substExpr _doc subst orig_expr = subst_expr subst orig_expr
364
365 subst_expr :: Subst -> CoreExpr -> CoreExpr
366 subst_expr subst expr
367   = go expr
368   where
369     go (Var v)         = lookupIdSubst (text "subst_expr") subst v 
370     go (Type ty)       = Type (substTy subst ty)
371     go (Coercion co)   = Coercion (substCo subst co)
372     go (Lit lit)       = Lit lit
373     go (App fun arg)   = App (go fun) (go arg)
374     go (Note note e)   = Note (go_note note) (go e)
375     go (Cast e co)     = Cast (go e) (substCo subst co)
376        -- Do not optimise even identity coercions
377        -- Reason: substitution applies to the LHS of RULES, and
378        --         if you "optimise" an identity coercion, you may
379        --         lose a binder. We optimise the LHS of rules at
380        --         construction time
381
382     go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
383                        where
384                          (subst', bndr') = substBndr subst bndr
385
386     go (Let bind body) = Let bind' (subst_expr subst' body)
387                        where
388                          (subst', bind') = substBind subst bind
389
390     go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
391                                  where
392                                  (subst', bndr') = substBndr subst bndr
393
394     go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
395                                  where
396                                    (subst', bndrs') = substBndrs subst bndrs
397
398     go_note note             = note
399
400 -- | Apply a substititon to an entire 'CoreBind', additionally returning an updated 'Subst'
401 -- that should be used by subsequent substitutons.
402 substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
403
404 substBindSC subst bind    -- Short-cut if the substitution is empty
405   | not (isEmptySubst subst)
406   = substBind subst bind
407   | otherwise
408   = case bind of
409        NonRec bndr rhs -> (subst', NonRec bndr' rhs)
410           where
411             (subst', bndr') = substBndr subst bndr
412        Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
413           where
414             (bndrs, rhss)    = unzip pairs
415             (subst', bndrs') = substRecBndrs subst bndrs
416             rhss' | isEmptySubst subst' = rhss
417                   | otherwise           = map (subst_expr subst') rhss
418
419 substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr subst rhs))
420                                   where
421                                     (subst', bndr') = substBndr subst bndr
422
423 substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
424                             where
425                                 (bndrs, rhss)    = unzip pairs
426                                 (subst', bndrs') = substRecBndrs subst bndrs
427                                 rhss' = map (subst_expr subst') rhss
428 \end{code}
429
430 \begin{code}
431 -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
432 -- by running over the bindings with an empty substitution, becuase substitution
433 -- returns a result that has no-shadowing guaranteed.
434 --
435 -- (Actually, within a single /type/ there might still be shadowing, because 
436 -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
437 --
438 -- [Aug 09] This function is not used in GHC at the moment, but seems so 
439 --          short and simple that I'm going to leave it here
440 deShadowBinds :: CoreProgram -> CoreProgram
441 deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
442 \end{code}
443
444
445 %************************************************************************
446 %*                                                                      *
447         Substituting binders
448 %*                                                                      *
449 %************************************************************************
450
451 Remember that substBndr and friends are used when doing expression
452 substitution only.  Their only business is substitution, so they
453 preserve all IdInfo (suitably substituted).  For example, we *want* to
454 preserve occ info in rules.
455
456 \begin{code}
457 -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
458 -- the result and an updated 'Subst' that should be used by subsequent substitutons.
459 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
460 substBndr :: Subst -> Var -> (Subst, Var)
461 substBndr subst bndr
462   | isTyVar bndr  = substTyVarBndr subst bndr
463   | isCoVar bndr  = substCoVarBndr subst bndr
464   | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
465
466 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
467 substBndrs :: Subst -> [Var] -> (Subst, [Var])
468 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
469
470 -- | Substitute in a mutually recursive group of 'Id's
471 substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
472 substRecBndrs subst bndrs 
473   = (new_subst, new_bndrs)
474   where         -- Here's the reason we need to pass rec_subst to subst_id
475     (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
476 \end{code}
477
478
479 \begin{code}
480 substIdBndr :: SDoc 
481             -> Subst            -- ^ Substitution to use for the IdInfo
482             -> Subst -> Id      -- ^ Substitition and Id to transform
483             -> (Subst, Id)      -- ^ Transformed pair
484                                 -- NB: unfolding may be zapped
485
486 substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
487   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
488     (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
489   where
490     id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary
491     id2 | no_type_change = id1
492         | otherwise      = setIdType id1 (substTy subst old_ty)
493
494     old_ty = idType old_id
495     no_type_change = isEmptyVarEnv tvs || 
496                      isEmptyVarSet (Type.tyVarsOfType old_ty)
497
498         -- new_id has the right IdInfo
499         -- The lazy-set is because we're in a loop here, with 
500         -- rec_subst, when dealing with a mutually-recursive group
501     new_id = maybeModifyIdInfo mb_new_info id2
502     mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
503         -- NB: unfolding info may be zapped
504
505         -- Extend the substitution if the unique has changed
506         -- See the notes with substTyVarBndr for the delVarEnv
507     new_env | no_change = delVarEnv env old_id
508             | otherwise = extendVarEnv env old_id (Var new_id)
509
510     no_change = id1 == old_id
511         -- See Note [Extending the Subst]
512         -- it's /not/ necessary to check mb_new_info and no_type_change
513 \end{code}
514
515 Now a variant that unconditionally allocates a new unique.
516 It also unconditionally zaps the OccInfo.
517
518 \begin{code}
519 -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
520 -- each variable in its output.  It substitutes the IdInfo though.
521 cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
522 cloneIdBndr subst us old_id
523   = clone_id subst subst (old_id, uniqFromSupply us)
524
525 -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
526 -- substitution from left to right
527 cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
528 cloneIdBndrs subst us ids
529   = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
530
531 cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
532 -- Works for all kinds of variables (typically case binders)
533 -- not just Ids
534 cloneBndrs subst us vs
535   = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)
536
537 cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
538 cloneBndr subst uniq v
539       | isTyVar v = cloneTyVarBndr subst v uniq
540       | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too
541
542 -- | Clone a mutually recursive group of 'Id's
543 cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
544 cloneRecIdBndrs subst us ids
545   = (subst', ids')
546   where
547     (subst', ids') = mapAccumL (clone_id subst') subst
548                                (ids `zip` uniqsFromSupply us)
549
550 -- Just like substIdBndr, except that it always makes a new unique
551 -- It is given the unique to use
552 clone_id    :: Subst                    -- Substitution for the IdInfo
553             -> Subst -> (Id, Unique)    -- Substitition and Id to transform
554             -> (Subst, Id)              -- Transformed pair
555
556 clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
557   = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
558   where
559     id1     = setVarUnique old_id uniq
560     id2     = substIdType subst id1
561     new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
562     (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
563                         | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)
564 \end{code}
565
566
567 %************************************************************************
568 %*                                                                      *
569                 Types and Coercions
570 %*                                                                      *
571 %************************************************************************
572
573 For types and coercions we just call the corresponding functions in
574 Type and Coercion, but we have to repackage the substitution, from a
575 Subst to a TvSubst.
576
577 \begin{code}
578 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
579 substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
580   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
581         (TvSubst in_scope' tv_env', tv') 
582            -> (Subst in_scope' id_env tv_env' cv_env, tv')
583
584 cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)
585 cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq
586   = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of
587         (TvSubst in_scope' tv_env', tv') 
588            -> (Subst in_scope' id_env tv_env' cv_env, tv')
589
590 substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
591 substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
592   = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
593         (CvSubst in_scope' tv_env' cv_env', cv') 
594            -> (Subst in_scope' id_env tv_env' cv_env', cv')
595
596 -- | See 'Type.substTy'
597 substTy :: Subst -> Type -> Type 
598 substTy subst ty = Type.substTy (getTvSubst subst) ty
599
600 getTvSubst :: Subst -> TvSubst
601 getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv
602
603 getCvSubst :: Subst -> CvSubst
604 getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
605
606 -- | See 'Coercion.substCo'
607 substCo :: Subst -> Coercion -> Coercion
608 substCo subst co = Coercion.substCo (getCvSubst subst) co
609 \end{code}
610
611
612 %************************************************************************
613 %*                                                                      *
614 \section{IdInfo substitution}
615 %*                                                                      *
616 %************************************************************************
617
618 \begin{code}
619 substIdType :: Subst -> Id -> Id
620 substIdType subst@(Subst _ _ tv_env cv_env) id
621   | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
622   | otherwise   = setIdType id (substTy subst old_ty)
623                 -- The tyVarsOfType is cheaper than it looks
624                 -- because we cache the free tyvars of the type
625                 -- in a Note in the id's type itself
626   where
627     old_ty = idType id
628
629 ------------------
630 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
631 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
632 substIdInfo subst new_id info
633   | nothing_to_do = Nothing
634   | otherwise     = Just (info `setSpecInfo`      substSpec subst new_id old_rules
635                                `setUnfoldingInfo` substUnfolding subst old_unf)
636   where
637     old_rules     = specInfo info
638     old_unf       = unfoldingInfo info
639     nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
640     
641
642 ------------------
643 -- | Substitutes for the 'Id's within an unfolding
644 substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
645         -- Seq'ing on the returned Unfolding is enough to cause
646         -- all the substitutions to happen completely
647
648 substUnfoldingSC subst unf       -- Short-cut version
649   | isEmptySubst subst = unf
650   | otherwise          = substUnfolding subst unf
651
652 substUnfolding subst (DFunUnfolding ar con args)
653   = DFunUnfolding ar con (map subst_arg args)
654   where
655     subst_arg = substExpr (text "dfun-unf") subst
656
657 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
658         -- Retain an InlineRule!
659   | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work
660   = NoUnfolding
661   | otherwise                 -- But keep a stable one!
662   = seqExpr new_tmpl `seq` 
663     new_src `seq`
664     unf { uf_tmpl = new_tmpl, uf_src = new_src }
665   where
666     new_tmpl = substExpr (text "subst-unf") subst tmpl
667     new_src  = substUnfoldingSource subst src
668
669 substUnfolding _ unf = unf      -- NoUnfolding, OtherCon
670
671 -------------------
672 substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
673 substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
674   | Just wkr_expr <- lookupVarEnv ids wkr 
675   = case wkr_expr of
676       Var w1 -> InlineWrapper w1
677       _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr 
678                 --             <+> ifPprDebug (equals <+> ppr wkr_expr) )   
679                               -- Note [Worker inlining]
680                 InlineStable  -- It's not a wrapper any more, but still inline it!
681
682   | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
683   | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
684                 -- This can legitimately happen.  The worker has been inlined and
685                 -- dropped as dead code, because we don't treat the UnfoldingSource
686                 -- as an "occurrence".
687                 -- Note [Worker inlining]
688                 InlineStable
689
690 substUnfoldingSource _ src = src
691
692 ------------------
693 substIdOcc :: Subst -> Id -> Id
694 -- These Ids should not be substituted to non-Ids
695 substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
696                         Var v' -> v'
697                         other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
698
699 ------------------
700 -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
701 substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
702 substSpec subst new_id (SpecInfo rules rhs_fvs)
703   = seqSpecInfo new_spec `seq` new_spec
704   where
705     subst_ru_fn = const (idName new_id)
706     new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
707                         (substVarSet subst rhs_fvs)
708
709 ------------------
710 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
711 substRulesForImportedIds subst rules 
712   = map (substRule subst not_needed) rules
713   where
714     not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
715
716 ------------------
717 substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
718
719 -- The subst_ru_fn argument is applied to substitute the ru_fn field
720 -- of the rule:
721 --    - Rules for *imported* Ids never change ru_fn
722 --    - Rules for *local* Ids are in the IdInfo for that Id,
723 --      and the ru_fn field is simply replaced by the new name 
724 --      of the Id
725 substRule _ _ rule@(BuiltinRule {}) = rule
726 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
727                                        , ru_fn = fn_name, ru_rhs = rhs
728                                        , ru_local = is_local })
729   = rule { ru_bndrs = bndrs', 
730            ru_fn    = if is_local 
731                         then subst_ru_fn fn_name 
732                         else fn_name,
733            ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
734            ru_rhs   = simpleOptExprWith subst' rhs }
735            -- Do simple optimisation on RHS, in case substitution lets
736            -- you improve it.  The real simplifier never gets to look at it.
737   where
738     (subst', bndrs') = substBndrs subst bndrs
739
740 ------------------
741 substVects :: Subst -> [CoreVect] -> [CoreVect]
742 substVects subst = map (substVect subst)
743
744 ------------------
745 substVect :: Subst -> CoreVect -> CoreVect
746 substVect _subst (Vect   v Nothing)    = Vect   v Nothing
747 substVect subst  (Vect   v (Just rhs)) = Vect   v (Just (simpleOptExprWith subst rhs))
748 substVect _subst vd@(NoVect _)         = vd
749 substVect _subst vd@(VectType _ _ _)   = vd
750
751 ------------------
752 substVarSet :: Subst -> VarSet -> VarSet
753 substVarSet subst fvs
754   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
755   where
756     subst_fv subst fv 
757         | isId fv   = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
758         | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
759 \end{code}
760
761 Note [Worker inlining]
762 ~~~~~~~~~~~~~~~~~~~~~~
763 A worker can get sustituted away entirely.
764         - it might be trivial
765         - it might simply be very small
766 We do not treat an InlWrapper as an 'occurrence' in the occurence 
767 analyser, so it's possible that the worker is not even in scope any more.
768
769 In all all these cases we simply drop the special case, returning to
770 InlVanilla.  The WARN is just so I can see if it happens a lot.
771
772
773 %************************************************************************
774 %*                                                                      *
775         The Very Simple Optimiser
776 %*                                                                      *
777 %************************************************************************
778
779 Note [Optimise coercion boxes agressively]
780 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
781
782 The simple expression optimiser needs to deal with Eq# boxes as follows:
783  1. If the result of optimising the RHS of a non-recursive binding is an
784     Eq# box, that box is substituted rather than turned into a let, just as
785     if it were trivial.
786        let eqv = Eq# co in e ==> e[Eq# co/eqv]
787
788  2. If the result of optimising a case scrutinee is a Eq# box and the case
789     deconstructs it in a trivial way, we evaluate the case then and there.
790       case Eq# co of Eq# cov -> e ==> e[co/cov]
791
792 We do this for two reasons:
793
794  1. Bindings/case scrutinisation of this form is often created by the
795     evidence-binding mechanism and we need them to be inlined to be able
796     desugar RULE LHSes that involve equalities (see e.g. T2291)
797
798  2. The test T4356 fails Lint because it creates a coercion between types
799     of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this
800     inlining agressively we can collapse away the intermediate coercion between
801     these two types and hence pass Lint again. (This is a sort of a hack.)
802
803 In fact, our implementation uses slightly liberalised versions of the second rule
804 rule so that the optimisations are a bit more generally applicable. Precisely:
805  2a. We reduce any situation where we can spot a case-of-known-constructor
806
807 As a result, the only time we should get residual coercion boxes in the code is
808 when the type checker generates something like:
809
810   \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...)
811
812 However, the case of lambda-bound equality evidence is fairly rare, so these two
813 rules should suffice for solving the rule LHS problem for now.
814
815 Annoyingly, we cannot use this modified rule 1a instead of 1:
816
817  1a. If we come across a let-bound constructor application with trivial arguments,
818      add an appropriate unfolding to the let binder.  We spot constructor applications
819      by using exprIsConApp_maybe, so this would actually let rule 2a reduce more.
820
821 The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a
822 we wouldn't simplify this expression at all:
823
824   let eqv = Eq# co
825   in foo eqv (bar eqv)
826
827 The rule LHS desugarer can't deal with Let at all, so we need to push that box into
828 the use sites.
829
830 \begin{code}
831 simpleOptExpr :: CoreExpr -> CoreExpr
832 -- Do simple optimisation on an expression
833 -- The optimisation is very straightforward: just
834 -- inline non-recursive bindings that are used only once, 
835 -- or where the RHS is trivial
836 --
837 -- We also inline bindings that bind a Eq# box: see
838 -- See Note [Optimise coercion boxes agressively].
839 --
840 -- The result is NOT guaranteed occurence-analysed, becuase
841 -- in  (let x = y in ....) we substitute for x; so y's occ-info
842 -- may change radically
843
844 simpleOptExpr expr
845   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
846     simpleOptExprWith init_subst expr
847   where
848     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
849         -- It's potentially important to make a proper in-scope set
850         -- Consider  let x = ..y.. in \y. ...x...
851         -- Then we should remember to clone y before substituting
852         -- for x.  It's very unlikely to occur, because we probably
853         -- won't *be* substituting for x if it occurs inside a
854         -- lambda.  
855         --
856         -- It's a bit painful to call exprFreeVars, because it makes
857         -- three passes instead of two (occ-anal, and go)
858
859 simpleOptExprWith :: Subst -> InExpr -> OutExpr
860 simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
861
862 ----------------------
863 simpleOptPgm :: DynFlags -> Module 
864              -> CoreProgram -> [CoreRule] -> [CoreVect] 
865              -> IO (CoreProgram, [CoreRule], [CoreVect])
866 simpleOptPgm dflags this_mod binds rules vects
867   = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
868                        (pprCoreBindings occ_anald_binds $$ pprRules rules );
869
870        ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
871   where
872     occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
873                                        rules vects binds
874     (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
875                        
876     do_one (subst, binds') bind 
877       = case simple_opt_bind subst bind of
878           (subst', Nothing)    -> (subst', binds')
879           (subst', Just bind') -> (subst', bind':binds')
880
881 ----------------------
882 type InVar   = Var
883 type OutVar  = Var
884 type InId    = Id
885 type OutId   = Id
886 type InExpr  = CoreExpr
887 type OutExpr = CoreExpr
888
889 -- In these functions the substitution maps InVar -> OutExpr
890
891 ----------------------
892 simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
893 simple_opt_expr s e = simple_opt_expr' s e
894
895 simple_opt_expr' subst expr
896   = go expr
897   where
898     go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
899     go (App e1 e2)      = simple_app subst e1 [go e2]
900     go (Type ty)        = Type     (substTy subst ty)
901     go (Coercion co)    = Coercion (optCoercion (getCvSubst subst) co)
902     go (Lit lit)        = Lit lit
903     go (Note note e)    = Note note (go e)
904     go (Cast e co)      | isReflCo co' = go e
905                         | otherwise    = Cast (go e) co' 
906                         where
907                           co' = optCoercion (getCvSubst subst) co
908
909     go (Let bind body) = case simple_opt_bind subst bind of
910                            (subst', Nothing)   -> simple_opt_expr subst' body
911                            (subst', Just bind) -> Let bind (simple_opt_expr subst' body)
912
913     go lam@(Lam {})     = go_lam [] subst lam
914     go (Case e b ty as)
915        -- See Note [Optimise coercion boxes agressively]
916       | isDeadBinder b
917       , Just (con, _tys, es) <- expr_is_con_app e'
918       , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
919       = case altcon of
920           DEFAULT -> go rhs
921           _       -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
922             where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst (zipEqual "simpleOptExpr" bs es)
923
924       | otherwise
925       = Case e' b' (substTy subst ty)
926                    (map (go_alt subst') as)
927         where
928           e' = go e
929           (subst', b') = subst_opt_bndr subst b
930
931     ----------------------
932     go_alt subst (con, bndrs, rhs) 
933       = (con, bndrs', simple_opt_expr subst' rhs)
934       where
935         (subst', bndrs') = subst_opt_bndrs subst bndrs
936
937     ----------------------
938     -- go_lam tries eta reduction
939     go_lam bs' subst (Lam b e) 
940        = go_lam (b':bs') subst' e
941        where
942          (subst', b') = subst_opt_bndr subst b
943     go_lam bs' subst e 
944        | Just etad_e <- tryEtaReduce bs e' = etad_e
945        | otherwise                         = mkLams bs e'
946        where
947          bs = reverse bs'
948          e' = simple_opt_expr subst e
949
950 ----------------------
951 -- simple_app collects arguments for beta reduction
952 simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr
953 simple_app subst (App e1 e2) as   
954   = simple_app subst e1 (simple_opt_expr subst e2 : as)
955 simple_app subst (Lam b e) (a:as) 
956   = case maybe_substitute subst b a of
957       Just ext_subst -> simple_app ext_subst e as
958       Nothing        -> Let (NonRec b2 a) (simple_app subst' e as)
959   where
960     (subst', b') = subst_opt_bndr subst b
961     b2 = add_info subst' b b'
962 simple_app subst e as
963   = foldl App (simple_opt_expr subst e) as
964
965 ----------------------
966 simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
967 simple_opt_bind s b               -- Can add trace stuff here
968   = simple_opt_bind' s b
969
970 simple_opt_bind' subst (Rec prs)
971   = (subst'', res_bind)
972   where
973     res_bind            = Just (Rec (reverse rev_prs'))
974     (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
975     (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
976     do_pr (subst, prs) ((b,r), b') 
977        = case maybe_substitute subst b r2 of
978            Just subst' -> (subst', prs)
979            Nothing     -> (subst,  (b2,r2):prs)
980        where
981          b2 = add_info subst b b'
982          r2 = simple_opt_expr subst r
983
984 simple_opt_bind' subst (NonRec b r)
985   = simple_opt_out_bind subst (b, simple_opt_expr subst r)
986
987 ----------------------
988 simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
989 simple_opt_out_bind subst (b, r') = case maybe_substitute subst b r' of
990       Just ext_subst -> (ext_subst, Nothing)
991       Nothing        -> (subst', Just (NonRec b2 r'))
992   where
993     (subst', b') = subst_opt_bndr subst b
994     b2 = add_info subst' b b'
995
996 ----------------------
997 maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
998     -- (maybe_substitute subst in_var out_rhs)  
999     --   either extends subst with (in_var -> out_rhs)
1000     --   or     returns Nothing
1001 maybe_substitute subst b r
1002   | Type ty <- r        -- let a::* = TYPE ty in <body>
1003   = ASSERT( isTyVar b )
1004     Just (extendTvSubst subst b ty)
1005
1006   | Coercion co <- r
1007   = ASSERT( isCoVar b )
1008     Just (extendCvSubst subst b co)
1009
1010   | isId b              -- let x = e in <body>
1011   , safe_to_inline (idOccInfo b) 
1012   , isAlwaysActive (idInlineActivation b)       -- Note [Inline prag in simplOpt]
1013   , not (isStableUnfolding (idUnfolding b))
1014   , not (isExportedId b)
1015   , not (isUnLiftedType (idType b)) || exprOkForSpeculation r
1016   = Just (extendIdSubst subst b r)
1017   
1018   | otherwise
1019   = Nothing
1020   where
1021         -- Unconditionally safe to inline
1022     safe_to_inline :: OccInfo -> Bool
1023     safe_to_inline (IAmALoopBreaker {})     = False
1024     safe_to_inline IAmDead                  = True
1025     safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial
1026     safe_to_inline NoOccInfo                = trivial
1027
1028     trivial | exprIsTrivial r = True
1029             | (Var fun, args) <- collectArgs r
1030             , Just dc <- isDataConWorkId_maybe fun
1031             , dc `hasKey` eqBoxDataConKey
1032             , all exprIsTrivial args = True -- See Note [Optimise coercion boxes agressively]
1033             | otherwise = False
1034
1035 ----------------------
1036 subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
1037 subst_opt_bndr subst bndr
1038   | isTyVar bndr  = substTyVarBndr subst bndr
1039   | isCoVar bndr  = substCoVarBndr subst bndr
1040   | otherwise     = subst_opt_id_bndr subst bndr
1041
1042 subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
1043 -- Nuke all fragile IdInfo, unfolding, and RULES; 
1044 --    it gets added back later by add_info
1045 -- Rather like SimplEnv.substIdBndr
1046 --
1047 -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr 
1048 -- carefully does not do) because simplOptExpr invalidates it
1049
1050 subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
1051   = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
1052   where
1053     id1    = uniqAway in_scope old_id
1054     id2    = setIdType id1 (substTy subst (idType old_id))
1055     new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
1056                                         -- and fragile OccInfo
1057     new_in_scope = in_scope `extendInScopeSet` new_id
1058
1059         -- Extend the substitution if the unique has changed,
1060         -- or there's some useful occurrence information
1061         -- See the notes with substTyVarBndr for the delSubstEnv
1062     new_id_subst | new_id /= old_id
1063                  = extendVarEnv id_subst old_id (Var new_id)
1064                  | otherwise 
1065                  = delVarEnv id_subst old_id
1066
1067 ----------------------
1068 subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
1069 subst_opt_bndrs subst bndrs
1070   = mapAccumL subst_opt_bndr subst bndrs
1071
1072 ----------------------
1073 add_info :: Subst -> InVar -> OutVar -> OutVar
1074 add_info subst old_bndr new_bndr
1075  | isTyVar old_bndr = new_bndr
1076  | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
1077  where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
1078
1079 expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr])
1080 expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding)
1081 \end{code}
1082
1083 Note [Inline prag in simplOpt]
1084 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1085 If there's an INLINE/NOINLINE pragma that restricts the phase in 
1086 which the binder can be inlined, we don't inline here; after all,
1087 we don't know what phase we're in.  Here's an example
1088
1089   foo :: Int -> Int -> Int
1090   {-# INLINE foo #-}
1091   foo m n = inner m
1092      where
1093        {-# INLINE [1] inner #-}
1094        inner m = m+n
1095
1096   bar :: Int -> Int
1097   bar n = foo n 1
1098
1099 When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
1100 to remain visible until Phase 1
1101
1102
1103 %************************************************************************
1104 %*                                                                      *
1105          exprIsConApp_maybe
1106 %*                                                                      *
1107 %************************************************************************
1108
1109 Note [exprIsConApp_maybe]
1110 ~~~~~~~~~~~~~~~~~~~~~~~~~
1111 exprIsConApp_maybe is a very important function.  There are two principal
1112 uses:
1113   * case e of { .... }
1114   * cls_op e, where cls_op is a class operation
1115
1116 In both cases you want to know if e is of form (C e1..en) where C is
1117 a data constructor.
1118
1119 However e might not *look* as if 
1120
1121 \begin{code}
1122 data ConCont = CC [CoreExpr] Coercion   
1123                   -- Substitution already applied
1124
1125 -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is 
1126 -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
1127 -- where t1..tk are the *universally-qantified* type args of 'dc'
1128 exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
1129 exprIsConApp_maybe id_unf expr
1130   = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr)))
1131   where
1132     in_scope = mkInScopeSet (exprFreeVars expr)
1133
1134     go :: Either InScopeSet Subst 
1135        -> CoreExpr -> ConCont 
1136        -> Maybe (DataCon, [Type], [CoreExpr])
1137     go subst (Note note expr) cont 
1138        | notSccNote note = go subst expr cont
1139     go subst (Cast expr co1) (CC [] co2)
1140        = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2))
1141     go subst (App fun arg) (CC args co)
1142        = go subst fun (CC (subst_arg subst arg : args) co)
1143     go subst (Lam var body) (CC (arg:args) co)
1144        | exprIsTrivial arg          -- Don't duplicate stuff!
1145        = go (extend subst var arg) body (CC args co)
1146     go (Right sub) (Var v) cont
1147        = go (Left (substInScope sub)) 
1148             (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) 
1149             cont
1150
1151     go (Left in_scope) (Var fun) cont@(CC args co)
1152         | Just con <- isDataConWorkId_maybe fun
1153         , count isValArg args == idArity fun
1154         , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
1155         = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args)
1156
1157         -- Look through dictionary functions; see Note [Unfolding DFuns]
1158         | DFunUnfolding dfun_nargs con ops <- unfolding
1159         , length args == dfun_nargs    -- See Note [DFun arity check]
1160         , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
1161               subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
1162               mk_arg e = mkApps e args
1163         = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops)
1164
1165         -- Look through unfoldings, but only cheap ones, because
1166         -- we are effectively duplicating the unfolding
1167         | Just rhs <- expandUnfolding_maybe unfolding
1168         = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
1169           let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
1170               res = go (Left in_scope') rhs cont
1171           in WARN( unfoldingArity unfolding > 0 && isJust res,
1172                    text "Interesting! exprIsConApp_maybe:" 
1173                    <+> ppr fun <+> ppr expr)
1174              res
1175         where
1176           unfolding = id_unf fun
1177
1178     go _ _ _ = Nothing
1179
1180     ----------------------------
1181     -- Operations on the (Either InScopeSet CoreSubst)
1182     -- The Left case is wildly dominant
1183     subst_co (Left {}) co = co
1184     subst_co (Right s) co = CoreSubst.substCo s co
1185
1186     subst_arg (Left {}) e = e
1187     subst_arg (Right s) e = substExpr (text "exprIsConApp") s e
1188
1189     extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
1190     extend (Right s)       v e = Right (extendSubst s v e)
1191
1192 dealWithCoercion :: Coercion
1193                  -> (DataCon, [Type], [CoreExpr])
1194                  -> Maybe (DataCon, [Type], [CoreExpr])
1195 dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
1196   | isReflCo co 
1197   = Just stuff
1198
1199   | Pair _from_ty to_ty <- coercionKind co
1200   , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
1201   , to_tc == dataConTyCon dc
1202         -- These two tests can fail; we might see 
1203         --      (C x y) `cast` (g :: T a ~ S [a]),
1204         -- where S is a type function.  In fact, exprIsConApp
1205         -- will probably not be called in such circumstances,
1206         -- but there't nothing wrong with it 
1207
1208   =     -- Here we do the KPush reduction rule as described in the FC paper
1209         -- The transformation applies iff we have
1210         --      (C e1 ... en) `cast` co
1211         -- where co :: (T t1 .. tn) ~ to_ty
1212         -- The left-hand one must be a T, because exprIsConApp returned True
1213         -- but the right-hand one might not be.  (Though it usually will.)
1214     let
1215         tc_arity       = tyConArity to_tc
1216         dc_univ_tyvars = dataConUnivTyVars dc
1217         dc_ex_tyvars   = dataConExTyVars dc
1218         arg_tys        = dataConRepArgTys dc
1219
1220         (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
1221
1222         -- Make the "theta" from Fig 3 of the paper
1223         gammas = decomposeCo tc_arity co
1224         theta_subst = liftCoSubstWith 
1225                          (dc_univ_tyvars ++ dc_ex_tyvars)
1226                          (gammas         ++ map mkReflCo (stripTypeArgs ex_args))
1227
1228           -- Cast the value arguments (which include dictionaries)
1229         new_val_args = zipWith cast_arg arg_tys val_args
1230         cast_arg arg_ty arg = mkCoerce (theta_subst arg_ty) arg
1231
1232         dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
1233                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
1234                          ppr ex_args, ppr val_args]
1235     in
1236     ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc )
1237     ASSERT2( all isTypeArg ex_args, dump_doc )
1238     ASSERT2( equalLength val_args arg_tys, dump_doc )
1239     Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
1240
1241   | otherwise
1242   = Nothing
1243
1244 stripTypeArgs :: [CoreExpr] -> [Type]
1245 stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
1246                      [ty | Type ty <- args]
1247   -- We really do want isTypeArg here, not isTyCoArg!
1248 \end{code}
1249
1250 Note [Unfolding DFuns]
1251 ~~~~~~~~~~~~~~~~~~~~~~
1252 DFuns look like
1253
1254   df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
1255   df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
1256                                ($c2 a b d_a d_b)
1257
1258 So to split it up we just need to apply the ops $c1, $c2 etc
1259 to the very same args as the dfun.  It takes a little more work
1260 to compute the type arguments to the dictionary constructor.
1261
1262 Note [DFun arity check]
1263 ~~~~~~~~~~~~~~~~~~~~~~~
1264 Here we check that the total number of supplied arguments (inclding 
1265 type args) matches what the dfun is expecting.  This may be *less*
1266 than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
1267
1268 \begin{code}
1269 exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal
1270 -- Same deal as exprIsConApp_maybe, but much simpler
1271 -- Nevertheless we do need to look through unfoldings for
1272 -- Integer literals, which are vigorously hoisted to top level
1273 -- and not subsequently inlined
1274 exprIsLiteral_maybe id_unf e
1275   = case e of
1276       Lit l     -> Just l
1277       Note _ e' -> exprIsLiteral_maybe id_unf e'
1278       Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)
1279                 -> exprIsLiteral_maybe id_unf rhs
1280       _         -> Nothing
1281 \end{code}