2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
9 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
10 InCoercion, OutCoercion,
12 -- The simplifier mode
16 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
17 isAmongSimpl, intSwitchSet, switchIsOn,
19 setEnclosingCC, getEnclosingCC,
22 SimplEnv(..), pprSimplEnv, -- Temp not abstract
23 mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
24 zapSubstEnv, setSubstEnv,
25 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
28 SimplSR(..), mkContEx, substId, lookupRecBndr,
30 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
31 simplBinder, simplBinders, addLetIdInfo,
35 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
36 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
37 doFloatFromRhs, getFloats
40 #include "HsVersions.h"
53 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
54 import qualified Type ( substTy, substTyVarBndr )
55 import Type hiding ( substTy, substTyVarBndr )
63 %************************************************************************
65 \subsection[Simplify-types]{Type declarations}
67 %************************************************************************
70 type InBndr = CoreBndr
71 type InId = Id -- Not yet cloned
72 type InType = Type -- Ditto
73 type InBind = CoreBind
74 type InExpr = CoreExpr
77 type InCoercion = Coercion
79 type OutBndr = CoreBndr
80 type OutId = Id -- Cloned
81 type OutTyVar = TyVar -- Cloned
82 type OutType = Type -- Cloned
83 type OutCoercion = Coercion
84 type OutBind = CoreBind
85 type OutExpr = CoreExpr
90 %************************************************************************
92 \subsubsection{The @SimplEnv@ type}
94 %************************************************************************
100 seMode :: SimplifierMode,
101 seChkr :: SwitchChecker,
102 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
104 -- Rules from other modules
105 seExtRules :: RuleBase,
107 -- The current set of in-scope variables
108 -- They are all OutVars, and all bound in this module
109 seInScope :: InScopeSet, -- OutVars only
110 -- Includes all variables bound by seFloats
112 -- See Note [Simplifier floats]
114 -- The current substitution
115 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
116 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
120 pprSimplEnv :: SimplEnv -> SDoc
121 -- Used for debugging; selective
123 = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
124 ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
126 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
127 -- See Note [Extending the Subst] in CoreSubst
130 = DoneEx OutExpr -- Completed term
131 | DoneId OutId -- Completed term variable
132 | ContEx TvSubstEnv -- A suspended substitution
136 instance Outputable SimplSR where
137 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
138 ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v
139 ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-,
140 ppr (filter_env tv), ppr (filter_env id) -}]
142 -- fvs = exprFreeVars e
143 -- filter_env env = filterVarEnv_Directly keep env
144 -- keep uniq _ = uniq `elemUFM_Directly` fvs
149 The in-scope part of Subst includes *all* in-scope TyVars and Ids
150 The elements of the set may have better IdInfo than the
151 occurrences of in-scope Ids, and (more important) they will
152 have a correctly-substituted type. So we use a lookup in this
153 set to replace occurrences
155 The Ids in the InScopeSet are replete with their Rules,
156 and as we gather info about the unfolding of an Id, we replace
157 it in the in-scope set.
159 The in-scope set is actually a mapping OutVar -> OutVar, and
160 in case expressions we sometimes bind
163 The substitution is *apply-once* only, because InIds and OutIds can overlap.
164 For example, we generally omit mappings
166 from the substitution, when we decide not to clone a77, but it's quite
167 legitimate to put the mapping in the substitution anyway.
169 Furthermore, consider
170 let x = case k of I# x77 -> ... in
171 let y = case k of I# x77 -> ... in ...
172 and suppose the body is strict in both x and y. Then the simplifier
173 will pull the first (case k) to the top; so the second (case k) will
174 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
177 Of course, the substitution *must* applied! Things in its domain
178 simply aren't necessarily bound in the result.
180 * substId adds a binding (DoneId new_id) to the substitution if
181 the Id's unique has changed
184 Note, though that the substitution isn't necessarily extended
185 if the type changes. Why not? Because of the next point:
187 * We *always, always* finish by looking up in the in-scope set
188 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
189 Reason: so that we never finish up with a "old" Id in the result.
190 An old Id might point to an old unfolding and so on... which gives a space leak.
192 [The DoneEx and DoneVar hits map to "new" stuff.]
194 * It follows that substExpr must not do a no-op if the substitution is empty.
195 substType is free to do so, however.
197 * When we come to a let-binding (say) we generate new IdInfo, including an
198 unfolding, attach it to the binder, and add this newly adorned binder to
199 the in-scope set. So all subsequent occurrences of the binder will get mapped
200 to the full-adorned binder, which is also the one put in the binding site.
202 * The in-scope "set" usually maps x->x; we use it simply for its domain.
203 But sometimes we have two in-scope Ids that are synomyms, and should
204 map to the same target: x->x, y->x. Notably:
206 That's why the "set" is actually a VarEnv Var
210 mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
211 mkSimplEnv mode switches rules
212 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
213 seMode = mode, seInScope = emptyInScopeSet,
214 seExtRules = rules, seFloats = emptyFloats,
215 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
216 -- The top level "enclosing CC" is "SUBSUMED".
218 ---------------------
219 getSwitchChecker :: SimplEnv -> SwitchChecker
220 getSwitchChecker env = seChkr env
222 ---------------------
223 getMode :: SimplEnv -> SimplifierMode
224 getMode env = seMode env
226 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
227 setMode mode env = env { seMode = mode }
229 ---------------------
230 getEnclosingCC :: SimplEnv -> CostCentreStack
231 getEnclosingCC env = seCC env
233 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
234 setEnclosingCC env cc = env {seCC = cc}
236 ---------------------
237 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
238 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
239 = env {seIdSubst = extendVarEnv subst var res}
241 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
242 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
243 = env {seTvSubst = extendVarEnv subst var res}
245 ---------------------
246 getInScope :: SimplEnv -> InScopeSet
247 getInScope env = seInScope env
249 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
250 setInScopeSet env in_scope = env {seInScope = in_scope}
252 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
253 -- Set the in-scope set, and *zap* the floats
254 setInScope env env_with_scope
255 = env { seInScope = seInScope env_with_scope,
256 seFloats = emptyFloats }
258 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
259 -- Set the in-scope set *and* the floats
260 setFloats env env_with_floats
261 = env { seInScope = seInScope env_with_floats,
262 seFloats = seFloats env_with_floats }
264 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
265 -- The new Ids are guaranteed to be freshly allocated
266 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
267 = env { seInScope = in_scope `extendInScopeSetList` vs,
268 seIdSubst = id_subst `delVarEnvList` vs }
269 -- Why delete? Consider
270 -- let x = a*b in (x, \x -> x+3)
271 -- We add [x |-> a*b] to the substitution, but we must
272 -- *delete* it from the substitution when going inside
275 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
276 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
277 = env {seInScope = modifyInScopeSet in_scope v v'}
279 ---------------------
280 zapSubstEnv :: SimplEnv -> SimplEnv
281 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
283 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
284 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
286 mkContEx :: SimplEnv -> InExpr -> SimplSR
287 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
289 isEmptySimplSubst :: SimplEnv -> Bool
290 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
291 = isEmptyVarEnv tvs && isEmptyVarEnv ids
293 ---------------------
294 getRules :: SimplEnv -> RuleBase
295 getRules = seExtRules
300 %************************************************************************
304 %************************************************************************
306 Note [Simplifier floats]
307 ~~~~~~~~~~~~~~~~~~~~~~~~~
308 The Floats is a bunch of bindings, classified by a FloatFlag.
310 NonRec x (y:ys) FltLifted
311 Rec [(x,rhs)] FltLifted
313 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
315 NonRec x# (a /# b) FltCareful
316 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
317 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
318 -- (where f :: Int -> Int#)
321 data Floats = Floats (OrdList OutBind) FloatFlag
322 -- See Note [Simplifier floats]
325 = FltLifted -- All bindings are lifted and lazy
326 -- Hence ok to float to top level, or recursive
328 | FltOkSpec -- All bindings are FltLifted *or*
329 -- strict (perhaps because unlifted,
330 -- perhaps because of a strict binder),
331 -- *and* ok-for-speculation
332 -- Hence ok to float out of the RHS
333 -- of a lazy non-recursive let binding
334 -- (but not to top level, or into a rec group)
336 | FltCareful -- At least one binding is strict (or unlifted)
337 -- and not guaranteed cheap
338 -- Do not float these bindings out of a lazy let
340 instance Outputable Floats where
341 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
343 instance Outputable FloatFlag where
344 ppr FltLifted = ptext SLIT("FltLifted")
345 ppr FltOkSpec = ptext SLIT("FltOkSpec")
346 ppr FltCareful = ptext SLIT("FltCareful")
348 andFF :: FloatFlag -> FloatFlag -> FloatFlag
349 andFF FltCareful _ = FltCareful
350 andFF FltOkSpec FltCareful = FltCareful
351 andFF FltOkSpec flt = FltOkSpec
352 andFF FltLifted flt = flt
354 classifyFF :: CoreBind -> FloatFlag
355 classifyFF (Rec _) = FltLifted
356 classifyFF (NonRec bndr rhs)
357 | not (isStrictId bndr) = FltLifted
358 | exprOkForSpeculation rhs = FltOkSpec
359 | otherwise = FltCareful
361 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
362 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
363 = not (isNilOL fs) && want_to_float && can_float
365 want_to_float = isTopLevel lvl || exprIsCheap rhs
366 can_float = case ff of
368 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
369 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
374 emptyFloats :: Floats
375 emptyFloats = Floats nilOL FltLifted
377 unitFloat :: OutBind -> Floats
378 -- A single-binding float
379 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
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
387 = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
388 seInScope = extendInScopeSet (seInScope env) id }
390 extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
391 -- Add these bindings to the floats, and extend the in-scope env too
392 extendFloats env binds
393 = env { seFloats = seFloats env `addFlts` new_floats,
394 seInScope = extendInScopeSetList (seInScope env) bndrs }
396 bndrs = bindersOfBinds binds
397 new_floats = Floats (toOL binds)
398 (foldr (andFF . classifyFF) FltLifted binds)
400 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
401 -- Add the floats for env2 to env1;
402 -- *plus* the in-scope set for env2, which is bigger
403 -- than that for env1
405 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
406 seInScope = seInScope env2 }
408 addFlts :: Floats -> Floats -> Floats
409 addFlts (Floats bs1 l1) (Floats bs2 l2)
410 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
412 zapFloats :: SimplEnv -> SimplEnv
413 zapFloats env = env { seFloats = emptyFloats }
415 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
416 -- Flattens the floats from env2 into a single Rec group,
417 -- prepends the floats from env1, and puts the result back in env2
418 -- This is all very specific to the way recursive bindings are
419 -- handled; see Simplify.simplRecBind
420 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
421 = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
422 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
424 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
425 wrapFloats env expr = wrapFlts (seFloats env) expr
427 wrapFlts :: Floats -> OutExpr -> OutExpr
428 -- Wrap the floats around the expression, using case-binding where necessary
429 wrapFlts (Floats bs _) body = foldrOL wrap body bs
431 wrap (Rec prs) body = Let (Rec prs) body
432 wrap (NonRec b r) body = bindNonRec b r body
434 getFloats :: SimplEnv -> [CoreBind]
435 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
437 isEmptyFloats :: SimplEnv -> Bool
438 isEmptyFloats env = isEmptyFlts (seFloats env)
440 isEmptyFlts :: Floats -> Bool
441 isEmptyFlts (Floats bs _) = isNilOL bs
443 floatBinds :: Floats -> [OutBind]
444 floatBinds (Floats bs _) = fromOL bs
448 %************************************************************************
452 %************************************************************************
456 substId :: SimplEnv -> Id -> SimplSR
457 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
460 | otherwise -- A local Id
461 = case lookupVarEnv ids v of
462 Just (DoneId v) -> DoneId (refine in_scope v)
464 Nothing -> DoneId (refine in_scope v)
467 -- Get the most up-to-date thing from the in-scope set
468 -- Even though it isn't in the substitution, it may be in
469 -- the in-scope set with better IdInfo
470 refine in_scope v = case lookupInScope in_scope v of
472 Nothing -> WARN( True, ppr v ) v -- This is an error!
474 lookupRecBndr :: SimplEnv -> Id -> Id
475 -- Look up an Id which has been put into the envt by simplRecBndrs,
476 -- but where we have not yet done its RHS
477 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
478 = case lookupVarEnv ids v of
480 Just res -> pprPanic "lookupRecBndr" (ppr v)
481 Nothing -> refine in_scope v
485 %************************************************************************
487 \section{Substituting an Id binder}
489 %************************************************************************
492 These functions are in the monad only so that they can be made strict via seq.
495 simplBinders, simplLamBndrs
496 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
497 simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
498 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
501 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
502 -- Used for lambda and case-bound variables
503 -- Clone Id if necessary, substitute type
504 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
505 -- The substitution is extended only if the variable is cloned, because
506 -- we *don't* need to use it to track occurrence info.
508 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
509 ; seqTyVar tv `seq` return (env', tv) }
510 | otherwise = do { let (env', id) = substIdBndr env bndr
511 ; seqId id `seq` return (env', id) }
514 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
515 -- Used for lambda binders. These sometimes have unfoldings added by
516 -- the worker/wrapper pass that must be preserved, becuase they can't
517 -- be reconstructed from context. For example:
518 -- f x = case x of (a,b) -> fw a b x
519 -- fw a b x{=(a,b)} = ...
520 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
521 simplLamBndr env bndr
522 | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
523 | otherwise = seqId id2 `seq` return (env', id2)
525 old_unf = idUnfolding bndr
526 (env', id1) = substIdBndr env bndr
527 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
530 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
531 -> (SimplEnv, Id) -- Transformed pair
534 -- * Unique changed if necessary
535 -- * Type substituted
536 -- * Unfolding zapped
537 -- * Rules, worker, lbvar info all substituted
538 -- * Fragile occurrence info zapped
539 -- * The in-scope set extended with the returned Id
540 -- * The substitution extended with a DoneId if unique changed
541 -- In this case, the var in the DoneId is the same as the
544 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
546 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
548 = (env { seInScope = in_scope `extendInScopeSet` new_id,
549 seIdSubst = new_subst }, new_id)
551 -- id1 is cloned if necessary
552 id1 = uniqAway in_scope old_id
554 -- id2 has its type zapped
555 id2 = substIdType env id1
557 -- new_id has the final IdInfo
558 subst = mkCoreSubst env
559 new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
561 -- Extend the substitution if the unique has changed
562 -- See the notes with substTyVarBndr for the delSubstEnv
563 -- Also see Note [Extending the Subst] in CoreSubst
564 new_subst | new_id /= old_id
565 = extendVarEnv id_subst old_id (DoneId new_id)
567 = delVarEnv id_subst old_id
571 ------------------------------------
572 seqTyVar :: TyVar -> ()
573 seqTyVar b = b `seq` ()
576 seqId id = seqType (idType id) `seq`
582 seqIds (id:ids) = seqId id `seq` seqIds ids
585 %************************************************************************
589 %************************************************************************
591 Simplifying let binders
592 ~~~~~~~~~~~~~~~~~~~~~~~
593 Rename the binders if necessary,
596 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
597 simplNonRecBndr env id
598 = do { let (env1, id1) = substLetIdBndr env id
599 ; seqId id1 `seq` return (env1, id1) }
602 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
603 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
604 = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
605 ; seqIds ids1 `seq` return env1 }
608 substLetIdBndr :: SimplEnv -> InBndr -- Env and binder to transform
609 -> (SimplEnv, OutBndr)
610 -- C.f. substIdBndr above
611 -- Clone Id if necessary, substitute its type
612 -- Return an Id with its fragile info zapped
613 -- namely, any info that depends on free variables
614 -- [addLetIdInfo, below, will restore its IdInfo]
615 -- We want to retain robust info, especially arity and demand info,
616 -- so that they are available to occurrences that occur in an
617 -- earlier binding of a letrec
618 -- Augment the subtitution
619 -- if the unique changed, *or*
620 -- if there's interesting occurrence info
622 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
623 = (env { seInScope = in_scope `extendInScopeSet` new_id,
624 seIdSubst = new_subst }, new_id)
626 id1 = uniqAway in_scope old_id
627 id2 = substIdType env id1
629 -- We want to get rid of any info that's dependent on free variables,
630 -- but keep other info (like the arity).
631 new_id = zapFragileIdInfo id2
633 -- Extend the substitution if the unique has changed,
634 -- or there's some useful occurrence information
635 -- See the notes with substTyVarBndr for the delSubstEnv
636 new_subst | new_id /= old_id
637 = extendVarEnv id_subst old_id (DoneId new_id)
639 = delVarEnv id_subst old_id
642 Add IdInfo back onto a let-bound Id
643 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
644 We must transfer the IdInfo of the original binder to the new binder.
645 This is crucial, to preserve
649 etc. To do this we must apply the current substitution,
650 which incorporates earlier substitutions in this very letrec group.
652 NB 1. We do this *before* processing the RHS of the binder, so that
653 its substituted rules are visible in its own RHS.
654 This is important. Manuel found cases where he really, really
655 wanted a RULE for a recursive function to apply in that function's
658 NB 2: ARITY. We *do* transfer the arity. This is important, so that
659 the arity of an Id is visible in its own RHS. For example:
660 f = \x. ....g (\y. f y)....
661 We can eta-reduce the arg to g, becuase f is a value. But that
664 This interacts with the 'state hack' too:
669 Can we eta-expand f? Only if we see that f has arity 1, and then we
670 take advantage of the 'state hack' on the result of
671 (f y) :: State# -> (State#, Int) to expand the arity one more.
673 There is a disadvantage though. Making the arity visible in the RHA
674 allows us to eta-reduce
678 which technically is not sound. This is very much a corner case, so
679 I'm not worried about it. Another idea is to ensure that f's arity
680 never decreases; its arity started as 1, and we should never eta-reduce
683 NB 3: OccInfo. It's important that we *do* transer the loop-breaker
684 OccInfo, because that's what stops the Id getting inlined infinitely,
685 in the body of the letrec.
687 NB 4: does no harm for non-recursive bindings
689 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
694 Here, we'll do postInlineUnconditionally on f, and we must "see" that
695 when substituting in h's RULE.
698 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
699 addLetIdInfo env in_id out_id
700 = (modifyInScope env out_id final_id, final_id)
702 final_id = out_id `setIdInfo` new_info
703 subst = mkCoreSubst env
704 old_info = idInfo in_id
705 new_info = case substIdInfo subst old_info of
707 Just new_info -> new_info
709 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
714 -- Keep only 'robust' OccInfo
717 -- Seq'ing on the returned IdInfo is enough to cause all the
718 -- substitutions to happen completely
720 substIdInfo subst info
721 | nothing_to_do = Nothing
722 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
723 `setSpecInfo` CoreSubst.substSpec subst old_rules
724 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
725 `setUnfoldingInfo` noUnfolding)
726 -- setSpecInfo does a seq
727 -- setWorkerInfo does a seq
729 nothing_to_do = keep_occ &&
730 isEmptySpecInfo old_rules &&
731 not (workerExists old_wrkr) &&
732 not (hasUnfolding (unfoldingInfo info))
734 keep_occ = not (isFragileOcc old_occ)
735 old_occ = occInfo info
736 old_rules = specInfo info
737 old_wrkr = workerInfo info
740 substIdType :: SimplEnv -> Id -> Id
741 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
742 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
743 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
744 -- The tyVarsOfType is cheaper than it looks
745 -- because we cache the free tyvars of the type
746 -- in a Note in the id's type itself
751 substUnfolding env NoUnfolding = NoUnfolding
752 substUnfolding env (OtherCon cons) = OtherCon cons
753 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
754 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
758 %************************************************************************
760 Impedence matching to type substitution
762 %************************************************************************
765 substTy :: SimplEnv -> Type -> Type
766 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
767 = Type.substTy (TvSubst in_scope tv_env) ty
769 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
770 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
771 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
772 (TvSubst in_scope' tv_env', tv')
773 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
775 -- When substituting in rules etc we can get CoreSubst to do the work
776 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
777 -- here. I think the this will not usually result in a lot of work;
778 -- the substitutions are typically small, and laziness will avoid work in many cases.
780 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
781 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
782 = mk_subst tv_env id_env
784 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
786 fiddle (DoneEx e) = e
787 fiddle (DoneId v) = Var v
788 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
790 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
792 | isEmptySimplSubst env = expr
793 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr