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