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,
14 -- The simplifier mode
18 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
19 isAmongSimpl, intSwitchSet, switchIsOn,
21 setEnclosingCC, getEnclosingCC,
24 SimplEnv(..), pprSimplEnv, -- Temp not abstract
25 mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
26 zapSubstEnv, setSubstEnv,
27 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
30 SimplSR(..), mkContEx, substId, lookupRecBndr,
32 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
33 simplBinder, simplBinders, addLetIdInfo,
37 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats,
38 wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats,
42 #include "HsVersions.h"
57 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
58 import qualified Type ( substTy, substTyVarBndr )
59 import Type hiding ( substTy, substTyVarBndr )
68 %************************************************************************
70 \subsection[Simplify-types]{Type declarations}
72 %************************************************************************
75 type InBndr = CoreBndr
76 type InId = Id -- Not yet cloned
77 type InType = Type -- Ditto
78 type InBind = CoreBind
79 type InExpr = CoreExpr
82 type InCoercion = Coercion
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
96 isStrictBndr :: Id -> Bool
98 = ASSERT2( isId bndr, ppr bndr )
99 isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)
102 %************************************************************************
104 \subsubsection{The @SimplEnv@ type}
106 %************************************************************************
112 seMode :: SimplifierMode,
113 seChkr :: SwitchChecker,
114 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
116 -- Rules from other modules
117 seExtRules :: RuleBase,
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
124 -- See Note [Simplifier floats]
126 -- The current substitution
127 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
128 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
132 pprSimplEnv :: SimplEnv -> SDoc
133 -- Used for debugging; selective
135 = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
136 ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
138 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
139 -- See Note [Extending the Subst] in CoreSubst
142 = DoneEx OutExpr -- Completed term
143 | DoneId OutId -- Completed term variable
144 | ContEx TvSubstEnv -- A suspended substitution
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) -}]
154 -- fvs = exprFreeVars e
155 -- filter_env env = filterVarEnv_Directly keep env
156 -- keep uniq _ = uniq `elemUFM_Directly` fvs
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
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.
171 The in-scope set is actually a mapping OutVar -> OutVar, and
172 in case expressions we sometimes bind
175 The substitution is *apply-once* only, because InIds and OutIds can overlap.
176 For example, we generally omit mappings
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.
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
189 Of course, the substitution *must* applied! Things in its domain
190 simply aren't necessarily bound in the result.
192 * substId adds a binding (DoneId new_id) to the substitution if
193 the Id's unique has changed
196 Note, though that the substitution isn't necessarily extended
197 if the type changes. Why not? Because of the next point:
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.
204 [The DoneEx and DoneVar hits map to "new" stuff.]
206 * It follows that substExpr must not do a no-op if the substitution is empty.
207 substType is free to do so, however.
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.
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:
218 That's why the "set" is actually a VarEnv Var
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".
230 ---------------------
231 getSwitchChecker :: SimplEnv -> SwitchChecker
232 getSwitchChecker env = seChkr env
234 ---------------------
235 getMode :: SimplEnv -> SimplifierMode
236 getMode env = seMode env
238 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
239 setMode mode env = env { seMode = mode }
241 ---------------------
242 getEnclosingCC :: SimplEnv -> CostCentreStack
243 getEnclosingCC env = seCC env
245 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
246 setEnclosingCC env cc = env {seCC = cc}
248 ---------------------
249 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
250 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
251 = env {seIdSubst = extendVarEnv subst var res}
253 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
254 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
255 = env {seTvSubst = extendVarEnv subst var res}
257 ---------------------
258 getInScope :: SimplEnv -> InScopeSet
259 getInScope env = seInScope env
261 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
262 setInScopeSet env in_scope = env {seInScope = in_scope}
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 }
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 }
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
287 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
288 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
289 = env {seInScope = modifyInScopeSet in_scope v v'}
291 ---------------------
292 zapSubstEnv :: SimplEnv -> SimplEnv
293 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
295 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
296 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
298 mkContEx :: SimplEnv -> InExpr -> SimplSR
299 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
301 isEmptySimplSubst :: SimplEnv -> Bool
302 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
303 = isEmptyVarEnv tvs && isEmptyVarEnv ids
305 ---------------------
306 getRules :: SimplEnv -> RuleBase
307 getRules = seExtRules
312 %************************************************************************
316 %************************************************************************
318 Note [Simplifier floats]
319 ~~~~~~~~~~~~~~~~~~~~~~~~~
320 The Floats is a bunch of bindings, classified by a FloatFlag.
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#)
331 data Floats = Floats (OrdList OutBind) FloatFlag
332 -- See Note [Simplifier floats]
335 = FltLifted -- All bindings are lifted and lazy
336 -- Hence ok to float to top level, or recursive
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)
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
350 instance Outputable Floats where
351 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
353 instance Outputable FloatFlag where
354 ppr FltLifted = ptext SLIT("FltLifted")
355 ppr FltOkSpec = ptext SLIT("FltOkSpec")
356 ppr FltCareful = ptext SLIT("FltCareful")
358 andFF :: FloatFlag -> FloatFlag -> FloatFlag
359 andFF FltCareful _ = FltCareful
360 andFF FltOkSpec FltCareful = FltCareful
361 andFF FltOkSpec flt = FltOkSpec
362 andFF FltLifted flt = flt
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
371 canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool
372 canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff})
373 = canFloatFlt lvl rec str ff
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
383 emptyFloats :: Floats
384 emptyFloats = Floats nilOL FltLifted
386 unitFloat :: OutBind -> Floats
387 -- A single-binding float
388 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
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
396 = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
397 seInScope = extendInScopeSet (seInScope env) id }
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
404 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
405 seInScope = seInScope env2 }
407 addFlts :: Floats -> Floats -> Floats
408 addFlts (Floats bs1 l1) (Floats bs2 l2)
409 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
411 zapFloats :: SimplEnv -> SimplEnv
412 zapFloats env = env { seFloats = emptyFloats }
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)))}
423 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
424 wrapFloats env expr = wrapFlts (seFloats env) expr
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
430 wrap (Rec prs) body = Let (Rec prs) body
431 wrap (NonRec b r) body = bindNonRec b r body
433 getFloats :: SimplEnv -> [CoreBind]
434 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
436 isEmptyFloats :: SimplEnv -> Bool
437 isEmptyFloats env = isEmptyFlts (seFloats env)
439 isEmptyFlts :: Floats -> Bool
440 isEmptyFlts (Floats bs _) = isNilOL bs
442 floatBinds :: Floats -> [OutBind]
443 floatBinds (Floats bs _) = fromOL bs
447 %************************************************************************
451 %************************************************************************
455 substId :: SimplEnv -> Id -> SimplSR
456 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
459 | otherwise -- A local Id
460 = case lookupVarEnv ids v of
461 Just (DoneId v) -> DoneId (refine in_scope v)
463 Nothing -> DoneId (refine in_scope v)
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
471 Nothing -> WARN( True, ppr v ) v -- This is an error!
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
479 Just res -> pprPanic "lookupRecBndr" (ppr v)
480 Nothing -> refine in_scope v
484 %************************************************************************
486 \section{Substituting an Id binder}
488 %************************************************************************
491 These functions are in the monad only so that they can be made strict via seq.
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
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.
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) }
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)
524 old_unf = idUnfolding bndr
525 (env', id1) = substIdBndr env bndr
526 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
529 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
530 -> (SimplEnv, Id) -- Transformed pair
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
543 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
545 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
547 = (env { seInScope = in_scope `extendInScopeSet` new_id,
548 seIdSubst = new_subst }, new_id)
550 -- id1 is cloned if necessary
551 id1 = uniqAway in_scope old_id
553 -- id2 has its type zapped
554 id2 = substIdType env id1
556 -- new_id has the final IdInfo
557 subst = mkCoreSubst env
558 new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
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)
566 = delVarEnv id_subst old_id
570 ------------------------------------
571 seqTyVar :: TyVar -> ()
572 seqTyVar b = b `seq` ()
575 seqId id = seqType (idType id) `seq`
581 seqIds (id:ids) = seqId id `seq` seqIds ids
584 %************************************************************************
588 %************************************************************************
590 Simplifying let binders
591 ~~~~~~~~~~~~~~~~~~~~~~~
592 Rename the binders if necessary,
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) }
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 }
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 completely zapped IdInfo
612 -- [addLetIdInfo, below, will restore its IdInfo]
613 -- Augment the subtitution
614 -- if the unique changed, *or*
615 -- if there's interesting occurrence info
617 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
618 = (env { seInScope = in_scope `extendInScopeSet` new_id,
619 seIdSubst = new_subst }, new_id)
621 id1 = uniqAway in_scope old_id
622 id2 = substIdType env id1
623 -- we want to get rid of any info that's dependent on free variables,
624 -- but keep other info (like the arity).
625 new_id = zapFragileIdInfo id2
627 -- Extend the substitution if the unique has changed,
628 -- or there's some useful occurrence information
629 -- See the notes with substTyVarBndr for the delSubstEnv
630 new_subst | new_id /= old_id
631 = extendVarEnv id_subst old_id (DoneId new_id)
633 = delVarEnv id_subst old_id
636 Add IdInfo back onto a let-bound Id
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
638 We must transfer the IdInfo of the original binder to the new binder.
639 This is crucial, to preserve
643 etc. To do this we must apply the current substitution,
644 which incorporates earlier substitutions in this very letrec group.
646 NB 1. We do this *before* processing the RHS of the binder, so that
647 its substituted rules are visible in its own RHS.
648 This is important. Manuel found cases where he really, really
649 wanted a RULE for a recursive function to apply in that function's
652 NB 2: ARITY. We *do* transfer the arity. This is important, so that
653 the arity of an Id is visible in its own RHS. For example:
654 f = \x. ....g (\y. f y)....
655 We can eta-reduce the arg to g, becuase f is a value. But that
658 This interacts with the 'state hack' too:
663 Can we eta-expand f? Only if we see that f has arity 1, and then we
664 take advantage of the 'state hack' on the result of
665 (f y) :: State# -> (State#, Int) to expand the arity one more.
667 There is a disadvantage though. Making the arity visible in the RHA
668 allows us to eta-reduce
672 which technically is not sound. This is very much a corner case, so
673 I'm not worried about it. Another idea is to ensure that f's arity
674 never decreases; its arity started as 1, and we should never eta-reduce
677 NB 3: OccInfo. It's important that we *do* transer the loop-breaker
678 OccInfo, because that's what stops the Id getting inlined infinitely,
679 in the body of the letrec.
681 NB 4: does no harm for non-recursive bindings
683 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
688 Here, we'll do postInlineUnconditionally on f, and we must "see" that
689 when substituting in h's RULE.
692 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
693 addLetIdInfo env in_id out_id
694 = (modifyInScope env out_id final_id, final_id)
696 final_id = out_id `setIdInfo` new_info
697 subst = mkCoreSubst env
698 old_info = idInfo in_id
699 new_info = case substIdInfo subst old_info of
701 Just new_info -> new_info
703 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
708 -- Keep only 'robust' OccInfo
711 -- Seq'ing on the returned IdInfo is enough to cause all the
712 -- substitutions to happen completely
714 substIdInfo subst info
715 | nothing_to_do = Nothing
716 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
717 `setSpecInfo` CoreSubst.substSpec subst old_rules
718 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
719 `setUnfoldingInfo` noUnfolding)
720 -- setSpecInfo does a seq
721 -- setWorkerInfo does a seq
723 nothing_to_do = keep_occ &&
724 isEmptySpecInfo old_rules &&
725 not (workerExists old_wrkr) &&
726 not (hasUnfolding (unfoldingInfo info))
728 keep_occ = not (isFragileOcc old_occ)
729 old_occ = occInfo info
730 old_rules = specInfo info
731 old_wrkr = workerInfo info
734 substIdType :: SimplEnv -> Id -> Id
735 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
736 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
737 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
738 -- The tyVarsOfType is cheaper than it looks
739 -- because we cache the free tyvars of the type
740 -- in a Note in the id's type itself
745 substUnfolding env NoUnfolding = NoUnfolding
746 substUnfolding env (OtherCon cons) = OtherCon cons
747 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
748 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
752 %************************************************************************
754 Impedence matching to type substitution
756 %************************************************************************
759 substTy :: SimplEnv -> Type -> Type
760 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
761 = Type.substTy (TvSubst in_scope tv_env) ty
763 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
764 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
765 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
766 (TvSubst in_scope' tv_env', tv')
767 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
769 -- When substituting in rules etc we can get CoreSubst to do the work
770 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
771 -- here. I think the this will not usually result in a lot of work;
772 -- the substitutions are typically small, and laziness will avoid work in many cases.
774 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
775 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
776 = mk_subst tv_env id_env
778 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
780 fiddle (DoneEx e) = e
781 fiddle (DoneId v) = Var v
782 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
784 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
786 | isEmptySimplSubst env = expr
787 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr