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
13 setMode, getMode, updMode,
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,
26 getSimplRules, inGentleMode,
28 SimplSR(..), mkContEx, substId, lookupRecBndr,
30 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
31 simplBinder, simplBinders, addBndrRules,
32 substExpr, substTy, mkCoreSubst,
35 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
36 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
37 doFloatFromRhs, getFloats
40 #include "HsVersions.h"
52 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding )
53 import qualified Type ( substTy, substTyVarBndr )
54 import Type hiding ( substTy, substTyVarBndr )
65 %************************************************************************
67 \subsection[Simplify-types]{Type declarations}
69 %************************************************************************
72 type InBndr = CoreBndr
73 type InId = Id -- Not yet cloned
74 type InType = Type -- Ditto
75 type InBind = CoreBind
76 type InExpr = CoreExpr
79 type InCoercion = Coercion
81 type OutBndr = CoreBndr
82 type OutId = Id -- Cloned
83 type OutTyVar = TyVar -- Cloned
84 type OutType = Type -- Cloned
85 type OutCoercion = Coercion
86 type OutBind = CoreBind
87 type OutExpr = CoreExpr
92 %************************************************************************
94 \subsubsection{The @SimplEnv@ type}
96 %************************************************************************
102 seMode :: SimplifierMode,
103 seChkr :: SwitchChecker,
104 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
106 -- The current set of in-scope variables
107 -- They are all OutVars, and all bound in this module
108 seInScope :: InScopeSet, -- OutVars only
109 -- Includes all variables bound by seFloats
111 -- See Note [Simplifier floats]
113 -- The current substitution
114 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
115 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
119 pprSimplEnv :: SimplEnv -> SDoc
120 -- Used for debugging; selective
122 = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
123 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ]
125 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
126 -- See Note [Extending the Subst] in CoreSubst
129 = DoneEx OutExpr -- Completed term
130 | DoneId OutId -- Completed term variable
131 | ContEx TvSubstEnv -- A suspended substitution
135 instance Outputable SimplSR where
136 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
137 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
138 ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
139 ppr (filter_env tv), ppr (filter_env id) -}]
141 -- fvs = exprFreeVars e
142 -- filter_env env = filterVarEnv_Directly keep env
143 -- keep uniq _ = uniq `elemUFM_Directly` fvs
148 The in-scope part of Subst includes *all* in-scope TyVars and Ids
149 The elements of the set may have better IdInfo than the
150 occurrences of in-scope Ids, and (more important) they will
151 have a correctly-substituted type. So we use a lookup in this
152 set to replace occurrences
154 The Ids in the InScopeSet are replete with their Rules,
155 and as we gather info about the unfolding of an Id, we replace
156 it in the in-scope set.
158 The in-scope set is actually a mapping OutVar -> OutVar, and
159 in case expressions we sometimes bind
162 The substitution is *apply-once* only, because InIds and OutIds can overlap.
163 For example, we generally omit mappings
165 from the substitution, when we decide not to clone a77, but it's quite
166 legitimate to put the mapping in the substitution anyway.
168 Furthermore, consider
169 let x = case k of I# x77 -> ... in
170 let y = case k of I# x77 -> ... in ...
171 and suppose the body is strict in both x and y. Then the simplifier
172 will pull the first (case k) to the top; so the second (case k) will
173 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
176 Of course, the substitution *must* applied! Things in its domain
177 simply aren't necessarily bound in the result.
179 * substId adds a binding (DoneId new_id) to the substitution if
180 the Id's unique has changed
183 Note, though that the substitution isn't necessarily extended
184 if the type changes. Why not? Because of the next point:
186 * We *always, always* finish by looking up in the in-scope set
187 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
188 Reason: so that we never finish up with a "old" Id in the result.
189 An old Id might point to an old unfolding and so on... which gives a space leak.
191 [The DoneEx and DoneVar hits map to "new" stuff.]
193 * It follows that substExpr must not do a no-op if the substitution is empty.
194 substType is free to do so, however.
196 * When we come to a let-binding (say) we generate new IdInfo, including an
197 unfolding, attach it to the binder, and add this newly adorned binder to
198 the in-scope set. So all subsequent occurrences of the binder will get mapped
199 to the full-adorned binder, which is also the one put in the binding site.
201 * The in-scope "set" usually maps x->x; we use it simply for its domain.
202 But sometimes we have two in-scope Ids that are synomyms, and should
203 map to the same target: x->x, y->x. Notably:
205 That's why the "set" is actually a VarEnv Var
209 mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
210 mkSimplEnv switches mode
211 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
212 seMode = mode, seInScope = emptyInScopeSet,
213 seFloats = emptyFloats,
214 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
215 -- The top level "enclosing CC" is "SUBSUMED".
217 ---------------------
218 getSwitchChecker :: SimplEnv -> SwitchChecker
219 getSwitchChecker env = seChkr env
221 ---------------------
222 getMode :: SimplEnv -> SimplifierMode
223 getMode env = seMode env
225 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
226 setMode mode env = env { seMode = mode }
228 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
229 updMode upd env = env { seMode = upd (seMode env) }
231 inGentleMode :: SimplEnv -> Bool
232 inGentleMode env = case seMode env of
233 SimplGently {} -> True
236 ---------------------
237 getEnclosingCC :: SimplEnv -> CostCentreStack
238 getEnclosingCC env = seCC env
240 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
241 setEnclosingCC env cc = env {seCC = cc}
243 ---------------------
244 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
245 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
246 = env {seIdSubst = extendVarEnv subst var res}
248 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
249 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
250 = env {seTvSubst = extendVarEnv subst var res}
252 ---------------------
253 getInScope :: SimplEnv -> InScopeSet
254 getInScope env = seInScope env
256 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
257 setInScopeSet env in_scope = env {seInScope = in_scope}
259 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
260 -- Set the in-scope set, and *zap* the floats
261 setInScope env env_with_scope
262 = env { seInScope = seInScope env_with_scope,
263 seFloats = emptyFloats }
265 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
266 -- Set the in-scope set *and* the floats
267 setFloats env env_with_floats
268 = env { seInScope = seInScope env_with_floats,
269 seFloats = seFloats env_with_floats }
271 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
272 -- The new Ids are guaranteed to be freshly allocated
273 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
274 = env { seInScope = in_scope `extendInScopeSetList` vs,
275 seIdSubst = id_subst `delVarEnvList` vs }
276 -- Why delete? Consider
277 -- let x = a*b in (x, \x -> x+3)
278 -- We add [x |-> a*b] to the substitution, but we must
279 -- _delete_ it from the substitution when going inside
282 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
283 -- The variable should already be in scope, but
284 -- replace the existing version with this new one
285 -- which has more information
286 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
287 = env {seInScope = extendInScopeSet in_scope v}
289 ---------------------
290 zapSubstEnv :: SimplEnv -> SimplEnv
291 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
293 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
294 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
296 mkContEx :: SimplEnv -> InExpr -> SimplSR
297 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
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 _ = 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 || exprIsExpandable 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 bind
395 = env { seFloats = seFloats env `addFlts` unitFloat bind,
396 seInScope = extendInScopeSetList (seInScope env) bndrs }
398 bndrs = bindersOf bind
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; _ -> 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 %************************************************************************
454 Note [Global Ids in the substitution]
455 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 We look up even a global (eg imported) Id in the substitution. Consider
457 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
458 The binder-swap in the occurence analyser will add a binding
459 for a LocalId version of g (with the same unique though):
460 case X.g_34 of b { (a,b) -> let g_34 = b in
461 ... case X.g_34 of { (p,q) -> ...} ... }
462 So we want to look up the inner X.g_34 in the substitution, where we'll
463 find that it has been substituted by b. (Or conceivably cloned.)
466 substId :: SimplEnv -> InId -> SimplSR
467 -- Returns DoneEx only on a non-Var expression
468 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
469 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
470 Nothing -> DoneId (refine in_scope v)
471 Just (DoneId v) -> DoneId (refine in_scope v)
472 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
473 Just res -> res -- DoneEx non-var, or ContEx
476 -- Get the most up-to-date thing from the in-scope set
477 -- Even though it isn't in the substitution, it may be in
478 -- the in-scope set with better IdInfo
479 refine :: InScopeSet -> Var -> Var
481 | isLocalId v = case lookupInScope in_scope v of
483 Nothing -> WARN( True, ppr v ) v -- This is an error!
486 lookupRecBndr :: SimplEnv -> InId -> OutId
487 -- Look up an Id which has been put into the envt by simplRecBndrs,
488 -- but where we have not yet done its RHS
489 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
490 = case lookupVarEnv ids v of
492 Just _ -> pprPanic "lookupRecBndr" (ppr v)
493 Nothing -> refine in_scope v
497 %************************************************************************
499 \section{Substituting an Id binder}
501 %************************************************************************
504 These functions are in the monad only so that they can be made strict via seq.
507 simplBinders, simplLamBndrs
508 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
509 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
510 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
513 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
514 -- Used for lambda and case-bound variables
515 -- Clone Id if necessary, substitute type
516 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
517 -- The substitution is extended only if the variable is cloned, because
518 -- we *don't* need to use it to track occurrence info.
520 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
521 ; seqTyVar tv `seq` return (env', tv) }
522 | otherwise = do { let (env', id) = substIdBndr env bndr
523 ; seqId id `seq` return (env', id) }
526 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
527 -- Used for lambda binders. These sometimes have unfoldings added by
528 -- the worker/wrapper pass that must be preserved, because they can't
529 -- be reconstructed from context. For example:
530 -- f x = case x of (a,b) -> fw a b x
531 -- fw a b x{=(a,b)} = ...
532 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
533 simplLamBndr env bndr
534 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
535 | otherwise = simplBinder env bndr -- Normal case
537 old_unf = idUnfolding bndr
538 (env1, id1) = substIdBndr env bndr
539 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
540 env2 = modifyInScope env1 id2
543 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
544 -- A non-recursive let binder
545 simplNonRecBndr env id
546 = do { let (env1, id1) = substIdBndr env id
547 ; seqId id1 `seq` return (env1, id1) }
550 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
551 -- Recursive let binders
552 simplRecBndrs env@(SimplEnv {}) ids
553 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
554 ; seqIds ids1 `seq` return env1 }
557 substIdBndr :: SimplEnv
558 -> InBndr -- Env and binder to transform
559 -> (SimplEnv, OutBndr)
560 -- Clone Id if necessary, substitute its type
561 -- Return an Id with its
562 -- * Type substituted
563 -- * UnfoldingInfo, Rules, WorkerInfo zapped
564 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
565 -- * Robust info, retained especially arity and demand info,
566 -- so that they are available to occurrences that occur in an
567 -- earlier binding of a letrec
569 -- For the robust info, see Note [Arity robustness]
571 -- Augment the substitution if the unique changed
572 -- Extend the in-scope set with the new Id
574 -- Similar to CoreSubst.substIdBndr, except that
575 -- the type of id_subst differs
576 -- all fragile info is zapped
578 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
580 = (env { seInScope = in_scope `extendInScopeSet` new_id,
581 seIdSubst = new_subst }, new_id)
583 id1 = uniqAway in_scope old_id
584 id2 = substIdType env id1
585 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
586 -- and fragile OccInfo
588 -- Extend the substitution if the unique has changed,
589 -- or there's some useful occurrence information
590 -- See the notes with substTyVarBndr for the delSubstEnv
591 new_subst | new_id /= old_id
592 = extendVarEnv id_subst old_id (DoneId new_id)
594 = delVarEnv id_subst old_id
598 ------------------------------------
599 seqTyVar :: TyVar -> ()
600 seqTyVar b = b `seq` ()
603 seqId id = seqType (idType id) `seq`
609 seqIds (id:ids) = seqId id `seq` seqIds ids
613 Note [Arity robustness]
614 ~~~~~~~~~~~~~~~~~~~~~~~
615 We *do* transfer the arity from from the in_id of a let binding to the
616 out_id. This is important, so that the arity of an Id is visible in
617 its own RHS. For example:
618 f = \x. ....g (\y. f y)....
619 We can eta-reduce the arg to g, becuase f is a value. But that
622 This interacts with the 'state hack' too:
627 Can we eta-expand f? Only if we see that f has arity 1, and then we
628 take advantage of the 'state hack' on the result of
629 (f y) :: State# -> (State#, Int) to expand the arity one more.
631 There is a disadvantage though. Making the arity visible in the RHS
632 allows us to eta-reduce
636 which technically is not sound. This is very much a corner case, so
637 I'm not worried about it. Another idea is to ensure that f's arity
638 never decreases; its arity started as 1, and we should never eta-reduce
642 Note [Robust OccInfo]
643 ~~~~~~~~~~~~~~~~~~~~~
644 It's important that we *do* retain the loop-breaker OccInfo, because
645 that's what stops the Id getting inlined infinitely, in the body of
649 Note [Rules in a letrec]
650 ~~~~~~~~~~~~~~~~~~~~~~~~
651 After creating fresh binders for the binders of a letrec, we
652 substitute the RULES and add them back onto the binders; this is done
653 *before* processing any of the RHSs. This is important. Manuel found
654 cases where he really, really wanted a RULE for a recursive function
655 to apply in that function's own right-hand side.
657 See Note [Loop breaking and RULES] in OccAnal.
661 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
662 -- Rules are added back in to to the bin
663 addBndrRules env in_id out_id
664 | isEmptySpecInfo old_rules = (env, out_id)
665 | otherwise = (modifyInScope env final_id, final_id)
667 subst = mkCoreSubst env
668 old_rules = idSpecialisation in_id
669 new_rules = CoreSubst.substSpec subst out_id old_rules
670 final_id = out_id `setIdSpecialisation` new_rules
674 %************************************************************************
676 Impedence matching to type substitution
678 %************************************************************************
681 substTy :: SimplEnv -> Type -> Type
682 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
683 = Type.substTy (TvSubst in_scope tv_env) ty
685 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
686 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
687 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
688 (TvSubst in_scope' tv_env', tv')
689 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
691 -- When substituting in rules etc we can get CoreSubst to do the work
692 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
693 -- here. I think the this will not usually result in a lot of work;
694 -- the substitutions are typically small, and laziness will avoid work in many cases.
696 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
697 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
698 = mk_subst tv_env id_env
700 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
702 fiddle (DoneEx e) = e
703 fiddle (DoneId v) = Var v
704 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
707 substIdType :: SimplEnv -> Id -> Id
708 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
709 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
710 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
711 -- The tyVarsOfType is cheaper than it looks
712 -- because we cache the free tyvars of the type
713 -- in a Note in the id's type itself
718 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
719 substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
720 -- Do *not* short-cut in the case of an empty substitution
721 -- See CoreSubst: Note [Extending the Subst]
723 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
724 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf