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