8964079453e4e3d20cd4a3b58a5bb1f3fd704f5a
[ghc.git] / compiler / simplCore / SimplEnv.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplMonad]{The simplifier Monad}
5
6 \begin{code}
7 module SimplEnv (
8         InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
9         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
10         InCoercion, OutCoercion,
11
12         -- The simplifier mode
13         setMode, getMode, updMode,
14
15         -- Switch checker
16         SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
17         isAmongSimpl, intSwitchSet, switchIsOn,
18
19         setEnclosingCC, getEnclosingCC,
20
21         -- Environments
22         SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract
23         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
24         zapSubstEnv, setSubstEnv, 
25         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
26         getSimplRules, inGentleMode,
27
28         SimplSR(..), mkContEx, substId, lookupRecBndr,
29
30         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
31         simplBinder, simplBinders, addBndrRules,
32         substExpr, substTy, getTvSubst, mkCoreSubst,
33
34         -- Floats
35         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
36         wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
37         doFloatFromRhs, getFloats
38     ) where
39
40 #include "HsVersions.h"
41
42 import SimplMonad
43 import IdInfo
44 import CoreSyn
45 import CoreUtils
46 import CostCentre
47 import Var
48 import VarEnv
49 import VarSet
50 import OrdList
51 import Id
52 import qualified CoreSubst      ( Subst, mkSubst, substExpr, substSpec, substUnfolding )
53 import qualified Type           ( substTy, substTyVarBndr )
54 import Type hiding              ( substTy, substTyVarBndr )
55 import Coercion
56 import BasicTypes       
57 import DynFlags
58 import MonadUtils
59 import Outputable
60 import FastString
61
62 import Data.List
63 \end{code}
64
65 %************************************************************************
66 %*                                                                      *
67 \subsection[Simplify-types]{Type declarations}
68 %*                                                                      *
69 %************************************************************************
70
71 \begin{code}
72 type InBndr     = CoreBndr
73 type InId       = Id                    -- Not yet cloned
74 type InType     = Type                  -- Ditto
75 type InBind     = CoreBind
76 type InExpr     = CoreExpr
77 type InAlt      = CoreAlt
78 type InArg      = CoreArg
79 type InCoercion = Coercion
80
81 type OutBndr     = CoreBndr
82 type OutId       = Id                   -- Cloned
83 type OutTyVar    = TyVar                -- Cloned
84 type OutType     = Type                 -- Cloned
85 type OutCoercion = Coercion
86 type OutBind     = CoreBind
87 type OutExpr     = CoreExpr
88 type OutAlt      = CoreAlt
89 type OutArg      = CoreArg
90 \end{code}
91
92 %************************************************************************
93 %*                                                                      *
94 \subsubsection{The @SimplEnv@ type}
95 %*                                                                      *
96 %************************************************************************
97
98
99 \begin{code}
100 data SimplEnv
101   = SimplEnv {
102      ----------- Static part of the environment -----------
103      -- Static in the sense of lexically scoped, 
104      -- wrt the original expression
105
106         seMode      :: SimplifierMode,
107         seChkr      :: SwitchChecker,
108         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
109
110         -- The current substitution
111         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
112         seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr
113
114      ----------- Dynamic part of the environment -----------
115      -- Dynamic in the sense of describing the setup where
116      -- the expression finally ends up
117
118         -- The current set of in-scope variables
119         -- They are all OutVars, and all bound in this module
120         seInScope   :: InScopeSet,      -- OutVars only
121                 -- Includes all variables bound by seFloats
122         seFloats    :: Floats
123                 -- See Note [Simplifier floats]
124     }
125
126 type StaticEnv = SimplEnv       -- Just the static part is relevant
127
128 pprSimplEnv :: SimplEnv -> SDoc
129 -- Used for debugging; selective
130 pprSimplEnv env
131   = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
132           ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ]
133
134 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
135         -- See Note [Extending the Subst] in CoreSubst
136
137 data SimplSR
138   = DoneEx OutExpr              -- Completed term
139   | DoneId OutId                -- Completed term variable
140   | ContEx TvSubstEnv           -- A suspended substitution
141            SimplIdSubst
142            InExpr        
143
144 instance Outputable SimplSR where
145   ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
146   ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
147   ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
148                                 ppr (filter_env tv), ppr (filter_env id) -}]
149         -- where
150         -- fvs = exprFreeVars e
151         -- filter_env env = filterVarEnv_Directly keep env
152         -- keep uniq _ = uniq `elemUFM_Directly` fvs
153 \end{code}
154
155
156 seInScope: 
157         The in-scope part of Subst includes *all* in-scope TyVars and Ids
158         The elements of the set may have better IdInfo than the
159         occurrences of in-scope Ids, and (more important) they will
160         have a correctly-substituted type.  So we use a lookup in this
161         set to replace occurrences
162
163         The Ids in the InScopeSet are replete with their Rules,
164         and as we gather info about the unfolding of an Id, we replace
165         it in the in-scope set.  
166
167         The in-scope set is actually a mapping OutVar -> OutVar, and
168         in case expressions we sometimes bind 
169
170 seIdSubst:
171         The substitution is *apply-once* only, because InIds and OutIds can overlap.
172         For example, we generally omit mappings 
173                 a77 -> a77
174         from the substitution, when we decide not to clone a77, but it's quite 
175         legitimate to put the mapping in the substitution anyway.
176
177         Furthermore, consider 
178                 let x = case k of I# x77 -> ... in
179                 let y = case k of I# x77 -> ... in ...
180         and suppose the body is strict in both x and y.  Then the simplifier
181         will pull the first (case k) to the top; so the second (case k) will
182         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the 
183         other is an out-Id. 
184
185         Of course, the substitution *must* applied! Things in its domain 
186         simply aren't necessarily bound in the result.
187
188 * substId adds a binding (DoneId new_id) to the substitution if 
189         the Id's unique has changed
190
191
192   Note, though that the substitution isn't necessarily extended
193   if the type changes.  Why not?  Because of the next point:
194
195 * We *always, always* finish by looking up in the in-scope set 
196   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
197   Reason: so that we never finish up with a "old" Id in the result.  
198   An old Id might point to an old unfolding and so on... which gives a space leak.
199
200   [The DoneEx and DoneVar hits map to "new" stuff.]
201
202 * It follows that substExpr must not do a no-op if the substitution is empty.
203   substType is free to do so, however.
204
205 * When we come to a let-binding (say) we generate new IdInfo, including an
206   unfolding, attach it to the binder, and add this newly adorned binder to
207   the in-scope set.  So all subsequent occurrences of the binder will get mapped
208   to the full-adorned binder, which is also the one put in the binding site.
209
210 * The in-scope "set" usually maps x->x; we use it simply for its domain.
211   But sometimes we have two in-scope Ids that are synomyms, and should
212   map to the same target:  x->x, y->x.  Notably:
213         case y of x { ... }
214   That's why the "set" is actually a VarEnv Var
215
216
217 \begin{code}
218 mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
219 mkSimplEnv switches mode
220   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
221                seMode = mode, seInScope = emptyInScopeSet, 
222                seFloats = emptyFloats,
223                seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
224         -- The top level "enclosing CC" is "SUBSUMED".
225
226 ---------------------
227 getSwitchChecker :: SimplEnv -> SwitchChecker
228 getSwitchChecker env = seChkr env
229
230 ---------------------
231 getMode :: SimplEnv -> SimplifierMode
232 getMode env = seMode env
233
234 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
235 setMode mode env = env { seMode = mode }
236
237 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
238 updMode upd env = env { seMode = upd (seMode env) }
239
240 inGentleMode :: SimplEnv -> Bool
241 inGentleMode env = case seMode env of
242                         SimplGently {} -> True
243                         _other         -> False
244
245 ---------------------
246 getEnclosingCC :: SimplEnv -> CostCentreStack
247 getEnclosingCC env = seCC env
248
249 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
250 setEnclosingCC env cc = env {seCC = cc}
251
252 ---------------------
253 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
254 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
255   = env {seIdSubst = extendVarEnv subst var res}
256
257 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
258 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
259   = env {seTvSubst = extendVarEnv subst var res}
260
261 ---------------------
262 getInScope :: SimplEnv -> InScopeSet
263 getInScope env = seInScope env
264
265 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
266 setInScopeSet env in_scope = env {seInScope = in_scope}
267
268 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
269 -- Set the in-scope set, and *zap* the floats
270 setInScope env env_with_scope
271   = env { seInScope = seInScope env_with_scope,
272           seFloats = emptyFloats }
273
274 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
275 -- Set the in-scope set *and* the floats
276 setFloats env env_with_floats
277   = env { seInScope = seInScope env_with_floats,
278           seFloats  = seFloats  env_with_floats }
279
280 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
281         -- The new Ids are guaranteed to be freshly allocated
282 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
283   = env { seInScope = in_scope `extendInScopeSetList` vs,
284           seIdSubst = id_subst `delVarEnvList` vs }
285         -- Why delete?  Consider 
286         --      let x = a*b in (x, \x -> x+3)
287         -- We add [x |-> a*b] to the substitution, but we must
288         -- _delete_ it from the substitution when going inside
289         -- the (\x -> ...)!
290
291 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
292 -- The variable should already be in scope, but 
293 -- replace the existing version with this new one
294 -- which has more information
295 modifyInScope env@(SimplEnv {seInScope = in_scope}) v 
296   = env {seInScope = extendInScopeSet in_scope v}
297
298 ---------------------
299 zapSubstEnv :: SimplEnv -> SimplEnv
300 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
301
302 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
303 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
304
305 mkContEx :: SimplEnv -> InExpr -> SimplSR
306 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
307 \end{code}
308
309
310
311 %************************************************************************
312 %*                                                                      *
313 \subsection{Floats}
314 %*                                                                      *
315 %************************************************************************
316
317 Note [Simplifier floats]
318 ~~~~~~~~~~~~~~~~~~~~~~~~~
319 The Floats is a bunch of bindings, classified by a FloatFlag.
320
321   NonRec x (y:ys)       FltLifted
322   Rec [(x,rhs)]         FltLifted
323
324   NonRec x# (y +# 3)    FltOkSpec       -- Unboxed, but ok-for-spec'n
325
326   NonRec x# (a /# b)    FltCareful
327   NonRec x* (f y)       FltCareful      -- Strict binding; might fail or diverge
328   NonRec x# (f y)       FltCareful      -- Unboxed binding: might fail or diverge
329                                         --        (where f :: Int -> Int#)
330
331 \begin{code}
332 data Floats = Floats (OrdList OutBind) FloatFlag
333         -- See Note [Simplifier floats]
334
335 data FloatFlag
336   = FltLifted   -- All bindings are lifted and lazy
337                 --  Hence ok to float to top level, or recursive
338
339   | FltOkSpec   -- All bindings are FltLifted *or* 
340                 --      strict (perhaps because unlifted, 
341                 --      perhaps because of a strict binder),
342                 --        *and* ok-for-speculation
343                 --  Hence ok to float out of the RHS 
344                 --  of a lazy non-recursive let binding
345                 --  (but not to top level, or into a rec group)
346
347   | FltCareful  -- At least one binding is strict (or unlifted)
348                 --      and not guaranteed cheap
349                 --      Do not float these bindings out of a lazy let
350
351 instance Outputable Floats where
352   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
353
354 instance Outputable FloatFlag where
355   ppr FltLifted = ptext (sLit "FltLifted")
356   ppr FltOkSpec = ptext (sLit "FltOkSpec")
357   ppr FltCareful = ptext (sLit "FltCareful")
358    
359 andFF :: FloatFlag -> FloatFlag -> FloatFlag
360 andFF FltCareful _          = FltCareful
361 andFF FltOkSpec  FltCareful = FltCareful
362 andFF FltOkSpec  _          = FltOkSpec
363 andFF FltLifted  flt        = flt
364
365 classifyFF :: CoreBind -> FloatFlag
366 classifyFF (Rec _) = FltLifted
367 classifyFF (NonRec bndr rhs) 
368   | not (isStrictId bndr)    = FltLifted
369   | exprOkForSpeculation rhs = FltOkSpec
370   | otherwise                = FltCareful
371
372 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
373 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
374   =  not (isNilOL fs) && want_to_float && can_float
375   where
376      want_to_float = isTopLevel lvl || exprIsExpandable rhs
377      can_float = case ff of
378                    FltLifted  -> True
379                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
380                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
381 \end{code}
382
383
384 \begin{code}
385 emptyFloats :: Floats
386 emptyFloats = Floats nilOL FltLifted
387
388 unitFloat :: OutBind -> Floats
389 -- A single-binding float
390 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
391
392 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
393 -- Add a non-recursive binding and extend the in-scope set
394 -- The latter is important; the binder may already be in the
395 -- in-scope set (although it might also have been created with newId)
396 -- but it may now have more IdInfo
397 addNonRec env id rhs
398   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
399           seInScope = extendInScopeSet (seInScope env) id }
400
401 extendFloats :: SimplEnv -> OutBind -> SimplEnv
402 -- Add these bindings to the floats, and extend the in-scope env too
403 extendFloats env bind
404   = env { seFloats  = seFloats env `addFlts` unitFloat bind,
405           seInScope = extendInScopeSetList (seInScope env) bndrs }
406   where
407     bndrs = bindersOf bind
408
409 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
410 -- Add the floats for env2 to env1; 
411 -- *plus* the in-scope set for env2, which is bigger 
412 -- than that for env1
413 addFloats env1 env2 
414   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
415           seInScope = seInScope env2 }
416
417 addFlts :: Floats -> Floats -> Floats
418 addFlts (Floats bs1 l1) (Floats bs2 l2)
419   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
420
421 zapFloats :: SimplEnv -> SimplEnv
422 zapFloats env = env { seFloats = emptyFloats }
423
424 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
425 -- Flattens the floats from env2 into a single Rec group,
426 -- prepends the floats from env1, and puts the result back in env2
427 -- This is all very specific to the way recursive bindings are
428 -- handled; see Simplify.simplRecBind
429 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
430   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
431     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
432
433 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
434 wrapFloats env expr = wrapFlts (seFloats env) expr
435
436 wrapFlts :: Floats -> OutExpr -> OutExpr
437 -- Wrap the floats around the expression, using case-binding where necessary
438 wrapFlts (Floats bs _) body = foldrOL wrap body bs
439   where
440     wrap (Rec prs)    body = Let (Rec prs) body
441     wrap (NonRec b r) body = bindNonRec b r body
442
443 getFloats :: SimplEnv -> [CoreBind]
444 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
445
446 isEmptyFloats :: SimplEnv -> Bool
447 isEmptyFloats env = isEmptyFlts (seFloats env)
448
449 isEmptyFlts :: Floats -> Bool
450 isEmptyFlts (Floats bs _) = isNilOL bs 
451
452 floatBinds :: Floats -> [OutBind]
453 floatBinds (Floats bs _) = fromOL bs
454 \end{code}
455
456
457 %************************************************************************
458 %*                                                                      *
459                 Substitution of Vars
460 %*                                                                      *
461 %************************************************************************
462
463 Note [Global Ids in the substitution]
464 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
465 We look up even a global (eg imported) Id in the substitution. Consider
466    case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
467 The binder-swap in the occurence analyser will add a binding
468 for a LocalId version of g (with the same unique though):
469    case X.g_34 of b { (a,b) ->  let g_34 = b in 
470                                 ... case X.g_34 of { (p,q) -> ...} ... }
471 So we want to look up the inner X.g_34 in the substitution, where we'll
472 find that it has been substituted by b.  (Or conceivably cloned.)
473
474 \begin{code}
475 substId :: SimplEnv -> InId -> SimplSR
476 -- Returns DoneEx only on a non-Var expression
477 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 
478   = case lookupVarEnv ids v of          -- Note [Global Ids in the substitution]
479         Nothing               -> DoneId (refine in_scope v)
480         Just (DoneId v)       -> DoneId (refine in_scope v)
481         Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
482         Just res              -> res    -- DoneEx non-var, or ContEx
483   where
484
485         -- Get the most up-to-date thing from the in-scope set
486         -- Even though it isn't in the substitution, it may be in
487         -- the in-scope set with better IdInfo
488 refine :: InScopeSet -> Var -> Var
489 refine in_scope v 
490   | isLocalId v = case lookupInScope in_scope v of
491                          Just v' -> v'
492                          Nothing -> WARN( True, ppr v ) v       -- This is an error!
493   | otherwise = v
494
495 lookupRecBndr :: SimplEnv -> InId -> OutId
496 -- Look up an Id which has been put into the envt by simplRecBndrs,
497 -- but where we have not yet done its RHS
498 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
499   = case lookupVarEnv ids v of
500         Just (DoneId v) -> v
501         Just _ -> pprPanic "lookupRecBndr" (ppr v)
502         Nothing -> refine in_scope v
503 \end{code}
504
505
506 %************************************************************************
507 %*                                                                      *
508 \section{Substituting an Id binder}
509 %*                                                                      *
510 %************************************************************************
511
512
513 These functions are in the monad only so that they can be made strict via seq.
514
515 \begin{code}
516 simplBinders, simplLamBndrs
517         :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
518 simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
519 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
520
521 -------------
522 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
523 -- Used for lambda and case-bound variables
524 -- Clone Id if necessary, substitute type
525 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
526 -- The substitution is extended only if the variable is cloned, because
527 -- we *don't* need to use it to track occurrence info.
528 simplBinder env bndr
529   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
530                         ; seqTyVar tv `seq` return (env', tv) }
531   | otherwise     = do  { let (env', id) = substIdBndr env bndr
532                         ; seqId id `seq` return (env', id) }
533
534 -------------
535 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
536 -- Used for lambda binders.  These sometimes have unfoldings added by
537 -- the worker/wrapper pass that must be preserved, because they can't
538 -- be reconstructed from context.  For example:
539 --      f x = case x of (a,b) -> fw a b x
540 --      fw a b x{=(a,b)} = ...
541 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
542 simplLamBndr env bndr
543   | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2)  -- Special case
544   | otherwise                             = simplBinder env bndr                -- Normal case
545   where
546     old_unf = idUnfolding bndr
547     (env1, id1) = substIdBndr env bndr
548     id2  = id1 `setIdUnfolding` substUnfolding env old_unf
549     env2 = modifyInScope env1 id2
550
551 ---------------
552 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
553 -- A non-recursive let binder
554 simplNonRecBndr env id
555   = do  { let (env1, id1) = substIdBndr env id
556         ; seqId id1 `seq` return (env1, id1) }
557
558 ---------------
559 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
560 -- Recursive let binders
561 simplRecBndrs env@(SimplEnv {}) ids
562   = do  { let (env1, ids1) = mapAccumL substIdBndr env ids
563         ; seqIds ids1 `seq` return env1 }
564
565 ---------------
566 substIdBndr :: SimplEnv         
567             -> InBndr   -- Env and binder to transform
568             -> (SimplEnv, OutBndr)
569 -- Clone Id if necessary, substitute its type
570 -- Return an Id with its 
571 --      * Type substituted
572 --      * UnfoldingInfo, Rules, WorkerInfo zapped
573 --      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
574 --      * Robust info, retained especially arity and demand info,
575 --         so that they are available to occurrences that occur in an
576 --         earlier binding of a letrec
577 --
578 -- For the robust info, see Note [Arity robustness]
579 --
580 -- Augment the substitution  if the unique changed
581 -- Extend the in-scope set with the new Id
582 --
583 -- Similar to CoreSubst.substIdBndr, except that 
584 --      the type of id_subst differs
585 --      all fragile info is zapped
586
587 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) 
588                old_id
589   = (env { seInScope = in_scope `extendInScopeSet` new_id, 
590            seIdSubst = new_subst }, new_id)
591   where
592     id1    = uniqAway in_scope old_id
593     id2    = substIdType env id1
594     new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
595                                         -- and fragile OccInfo
596
597         -- Extend the substitution if the unique has changed,
598         -- or there's some useful occurrence information
599         -- See the notes with substTyVarBndr for the delSubstEnv
600     new_subst | new_id /= old_id
601               = extendVarEnv id_subst old_id (DoneId new_id)
602               | otherwise 
603               = delVarEnv id_subst old_id
604 \end{code}
605
606 \begin{code}
607 ------------------------------------
608 seqTyVar :: TyVar -> ()
609 seqTyVar b = b `seq` ()
610
611 seqId :: Id -> ()
612 seqId id = seqType (idType id)  `seq`
613            idInfo id            `seq`
614            ()
615
616 seqIds :: [Id] -> ()
617 seqIds []       = ()
618 seqIds (id:ids) = seqId id `seq` seqIds ids
619 \end{code}
620
621
622 Note [Arity robustness]
623 ~~~~~~~~~~~~~~~~~~~~~~~
624 We *do* transfer the arity from from the in_id of a let binding to the
625 out_id.  This is important, so that the arity of an Id is visible in
626 its own RHS.  For example:
627         f = \x. ....g (\y. f y)....
628 We can eta-reduce the arg to g, becuase f is a value.  But that 
629 needs to be visible.  
630
631 This interacts with the 'state hack' too:
632         f :: Bool -> IO Int
633         f = \x. case x of 
634                   True  -> f y
635                   False -> \s -> ...
636 Can we eta-expand f?  Only if we see that f has arity 1, and then we 
637 take advantage of the 'state hack' on the result of
638 (f y) :: State# -> (State#, Int) to expand the arity one more.
639
640 There is a disadvantage though.  Making the arity visible in the RHS
641 allows us to eta-reduce
642         f = \x -> f x
643 to
644         f = f
645 which technically is not sound.   This is very much a corner case, so
646 I'm not worried about it.  Another idea is to ensure that f's arity 
647 never decreases; its arity started as 1, and we should never eta-reduce
648 below that.
649
650
651 Note [Robust OccInfo]
652 ~~~~~~~~~~~~~~~~~~~~~
653 It's important that we *do* retain the loop-breaker OccInfo, because
654 that's what stops the Id getting inlined infinitely, in the body of
655 the letrec.
656
657
658 Note [Rules in a letrec]
659 ~~~~~~~~~~~~~~~~~~~~~~~~
660 After creating fresh binders for the binders of a letrec, we
661 substitute the RULES and add them back onto the binders; this is done
662 *before* processing any of the RHSs.  This is important.  Manuel found
663 cases where he really, really wanted a RULE for a recursive function
664 to apply in that function's own right-hand side.
665
666 See Note [Loop breaking and RULES] in OccAnal.
667
668
669 \begin{code}
670 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
671 -- Rules are added back in to to the bin
672 addBndrRules env in_id out_id
673   | isEmptySpecInfo old_rules = (env, out_id)
674   | otherwise = (modifyInScope env final_id, final_id)
675   where
676     subst     = mkCoreSubst env
677     old_rules = idSpecialisation in_id
678     new_rules = CoreSubst.substSpec subst out_id old_rules
679     final_id  = out_id `setIdSpecialisation` new_rules
680 \end{code}
681
682
683 %************************************************************************
684 %*                                                                      *
685                 Impedence matching to type substitution
686 %*                                                                      *
687 %************************************************************************
688
689 \begin{code}
690 getTvSubst :: SimplEnv -> TvSubst
691 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
692   = mkTvSubst in_scope tv_env
693
694 substTy :: SimplEnv -> Type -> Type 
695 substTy env ty = Type.substTy (getTvSubst env) ty
696
697 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
698 substTyVarBndr env tv
699   = case Type.substTyVarBndr (getTvSubst env) tv of
700         (TvSubst in_scope' tv_env', tv') 
701            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
702
703 -- When substituting in rules etc we can get CoreSubst to do the work
704 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
705 -- here.  I think the this will not usually result in a lot of work;
706 -- the substitutions are typically small, and laziness will avoid work in many cases.
707
708 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
709 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
710   = mk_subst tv_env id_env
711   where
712     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
713
714     fiddle (DoneEx e)       = e
715     fiddle (DoneId v)       = Var v
716     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
717
718 ------------------
719 substIdType :: SimplEnv -> Id -> Id
720 substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
721   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
722   | otherwise   = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
723                 -- The tyVarsOfType is cheaper than it looks
724                 -- because we cache the free tyvars of the type
725                 -- in a Note in the id's type itself
726   where
727     old_ty = idType id
728
729 ------------------
730 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
731 substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
732   -- Do *not* short-cut in the case of an empty substitution
733   -- See CoreSubst: Note [Extending the Subst]
734
735 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
736 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
737 \end{code}
738