2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
16 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
17 InCoercion, OutCoercion,
19 -- The simplifier mode
23 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
24 isAmongSimpl, intSwitchSet, switchIsOn,
26 setEnclosingCC, getEnclosingCC,
29 SimplEnv(..), pprSimplEnv, -- Temp not abstract
30 mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
31 zapSubstEnv, setSubstEnv,
32 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
35 SimplSR(..), mkContEx, substId, lookupRecBndr,
37 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
38 simplBinder, simplBinders, addLetIdInfo,
42 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
43 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
44 doFloatFromRhs, getFloats
47 #include "HsVersions.h"
60 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
61 import qualified Type ( substTy, substTyVarBndr )
62 import Type hiding ( substTy, substTyVarBndr )
72 %************************************************************************
74 \subsection[Simplify-types]{Type declarations}
76 %************************************************************************
79 type InBndr = CoreBndr
80 type InId = Id -- Not yet cloned
81 type InType = Type -- Ditto
82 type InBind = CoreBind
83 type InExpr = CoreExpr
86 type InCoercion = Coercion
88 type OutBndr = CoreBndr
89 type OutId = Id -- Cloned
90 type OutTyVar = TyVar -- Cloned
91 type OutType = Type -- Cloned
92 type OutCoercion = Coercion
93 type OutBind = CoreBind
94 type OutExpr = CoreExpr
99 %************************************************************************
101 \subsubsection{The @SimplEnv@ type}
103 %************************************************************************
109 seMode :: SimplifierMode,
110 seChkr :: SwitchChecker,
111 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
113 -- The current set of in-scope variables
114 -- They are all OutVars, and all bound in this module
115 seInScope :: InScopeSet, -- OutVars only
116 -- Includes all variables bound by seFloats
118 -- See Note [Simplifier floats]
120 -- The current substitution
121 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
122 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
126 pprSimplEnv :: SimplEnv -> SDoc
127 -- Used for debugging; selective
129 = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
130 ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
132 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
133 -- See Note [Extending the Subst] in CoreSubst
136 = DoneEx OutExpr -- Completed term
137 | DoneId OutId -- Completed term variable
138 | ContEx TvSubstEnv -- A suspended substitution
142 instance Outputable SimplSR where
143 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
144 ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v
145 ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-,
146 ppr (filter_env tv), ppr (filter_env id) -}]
148 -- fvs = exprFreeVars e
149 -- filter_env env = filterVarEnv_Directly keep env
150 -- keep uniq _ = uniq `elemUFM_Directly` fvs
155 The in-scope part of Subst includes *all* in-scope TyVars and Ids
156 The elements of the set may have better IdInfo than the
157 occurrences of in-scope Ids, and (more important) they will
158 have a correctly-substituted type. So we use a lookup in this
159 set to replace occurrences
161 The Ids in the InScopeSet are replete with their Rules,
162 and as we gather info about the unfolding of an Id, we replace
163 it in the in-scope set.
165 The in-scope set is actually a mapping OutVar -> OutVar, and
166 in case expressions we sometimes bind
169 The substitution is *apply-once* only, because InIds and OutIds can overlap.
170 For example, we generally omit mappings
172 from the substitution, when we decide not to clone a77, but it's quite
173 legitimate to put the mapping in the substitution anyway.
175 Furthermore, consider
176 let x = case k of I# x77 -> ... in
177 let y = case k of I# x77 -> ... in ...
178 and suppose the body is strict in both x and y. Then the simplifier
179 will pull the first (case k) to the top; so the second (case k) will
180 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
183 Of course, the substitution *must* applied! Things in its domain
184 simply aren't necessarily bound in the result.
186 * substId adds a binding (DoneId new_id) to the substitution if
187 the Id's unique has changed
190 Note, though that the substitution isn't necessarily extended
191 if the type changes. Why not? Because of the next point:
193 * We *always, always* finish by looking up in the in-scope set
194 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
195 Reason: so that we never finish up with a "old" Id in the result.
196 An old Id might point to an old unfolding and so on... which gives a space leak.
198 [The DoneEx and DoneVar hits map to "new" stuff.]
200 * It follows that substExpr must not do a no-op if the substitution is empty.
201 substType is free to do so, however.
203 * When we come to a let-binding (say) we generate new IdInfo, including an
204 unfolding, attach it to the binder, and add this newly adorned binder to
205 the in-scope set. So all subsequent occurrences of the binder will get mapped
206 to the full-adorned binder, which is also the one put in the binding site.
208 * The in-scope "set" usually maps x->x; we use it simply for its domain.
209 But sometimes we have two in-scope Ids that are synomyms, and should
210 map to the same target: x->x, y->x. Notably:
212 That's why the "set" is actually a VarEnv Var
216 mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
217 mkSimplEnv mode switches
218 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
219 seMode = mode, seInScope = emptyInScopeSet,
220 seFloats = emptyFloats,
221 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
222 -- The top level "enclosing CC" is "SUBSUMED".
224 ---------------------
225 getSwitchChecker :: SimplEnv -> SwitchChecker
226 getSwitchChecker env = seChkr env
228 ---------------------
229 getMode :: SimplEnv -> SimplifierMode
230 getMode env = seMode env
232 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
233 setMode mode env = env { seMode = mode }
235 ---------------------
236 getEnclosingCC :: SimplEnv -> CostCentreStack
237 getEnclosingCC env = seCC env
239 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
240 setEnclosingCC env cc = env {seCC = cc}
242 ---------------------
243 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
244 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
245 = env {seIdSubst = extendVarEnv subst var res}
247 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
248 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
249 = env {seTvSubst = extendVarEnv subst var res}
251 ---------------------
252 getInScope :: SimplEnv -> InScopeSet
253 getInScope env = seInScope env
255 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
256 setInScopeSet env in_scope = env {seInScope = in_scope}
258 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
259 -- Set the in-scope set, and *zap* the floats
260 setInScope env env_with_scope
261 = env { seInScope = seInScope env_with_scope,
262 seFloats = emptyFloats }
264 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
265 -- Set the in-scope set *and* the floats
266 setFloats env env_with_floats
267 = env { seInScope = seInScope env_with_floats,
268 seFloats = seFloats env_with_floats }
270 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
271 -- The new Ids are guaranteed to be freshly allocated
272 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
273 = env { seInScope = in_scope `extendInScopeSetList` vs,
274 seIdSubst = id_subst `delVarEnvList` vs }
275 -- Why delete? Consider
276 -- let x = a*b in (x, \x -> x+3)
277 -- We add [x |-> a*b] to the substitution, but we must
278 -- *delete* it from the substitution when going inside
281 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
282 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
283 = env {seInScope = modifyInScopeSet in_scope v v'}
285 ---------------------
286 zapSubstEnv :: SimplEnv -> SimplEnv
287 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
289 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
290 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
292 mkContEx :: SimplEnv -> InExpr -> SimplSR
293 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
295 isEmptySimplSubst :: SimplEnv -> Bool
296 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
297 = isEmptyVarEnv tvs && isEmptyVarEnv ids
302 %************************************************************************
306 %************************************************************************
308 Note [Simplifier floats]
309 ~~~~~~~~~~~~~~~~~~~~~~~~~
310 The Floats is a bunch of bindings, classified by a FloatFlag.
312 NonRec x (y:ys) FltLifted
313 Rec [(x,rhs)] FltLifted
315 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
317 NonRec x# (a /# b) FltCareful
318 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
319 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
320 -- (where f :: Int -> Int#)
323 data Floats = Floats (OrdList OutBind) FloatFlag
324 -- See Note [Simplifier floats]
327 = FltLifted -- All bindings are lifted and lazy
328 -- Hence ok to float to top level, or recursive
330 | FltOkSpec -- All bindings are FltLifted *or*
331 -- strict (perhaps because unlifted,
332 -- perhaps because of a strict binder),
333 -- *and* ok-for-speculation
334 -- Hence ok to float out of the RHS
335 -- of a lazy non-recursive let binding
336 -- (but not to top level, or into a rec group)
338 | FltCareful -- At least one binding is strict (or unlifted)
339 -- and not guaranteed cheap
340 -- Do not float these bindings out of a lazy let
342 instance Outputable Floats where
343 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
345 instance Outputable FloatFlag where
346 ppr FltLifted = ptext SLIT("FltLifted")
347 ppr FltOkSpec = ptext SLIT("FltOkSpec")
348 ppr FltCareful = ptext SLIT("FltCareful")
350 andFF :: FloatFlag -> FloatFlag -> FloatFlag
351 andFF FltCareful _ = FltCareful
352 andFF FltOkSpec FltCareful = FltCareful
353 andFF FltOkSpec flt = FltOkSpec
354 andFF FltLifted flt = flt
356 classifyFF :: CoreBind -> FloatFlag
357 classifyFF (Rec _) = FltLifted
358 classifyFF (NonRec bndr rhs)
359 | not (isStrictId bndr) = FltLifted
360 | exprOkForSpeculation rhs = FltOkSpec
361 | otherwise = FltCareful
363 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
364 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
365 = not (isNilOL fs) && want_to_float && can_float
367 want_to_float = isTopLevel lvl || exprIsCheap rhs
368 can_float = case ff of
370 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
371 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
376 emptyFloats :: Floats
377 emptyFloats = Floats nilOL FltLifted
379 unitFloat :: OutBind -> Floats
380 -- A single-binding float
381 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
383 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
384 -- Add a non-recursive binding and extend the in-scope set
385 -- The latter is important; the binder may already be in the
386 -- in-scope set (although it might also have been created with newId)
387 -- but it may now have more IdInfo
389 = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
390 seInScope = extendInScopeSet (seInScope env) id }
392 extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
393 -- Add these bindings to the floats, and extend the in-scope env too
394 extendFloats env binds
395 = env { seFloats = seFloats env `addFlts` new_floats,
396 seInScope = extendInScopeSetList (seInScope env) bndrs }
398 bndrs = bindersOfBinds binds
399 new_floats = Floats (toOL binds)
400 (foldr (andFF . classifyFF) FltLifted binds)
402 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
403 -- Add the floats for env2 to env1;
404 -- *plus* the in-scope set for env2, which is bigger
405 -- than that for env1
407 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
408 seInScope = seInScope env2 }
410 addFlts :: Floats -> Floats -> Floats
411 addFlts (Floats bs1 l1) (Floats bs2 l2)
412 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
414 zapFloats :: SimplEnv -> SimplEnv
415 zapFloats env = env { seFloats = emptyFloats }
417 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
418 -- Flattens the floats from env2 into a single Rec group,
419 -- prepends the floats from env1, and puts the result back in env2
420 -- This is all very specific to the way recursive bindings are
421 -- handled; see Simplify.simplRecBind
422 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
423 = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
424 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
426 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
427 wrapFloats env expr = wrapFlts (seFloats env) expr
429 wrapFlts :: Floats -> OutExpr -> OutExpr
430 -- Wrap the floats around the expression, using case-binding where necessary
431 wrapFlts (Floats bs _) body = foldrOL wrap body bs
433 wrap (Rec prs) body = Let (Rec prs) body
434 wrap (NonRec b r) body = bindNonRec b r body
436 getFloats :: SimplEnv -> [CoreBind]
437 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
439 isEmptyFloats :: SimplEnv -> Bool
440 isEmptyFloats env = isEmptyFlts (seFloats env)
442 isEmptyFlts :: Floats -> Bool
443 isEmptyFlts (Floats bs _) = isNilOL bs
445 floatBinds :: Floats -> [OutBind]
446 floatBinds (Floats bs _) = fromOL bs
450 %************************************************************************
454 %************************************************************************
458 substId :: SimplEnv -> Id -> SimplSR
459 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
462 | otherwise -- A local Id
463 = case lookupVarEnv ids v of
464 Just (DoneId v) -> DoneId (refine in_scope v)
466 Nothing -> DoneId (refine in_scope v)
469 -- Get the most up-to-date thing from the in-scope set
470 -- Even though it isn't in the substitution, it may be in
471 -- the in-scope set with better IdInfo
472 refine in_scope v = case lookupInScope in_scope v of
474 Nothing -> WARN( True, ppr v ) v -- This is an error!
476 lookupRecBndr :: SimplEnv -> Id -> Id
477 -- Look up an Id which has been put into the envt by simplRecBndrs,
478 -- but where we have not yet done its RHS
479 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
480 = case lookupVarEnv ids v of
482 Just res -> pprPanic "lookupRecBndr" (ppr v)
483 Nothing -> refine in_scope v
487 %************************************************************************
489 \section{Substituting an Id binder}
491 %************************************************************************
494 These functions are in the monad only so that they can be made strict via seq.
497 simplBinders, simplLamBndrs
498 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
499 simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
500 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
503 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
504 -- Used for lambda and case-bound variables
505 -- Clone Id if necessary, substitute type
506 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
507 -- The substitution is extended only if the variable is cloned, because
508 -- we *don't* need to use it to track occurrence info.
510 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
511 ; seqTyVar tv `seq` return (env', tv) }
512 | otherwise = do { let (env', id) = substIdBndr env bndr
513 ; seqId id `seq` return (env', id) }
516 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
517 -- Used for lambda binders. These sometimes have unfoldings added by
518 -- the worker/wrapper pass that must be preserved, becuase they can't
519 -- be reconstructed from context. For example:
520 -- f x = case x of (a,b) -> fw a b x
521 -- fw a b x{=(a,b)} = ...
522 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
523 simplLamBndr env bndr
524 | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
525 | otherwise = seqId id2 `seq` return (env', id2)
527 old_unf = idUnfolding bndr
528 (env', id1) = substIdBndr env bndr
529 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
532 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
533 -> (SimplEnv, Id) -- Transformed pair
536 -- * Unique changed if necessary
537 -- * Type substituted
538 -- * Unfolding zapped
539 -- * Rules, worker, lbvar info all substituted
540 -- * Fragile occurrence info zapped
541 -- * The in-scope set extended with the returned Id
542 -- * The substitution extended with a DoneId if unique changed
543 -- In this case, the var in the DoneId is the same as the
546 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
548 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
550 = (env { seInScope = in_scope `extendInScopeSet` new_id,
551 seIdSubst = new_subst }, new_id)
553 -- id1 is cloned if necessary
554 id1 = uniqAway in_scope old_id
556 -- id2 has its type zapped
557 id2 = substIdType env id1
559 -- new_id has the final IdInfo
560 subst = mkCoreSubst env
561 new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
563 -- Extend the substitution if the unique has changed
564 -- See the notes with substTyVarBndr for the delSubstEnv
565 -- Also see Note [Extending the Subst] in CoreSubst
566 new_subst | new_id /= old_id
567 = extendVarEnv id_subst old_id (DoneId new_id)
569 = delVarEnv id_subst old_id
573 ------------------------------------
574 seqTyVar :: TyVar -> ()
575 seqTyVar b = b `seq` ()
578 seqId id = seqType (idType id) `seq`
584 seqIds (id:ids) = seqId id `seq` seqIds ids
587 %************************************************************************
591 %************************************************************************
593 Simplifying let binders
594 ~~~~~~~~~~~~~~~~~~~~~~~
595 Rename the binders if necessary,
598 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
599 simplNonRecBndr env id
600 = do { let (env1, id1) = substLetIdBndr env id
601 ; seqId id1 `seq` return (env1, id1) }
604 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
605 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
606 = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
607 ; seqIds ids1 `seq` return env1 }
610 substLetIdBndr :: SimplEnv -> InBndr -- Env and binder to transform
611 -> (SimplEnv, OutBndr)
612 -- C.f. substIdBndr above
613 -- Clone Id if necessary, substitute its type
614 -- Return an Id with its fragile info zapped
615 -- namely, any info that depends on free variables
616 -- [addLetIdInfo, below, will restore its IdInfo]
617 -- We want to retain robust info, especially arity and demand info,
618 -- so that they are available to occurrences that occur in an
619 -- earlier binding of a letrec
620 -- Augment the subtitution
621 -- if the unique changed, *or*
622 -- if there's interesting occurrence info
624 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
625 = (env { seInScope = in_scope `extendInScopeSet` new_id,
626 seIdSubst = new_subst }, new_id)
628 id1 = uniqAway in_scope old_id
629 id2 = substIdType env id1
631 -- We want to get rid of any info that's dependent on free variables,
632 -- but keep other info (like the arity).
633 new_id = zapFragileIdInfo id2
635 -- Extend the substitution if the unique has changed,
636 -- or there's some useful occurrence information
637 -- See the notes with substTyVarBndr for the delSubstEnv
638 new_subst | new_id /= old_id
639 = extendVarEnv id_subst old_id (DoneId new_id)
641 = delVarEnv id_subst old_id
644 Note [Add IdInfo back onto a let-bound Id]
645 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
646 We must transfer the IdInfo of the original binder to the new binder.
647 This is crucial, to preserve
651 etc. To do this we must apply the current substitution,
652 which incorporates earlier substitutions in this very letrec group.
654 NB 1. We do this *before* processing the RHS of the binder, so that
655 its substituted rules are visible in its own RHS.
656 This is important. Manuel found cases where he really, really
657 wanted a RULE for a recursive function to apply in that function's
660 NB 2: ARITY. We *do* transfer the arity. This is important, so that
661 the arity of an Id is visible in its own RHS. For example:
662 f = \x. ....g (\y. f y)....
663 We can eta-reduce the arg to g, becuase f is a value. But that
666 This interacts with the 'state hack' too:
671 Can we eta-expand f? Only if we see that f has arity 1, and then we
672 take advantage of the 'state hack' on the result of
673 (f y) :: State# -> (State#, Int) to expand the arity one more.
675 There is a disadvantage though. Making the arity visible in the RHA
676 allows us to eta-reduce
680 which technically is not sound. This is very much a corner case, so
681 I'm not worried about it. Another idea is to ensure that f's arity
682 never decreases; its arity started as 1, and we should never eta-reduce
685 NB 3: OccInfo. It's important that we *do* transer the loop-breaker
686 OccInfo, because that's what stops the Id getting inlined infinitely,
687 in the body of the letrec.
689 NB 4: does no harm for non-recursive bindings
691 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
696 Here, we'll do postInlineUnconditionally on f, and we must "see" that
697 when substituting in h's RULE.
700 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
701 addLetIdInfo env in_id out_id
702 = (modifyInScope env out_id final_id, final_id)
704 final_id = out_id `setIdInfo` new_info
705 subst = mkCoreSubst env
706 old_info = idInfo in_id
707 new_info = case substIdInfo subst old_info of
709 Just new_info -> new_info
711 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
716 -- Keep only 'robust' OccInfo
719 -- Seq'ing on the returned IdInfo is enough to cause all the
720 -- substitutions to happen completely
722 substIdInfo subst info
723 | nothing_to_do = Nothing
724 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
725 `setSpecInfo` CoreSubst.substSpec subst old_rules
726 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
727 `setUnfoldingInfo` noUnfolding)
728 -- setSpecInfo does a seq
729 -- setWorkerInfo does a seq
731 nothing_to_do = keep_occ &&
732 isEmptySpecInfo old_rules &&
733 not (workerExists old_wrkr) &&
734 not (hasUnfolding (unfoldingInfo info))
736 keep_occ = not (isFragileOcc old_occ)
737 old_occ = occInfo info
738 old_rules = specInfo info
739 old_wrkr = workerInfo info
742 substIdType :: SimplEnv -> Id -> Id
743 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
744 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
745 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
746 -- The tyVarsOfType is cheaper than it looks
747 -- because we cache the free tyvars of the type
748 -- in a Note in the id's type itself
753 substUnfolding env NoUnfolding = NoUnfolding
754 substUnfolding env (OtherCon cons) = OtherCon cons
755 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
756 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
760 %************************************************************************
762 Impedence matching to type substitution
764 %************************************************************************
767 substTy :: SimplEnv -> Type -> Type
768 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
769 = Type.substTy (TvSubst in_scope tv_env) ty
771 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
772 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
773 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
774 (TvSubst in_scope' tv_env', tv')
775 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
777 -- When substituting in rules etc we can get CoreSubst to do the work
778 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
779 -- here. I think the this will not usually result in a lot of work;
780 -- the substitutions are typically small, and laziness will avoid work in many cases.
782 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
783 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
784 = mk_subst tv_env id_env
786 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
788 fiddle (DoneEx e) = e
789 fiddle (DoneId v) = Var v
790 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
792 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
794 | isEmptySimplSubst env = expr
795 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr