2 o% (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
9 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
10 InCoercion, OutCoercion,
12 -- The simplifier mode
13 setMode, getMode, updMode,
15 setEnclosingCC, getEnclosingCC,
18 SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
19 mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
20 zapSubstEnv, setSubstEnv,
21 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
24 SimplSR(..), mkContEx, substId, lookupRecBndr,
26 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
27 simplBinder, simplBinders, addBndrRules,
28 substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
31 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
32 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
33 doFloatFromRhs, getFloats
36 #include "HsVersions.h"
39 import CoreMonad ( SimplifierMode(..) )
49 import qualified CoreSubst
50 import qualified Type ( substTy, substTyVarBndr, substTyVar )
51 import Type hiding ( substTy, substTyVarBndr, substTyVar )
61 %************************************************************************
63 \subsection[Simplify-types]{Type declarations}
65 %************************************************************************
68 type InBndr = CoreBndr
69 type InVar = Var -- Not yet cloned
70 type InId = Id -- Not yet cloned
71 type InType = Type -- Ditto
72 type InBind = CoreBind
73 type InExpr = CoreExpr
76 type InCoercion = Coercion
78 type OutBndr = CoreBndr
79 type OutVar = Var -- Cloned
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 ----------- Static part of the environment -----------
101 -- Static in the sense of lexically scoped,
102 -- wrt the original expression
104 seMode :: SimplifierMode,
105 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
107 -- The current substitution
108 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
109 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
111 ----------- Dynamic part of the environment -----------
112 -- Dynamic in the sense of describing the setup where
113 -- the expression finally ends up
115 -- The current set of in-scope variables
116 -- They are all OutVars, and all bound in this module
117 seInScope :: InScopeSet, -- OutVars only
118 -- Includes all variables bound by seFloats
120 -- See Note [Simplifier floats]
123 type StaticEnv = SimplEnv -- Just the static part is relevant
125 pprSimplEnv :: SimplEnv -> SDoc
126 -- Used for debugging; selective
128 = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
129 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
130 ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
133 in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
134 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
137 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
138 -- See Note [Extending the Subst] in CoreSubst
141 = DoneEx OutExpr -- Completed term
142 | DoneId OutId -- Completed term variable
143 | ContEx TvSubstEnv -- A suspended substitution
147 instance Outputable SimplSR where
148 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
149 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
150 ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
151 ppr (filter_env tv), ppr (filter_env id) -}]
153 -- fvs = exprFreeVars e
154 -- filter_env env = filterVarEnv_Directly keep env
155 -- keep uniq _ = uniq `elemUFM_Directly` fvs
158 Note [SimplEnv invariants]
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~
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
195 Note, though that the substitution isn't necessarily extended
196 if the type of the Id changes. Why not? Because of the next point:
198 * We *always, always* finish by looking up in the in-scope set
199 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
200 Reason: so that we never finish up with a "old" Id in the result.
201 An old Id might point to an old unfolding and so on... which gives a space leak.
203 [The DoneEx and DoneVar hits map to "new" stuff.]
205 * It follows that substExpr must not do a no-op if the substitution is empty.
206 substType is free to do so, however.
208 * When we come to a let-binding (say) we generate new IdInfo, including an
209 unfolding, attach it to the binder, and add this newly adorned binder to
210 the in-scope set. So all subsequent occurrences of the binder will get mapped
211 to the full-adorned binder, which is also the one put in the binding site.
213 * The in-scope "set" usually maps x->x; we use it simply for its domain.
214 But sometimes we have two in-scope Ids that are synomyms, and should
215 map to the same target: x->x, y->x. Notably:
217 That's why the "set" is actually a VarEnv Var
221 mkSimplEnv :: SimplifierMode -> SimplEnv
223 = SimplEnv { seCC = subsumedCCS,
224 seMode = mode, seInScope = emptyInScopeSet,
225 seFloats = emptyFloats,
226 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
227 -- The top level "enclosing CC" is "SUBSUMED".
229 ---------------------
230 getMode :: SimplEnv -> SimplifierMode
231 getMode env = seMode env
233 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
234 setMode mode env = env { seMode = mode }
236 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
237 updMode upd env = env { seMode = upd (seMode env) }
239 ---------------------
240 getEnclosingCC :: SimplEnv -> CostCentreStack
241 getEnclosingCC env = seCC env
243 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
244 setEnclosingCC env cc = env {seCC = cc}
246 ---------------------
247 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
248 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
249 = env {seIdSubst = extendVarEnv subst var res}
251 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
252 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
253 = env {seTvSubst = extendVarEnv subst var res}
255 ---------------------
256 getInScope :: SimplEnv -> InScopeSet
257 getInScope env = seInScope env
259 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
260 setInScopeSet env in_scope = env {seInScope = in_scope}
262 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
263 -- Set the in-scope set, and *zap* the floats
264 setInScope env env_with_scope
265 = env { seInScope = seInScope env_with_scope,
266 seFloats = emptyFloats }
268 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
269 -- Set the in-scope set *and* the floats
270 setFloats env env_with_floats
271 = env { seInScope = seInScope env_with_floats,
272 seFloats = seFloats env_with_floats }
274 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
275 -- The new Ids are guaranteed to be freshly allocated
276 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
277 = env { seInScope = in_scope `extendInScopeSetList` vs,
278 seIdSubst = id_subst `delVarEnvList` vs }
279 -- Why delete? Consider
280 -- let x = a*b in (x, \x -> x+3)
281 -- We add [x |-> a*b] to the substitution, but we must
282 -- _delete_ it from the substitution when going inside
285 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
286 -- The variable should already be in scope, but
287 -- replace the existing version with this new one
288 -- which has more information
289 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
290 = env {seInScope = extendInScopeSet in_scope v}
292 ---------------------
293 zapSubstEnv :: SimplEnv -> SimplEnv
294 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
296 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
297 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
299 mkContEx :: SimplEnv -> InExpr -> SimplSR
300 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
305 %************************************************************************
309 %************************************************************************
311 Note [Simplifier floats]
312 ~~~~~~~~~~~~~~~~~~~~~~~~~
313 The Floats is a bunch of bindings, classified by a FloatFlag.
315 NonRec x (y:ys) FltLifted
316 Rec [(x,rhs)] FltLifted
318 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
320 NonRec x# (a /# b) FltCareful
321 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
322 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
323 -- (where f :: Int -> Int#)
326 data Floats = Floats (OrdList OutBind) FloatFlag
327 -- See Note [Simplifier floats]
330 = FltLifted -- All bindings are lifted and lazy
331 -- Hence ok to float to top level, or recursive
333 | FltOkSpec -- All bindings are FltLifted *or*
334 -- strict (perhaps because unlifted,
335 -- perhaps because of a strict binder),
336 -- *and* ok-for-speculation
337 -- Hence ok to float out of the RHS
338 -- of a lazy non-recursive let binding
339 -- (but not to top level, or into a rec group)
341 | FltCareful -- At least one binding is strict (or unlifted)
342 -- and not guaranteed cheap
343 -- Do not float these bindings out of a lazy let
345 instance Outputable Floats where
346 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
348 instance Outputable FloatFlag where
349 ppr FltLifted = ptext (sLit "FltLifted")
350 ppr FltOkSpec = ptext (sLit "FltOkSpec")
351 ppr FltCareful = ptext (sLit "FltCareful")
353 andFF :: FloatFlag -> FloatFlag -> FloatFlag
354 andFF FltCareful _ = FltCareful
355 andFF FltOkSpec FltCareful = FltCareful
356 andFF FltOkSpec _ = FltOkSpec
357 andFF FltLifted flt = flt
359 classifyFF :: CoreBind -> FloatFlag
360 classifyFF (Rec _) = FltLifted
361 classifyFF (NonRec bndr rhs)
362 | not (isStrictId bndr) = FltLifted
363 | exprOkForSpeculation rhs = FltOkSpec
364 | otherwise = FltCareful
366 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
367 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
368 = not (isNilOL fs) && want_to_float && can_float
370 want_to_float = isTopLevel lvl || exprIsExpandable rhs
371 can_float = case ff of
373 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
374 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
379 emptyFloats :: Floats
380 emptyFloats = Floats nilOL FltLifted
382 unitFloat :: OutBind -> Floats
383 -- A single-binding float
384 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
386 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
387 -- Add a non-recursive binding and extend the in-scope set
388 -- The latter is important; the binder may already be in the
389 -- in-scope set (although it might also have been created with newId)
390 -- but it may now have more IdInfo
392 = id `seq` -- This seq forces the Id, and hence its IdInfo,
393 -- and hence any inner substitutions
394 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
395 seInScope = extendInScopeSet (seInScope env) id }
397 extendFloats :: SimplEnv -> OutBind -> SimplEnv
398 -- Add these bindings to the floats, and extend the in-scope env too
399 extendFloats env bind
400 = env { seFloats = seFloats env `addFlts` unitFloat bind,
401 seInScope = extendInScopeSetList (seInScope env) bndrs }
403 bndrs = bindersOf bind
405 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
406 -- Add the floats for env2 to env1;
407 -- *plus* the in-scope set for env2, which is bigger
408 -- than that for env1
410 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
411 seInScope = seInScope env2 }
413 addFlts :: Floats -> Floats -> Floats
414 addFlts (Floats bs1 l1) (Floats bs2 l2)
415 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
417 zapFloats :: SimplEnv -> SimplEnv
418 zapFloats env = env { seFloats = emptyFloats }
420 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
421 -- Flattens the floats from env2 into a single Rec group,
422 -- prepends the floats from env1, and puts the result back in env2
423 -- This is all very specific to the way recursive bindings are
424 -- handled; see Simplify.simplRecBind
425 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
426 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
427 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
429 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
430 wrapFloats env expr = wrapFlts (seFloats env) expr
432 wrapFlts :: Floats -> OutExpr -> OutExpr
433 -- Wrap the floats around the expression, using case-binding where necessary
434 wrapFlts (Floats bs _) body = foldrOL wrap body bs
436 wrap (Rec prs) body = Let (Rec prs) body
437 wrap (NonRec b r) body = bindNonRec b r body
439 getFloats :: SimplEnv -> [CoreBind]
440 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
442 isEmptyFloats :: SimplEnv -> Bool
443 isEmptyFloats env = isEmptyFlts (seFloats env)
445 isEmptyFlts :: Floats -> Bool
446 isEmptyFlts (Floats bs _) = isNilOL bs
448 floatBinds :: Floats -> [OutBind]
449 floatBinds (Floats bs _) = fromOL bs
453 %************************************************************************
457 %************************************************************************
459 Note [Global Ids in the substitution]
460 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
461 We look up even a global (eg imported) Id in the substitution. Consider
462 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
463 The binder-swap in the occurence analyser will add a binding
464 for a LocalId version of g (with the same unique though):
465 case X.g_34 of b { (a,b) -> let g_34 = b in
466 ... case X.g_34 of { (p,q) -> ...} ... }
467 So we want to look up the inner X.g_34 in the substitution, where we'll
468 find that it has been substituted by b. (Or conceivably cloned.)
471 substId :: SimplEnv -> InId -> SimplSR
472 -- Returns DoneEx only on a non-Var expression
473 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
474 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
475 Nothing -> DoneId (refine in_scope v)
476 Just (DoneId v) -> DoneId (refine in_scope v)
477 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
478 Just res -> res -- DoneEx non-var, or ContEx
481 -- Get the most up-to-date thing from the in-scope set
482 -- Even though it isn't in the substitution, it may be in
483 -- the in-scope set with better IdInfo
484 refine :: InScopeSet -> Var -> Var
486 | isLocalId v = case lookupInScope in_scope v of
488 Nothing -> WARN( True, ppr v ) v -- This is an error!
491 lookupRecBndr :: SimplEnv -> InId -> OutId
492 -- Look up an Id which has been put into the envt by simplRecBndrs,
493 -- but where we have not yet done its RHS
494 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
495 = case lookupVarEnv ids v of
497 Just _ -> pprPanic "lookupRecBndr" (ppr v)
498 Nothing -> refine in_scope v
502 %************************************************************************
504 \section{Substituting an Id binder}
506 %************************************************************************
509 These functions are in the monad only so that they can be made strict via seq.
512 simplBinders, simplLamBndrs
513 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
514 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
515 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
518 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
519 -- Used for lambda and case-bound variables
520 -- Clone Id if necessary, substitute type
521 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
522 -- The substitution is extended only if the variable is cloned, because
523 -- we *don't* need to use it to track occurrence info.
525 | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
526 ; seqTyVar tv `seq` return (env', tv) }
527 | otherwise = do { let (env', id) = substIdBndr env bndr
528 ; seqId id `seq` return (env', id) }
531 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
532 -- Used for lambda binders. These sometimes have unfoldings added by
533 -- the worker/wrapper pass that must be preserved, because they can't
534 -- be reconstructed from context. For example:
535 -- f x = case x of (a,b) -> fw a b x
536 -- fw a b x{=(a,b)} = ...
537 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
538 simplLamBndr env bndr
539 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
540 | otherwise = simplBinder env bndr -- Normal case
542 old_unf = idUnfolding bndr
543 (env1, id1) = substIdBndr env bndr
544 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
545 env2 = modifyInScope env1 id2
548 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
549 -- A non-recursive let binder
550 simplNonRecBndr env id
551 = do { let (env1, id1) = substIdBndr env id
552 ; seqId id1 `seq` return (env1, id1) }
555 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
556 -- Recursive let binders
557 simplRecBndrs env@(SimplEnv {}) ids
558 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
559 ; seqIds ids1 `seq` return env1 }
562 substIdBndr :: SimplEnv
563 -> InBndr -- Env and binder to transform
564 -> (SimplEnv, OutBndr)
565 -- Clone Id if necessary, substitute its type
566 -- Return an Id with its
567 -- * Type substituted
568 -- * UnfoldingInfo, Rules, WorkerInfo zapped
569 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
570 -- * Robust info, retained especially arity and demand info,
571 -- so that they are available to occurrences that occur in an
572 -- earlier binding of a letrec
574 -- For the robust info, see Note [Arity robustness]
576 -- Augment the substitution if the unique changed
577 -- Extend the in-scope set with the new Id
579 -- Similar to CoreSubst.substIdBndr, except that
580 -- the type of id_subst differs
581 -- all fragile info is zapped
583 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
585 = (env { seInScope = in_scope `extendInScopeSet` new_id,
586 seIdSubst = new_subst }, new_id)
588 id1 = uniqAway in_scope old_id
589 id2 = substIdType env id1
590 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
591 -- and fragile OccInfo
593 -- Extend the substitution if the unique has changed,
594 -- or there's some useful occurrence information
595 -- See the notes with substTyVarBndr for the delSubstEnv
596 new_subst | new_id /= old_id
597 = extendVarEnv id_subst old_id (DoneId new_id)
599 = delVarEnv id_subst old_id
603 ------------------------------------
604 seqTyVar :: TyVar -> ()
605 seqTyVar b = b `seq` ()
608 seqId id = seqType (idType id) `seq`
614 seqIds (id:ids) = seqId id `seq` seqIds ids
618 Note [Arity robustness]
619 ~~~~~~~~~~~~~~~~~~~~~~~
620 We *do* transfer the arity from from the in_id of a let binding to the
621 out_id. This is important, so that the arity of an Id is visible in
622 its own RHS. For example:
623 f = \x. ....g (\y. f y)....
624 We can eta-reduce the arg to g, becuase f is a value. But that
627 This interacts with the 'state hack' too:
632 Can we eta-expand f? Only if we see that f has arity 1, and then we
633 take advantage of the 'state hack' on the result of
634 (f y) :: State# -> (State#, Int) to expand the arity one more.
636 There is a disadvantage though. Making the arity visible in the RHS
637 allows us to eta-reduce
641 which technically is not sound. This is very much a corner case, so
642 I'm not worried about it. Another idea is to ensure that f's arity
643 never decreases; its arity started as 1, and we should never eta-reduce
647 Note [Robust OccInfo]
648 ~~~~~~~~~~~~~~~~~~~~~
649 It's important that we *do* retain the loop-breaker OccInfo, because
650 that's what stops the Id getting inlined infinitely, in the body of
654 Note [Rules in a letrec]
655 ~~~~~~~~~~~~~~~~~~~~~~~~
656 After creating fresh binders for the binders of a letrec, we
657 substitute the RULES and add them back onto the binders; this is done
658 *before* processing any of the RHSs. This is important. Manuel found
659 cases where he really, really wanted a RULE for a recursive function
660 to apply in that function's own right-hand side.
662 See Note [Loop breaking and RULES] in OccAnal.
666 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
667 -- Rules are added back in to to the bin
668 addBndrRules env in_id out_id
669 | isEmptySpecInfo old_rules = (env, out_id)
670 | otherwise = (modifyInScope env final_id, final_id)
672 subst = mkCoreSubst (text "local rules") env
673 old_rules = idSpecialisation in_id
674 new_rules = CoreSubst.substSpec subst out_id old_rules
675 final_id = out_id `setIdSpecialisation` new_rules
679 %************************************************************************
681 Impedence matching to type substitution
683 %************************************************************************
686 getTvSubst :: SimplEnv -> TvSubst
687 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
688 = mkTvSubst in_scope tv_env
690 substTy :: SimplEnv -> Type -> Type
691 substTy env ty = Type.substTy (getTvSubst env) ty
693 substTyVar :: SimplEnv -> TyVar -> Type
694 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
696 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
697 substTyVarBndr env tv
698 = case Type.substTyVarBndr (getTvSubst env) tv of
699 (TvSubst in_scope' tv_env', tv')
700 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
702 -- When substituting in rules etc we can get CoreSubst to do the work
703 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
704 -- here. I think the this will not usually result in a lot of work;
705 -- the substitutions are typically small, and laziness will avoid work in many cases.
707 mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
708 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
709 = mk_subst tv_env id_env
711 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
713 fiddle (DoneEx e) = e
714 fiddle (DoneId v) = Var v
715 fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
716 -- Don't shortcut here
719 substIdType :: SimplEnv -> Id -> Id
720 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
721 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
722 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
723 -- The tyVarsOfType is cheaper than it looks
724 -- because we cache the free tyvars of the type
725 -- in a Note in the id's type itself
730 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
732 = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
733 (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
734 -- Do *not* short-cut in the case of an empty substitution
735 -- See Note [SimplEnv invariants]
737 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
738 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
739 -- Do *not* short-cut in the case of an empty substitution
740 -- See Note [SimplEnv invariants]