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