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,
36 wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats,
40 #include "HsVersions.h"
55 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
56 import qualified Type ( substTy, substTyVarBndr )
57 import Type hiding ( substTy, substTyVarBndr )
66 %************************************************************************
68 \subsection[Simplify-types]{Type declarations}
70 %************************************************************************
73 type InBndr = CoreBndr
74 type InId = Id -- Not yet cloned
75 type InType = Type -- Ditto
76 type InBind = CoreBind
77 type InExpr = CoreExpr
80 type InCoercion = Coercion
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
93 %************************************************************************
95 \subsubsection{The @SimplEnv@ type}
97 %************************************************************************
103 seMode :: SimplifierMode,
104 seChkr :: SwitchChecker,
105 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
107 -- Rules from other modules
108 seExtRules :: RuleBase,
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
115 -- See Note [Simplifier floats]
117 -- The current substitution
118 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
119 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
123 pprSimplEnv :: SimplEnv -> SDoc
124 -- Used for debugging; selective
126 = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
127 ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
129 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
130 -- See Note [Extending the Subst] in CoreSubst
133 = DoneEx OutExpr -- Completed term
134 | DoneId OutId -- Completed term variable
135 | ContEx TvSubstEnv -- A suspended substitution
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) -}]
145 -- fvs = exprFreeVars e
146 -- filter_env env = filterVarEnv_Directly keep env
147 -- keep uniq _ = uniq `elemUFM_Directly` fvs
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
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.
162 The in-scope set is actually a mapping OutVar -> OutVar, and
163 in case expressions we sometimes bind
166 The substitution is *apply-once* only, because InIds and OutIds can overlap.
167 For example, we generally omit mappings
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.
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
180 Of course, the substitution *must* applied! Things in its domain
181 simply aren't necessarily bound in the result.
183 * substId adds a binding (DoneId new_id) to the substitution if
184 the Id's unique has changed
187 Note, though that the substitution isn't necessarily extended
188 if the type changes. Why not? Because of the next point:
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.
195 [The DoneEx and DoneVar hits map to "new" stuff.]
197 * It follows that substExpr must not do a no-op if the substitution is empty.
198 substType is free to do so, however.
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.
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:
209 That's why the "set" is actually a VarEnv Var
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".
221 ---------------------
222 getSwitchChecker :: SimplEnv -> SwitchChecker
223 getSwitchChecker env = seChkr env
225 ---------------------
226 getMode :: SimplEnv -> SimplifierMode
227 getMode env = seMode env
229 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
230 setMode mode env = env { seMode = mode }
232 ---------------------
233 getEnclosingCC :: SimplEnv -> CostCentreStack
234 getEnclosingCC env = seCC env
236 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
237 setEnclosingCC env cc = env {seCC = cc}
239 ---------------------
240 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
241 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
242 = env {seIdSubst = extendVarEnv subst var res}
244 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
245 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
246 = env {seTvSubst = extendVarEnv subst var res}
248 ---------------------
249 getInScope :: SimplEnv -> InScopeSet
250 getInScope env = seInScope env
252 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
253 setInScopeSet env in_scope = env {seInScope = in_scope}
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 }
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 }
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
278 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
279 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
280 = env {seInScope = modifyInScopeSet in_scope v v'}
282 ---------------------
283 zapSubstEnv :: SimplEnv -> SimplEnv
284 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
286 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
287 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
289 mkContEx :: SimplEnv -> InExpr -> SimplSR
290 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
292 isEmptySimplSubst :: SimplEnv -> Bool
293 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
294 = isEmptyVarEnv tvs && isEmptyVarEnv ids
296 ---------------------
297 getRules :: SimplEnv -> RuleBase
298 getRules = seExtRules
303 %************************************************************************
307 %************************************************************************
309 Note [Simplifier floats]
310 ~~~~~~~~~~~~~~~~~~~~~~~~~
311 The Floats is a bunch of bindings, classified by a FloatFlag.
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#)
322 data Floats = Floats (OrdList OutBind) FloatFlag
323 -- See Note [Simplifier floats]
326 = FltLifted -- All bindings are lifted and lazy
327 -- Hence ok to float to top level, or recursive
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)
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
341 instance Outputable Floats where
342 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
344 instance Outputable FloatFlag where
345 ppr FltLifted = ptext SLIT("FltLifted")
346 ppr FltOkSpec = ptext SLIT("FltOkSpec")
347 ppr FltCareful = ptext SLIT("FltCareful")
349 andFF :: FloatFlag -> FloatFlag -> FloatFlag
350 andFF FltCareful _ = FltCareful
351 andFF FltOkSpec FltCareful = FltCareful
352 andFF FltOkSpec flt = FltOkSpec
353 andFF FltLifted flt = flt
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
362 canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool
363 canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff})
364 = canFloatFlt lvl rec str ff
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
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 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
395 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
396 seInScope = seInScope env2 }
398 addFlts :: Floats -> Floats -> Floats
399 addFlts (Floats bs1 l1) (Floats bs2 l2)
400 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
402 zapFloats :: SimplEnv -> SimplEnv
403 zapFloats env = env { seFloats = emptyFloats }
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)))}
414 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
415 wrapFloats env expr = wrapFlts (seFloats env) expr
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
421 wrap (Rec prs) body = Let (Rec prs) body
422 wrap (NonRec b r) body = bindNonRec b r body
424 getFloats :: SimplEnv -> [CoreBind]
425 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
427 isEmptyFloats :: SimplEnv -> Bool
428 isEmptyFloats env = isEmptyFlts (seFloats env)
430 isEmptyFlts :: Floats -> Bool
431 isEmptyFlts (Floats bs _) = isNilOL bs
433 floatBinds :: Floats -> [OutBind]
434 floatBinds (Floats bs _) = fromOL bs
438 %************************************************************************
442 %************************************************************************
446 substId :: SimplEnv -> Id -> SimplSR
447 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
450 | otherwise -- A local Id
451 = case lookupVarEnv ids v of
452 Just (DoneId v) -> DoneId (refine in_scope v)
454 Nothing -> DoneId (refine in_scope v)
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
462 Nothing -> WARN( True, ppr v ) v -- This is an error!
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
470 Just res -> pprPanic "lookupRecBndr" (ppr v)
471 Nothing -> refine in_scope v
475 %************************************************************************
477 \section{Substituting an Id binder}
479 %************************************************************************
482 These functions are in the monad only so that they can be made strict via seq.
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
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.
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) }
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)
515 old_unf = idUnfolding bndr
516 (env', id1) = substIdBndr env bndr
517 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
520 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
521 -> (SimplEnv, Id) -- Transformed pair
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
534 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
536 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
538 = (env { seInScope = in_scope `extendInScopeSet` new_id,
539 seIdSubst = new_subst }, new_id)
541 -- id1 is cloned if necessary
542 id1 = uniqAway in_scope old_id
544 -- id2 has its type zapped
545 id2 = substIdType env id1
547 -- new_id has the final IdInfo
548 subst = mkCoreSubst env
549 new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
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)
557 = delVarEnv id_subst old_id
561 ------------------------------------
562 seqTyVar :: TyVar -> ()
563 seqTyVar b = b `seq` ()
566 seqId id = seqType (idType id) `seq`
572 seqIds (id:ids) = seqId id `seq` seqIds ids
575 %************************************************************************
579 %************************************************************************
581 Simplifying let binders
582 ~~~~~~~~~~~~~~~~~~~~~~~
583 Rename the binders if necessary,
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) }
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 }
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
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)
616 id1 = uniqAway in_scope old_id
617 id2 = substIdType env id1
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
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)
629 = delVarEnv id_subst old_id
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
639 etc. To do this we must apply the current substitution,
640 which incorporates earlier substitutions in this very letrec group.
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
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
654 This interacts with the 'state hack' too:
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.
663 There is a disadvantage though. Making the arity visible in the RHA
664 allows us to eta-reduce
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
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.
677 NB 4: does no harm for non-recursive bindings
679 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
684 Here, we'll do postInlineUnconditionally on f, and we must "see" that
685 when substituting in h's RULE.
688 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
689 addLetIdInfo env in_id out_id
690 = (modifyInScope env out_id final_id, final_id)
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
697 Just new_info -> new_info
699 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
704 -- Keep only 'robust' OccInfo
707 -- Seq'ing on the returned IdInfo is enough to cause all the
708 -- substitutions to happen completely
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
719 nothing_to_do = keep_occ &&
720 isEmptySpecInfo old_rules &&
721 not (workerExists old_wrkr) &&
722 not (hasUnfolding (unfoldingInfo info))
724 keep_occ = not (isFragileOcc old_occ)
725 old_occ = occInfo info
726 old_rules = specInfo info
727 old_wrkr = workerInfo info
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
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
748 %************************************************************************
750 Impedence matching to type substitution
752 %************************************************************************
755 substTy :: SimplEnv -> Type -> Type
756 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
757 = Type.substTy (TvSubst in_scope tv_env) ty
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')
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.
770 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
771 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
772 = mk_subst tv_env id_env
774 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
776 fiddle (DoneEx e) = e
777 fiddle (DoneId v) = Var v
778 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
780 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
782 | isEmptySimplSubst env = expr
783 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr