2 % (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,
16 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
17 isAmongSimpl, intSwitchSet, switchIsOn,
19 setEnclosingCC, getEnclosingCC,
22 SimplEnv(..), StaticEnv, 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, substTyVar, getTvSubst, mkCoreSubst,
35 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
36 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
37 doFloatFromRhs, getFloats
40 #include "HsVersions.h"
43 import CoreMonad ( SimplifierMode(..) )
53 import qualified CoreSubst
54 import qualified Type ( substTy, substTyVarBndr, substTyVar )
55 import Type hiding ( substTy, substTyVarBndr, substTyVar )
65 %************************************************************************
67 \subsection[Simplify-types]{Type declarations}
69 %************************************************************************
72 type InBndr = CoreBndr
73 type InVar = Var -- Not yet cloned
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 OutVar = Var -- Cloned
84 type OutId = Id -- Cloned
85 type OutTyVar = TyVar -- Cloned
86 type OutType = Type -- Cloned
87 type OutCoercion = Coercion
88 type OutBind = CoreBind
89 type OutExpr = CoreExpr
94 %************************************************************************
96 \subsubsection{The @SimplEnv@ type}
98 %************************************************************************
104 ----------- Static part of the environment -----------
105 -- Static in the sense of lexically scoped,
106 -- wrt the original expression
108 seMode :: SimplifierMode,
109 seChkr :: SwitchChecker,
110 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
112 -- The current substitution
113 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
114 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
116 ----------- Dynamic part of the environment -----------
117 -- Dynamic in the sense of describing the setup where
118 -- the expression finally ends up
120 -- The current set of in-scope variables
121 -- They are all OutVars, and all bound in this module
122 seInScope :: InScopeSet, -- OutVars only
123 -- Includes all variables bound by seFloats
125 -- See Note [Simplifier floats]
128 type StaticEnv = SimplEnv -- Just the static part is relevant
130 pprSimplEnv :: SimplEnv -> SDoc
131 -- Used for debugging; selective
133 = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
134 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
135 ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
138 in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
139 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
142 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
143 -- See Note [Extending the Subst] in CoreSubst
146 = DoneEx OutExpr -- Completed term
147 | DoneId OutId -- Completed term variable
148 | ContEx TvSubstEnv -- A suspended substitution
152 instance Outputable SimplSR where
153 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
154 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
155 ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
156 ppr (filter_env tv), ppr (filter_env id) -}]
158 -- fvs = exprFreeVars e
159 -- filter_env env = filterVarEnv_Directly keep env
160 -- keep uniq _ = uniq `elemUFM_Directly` fvs
163 Note [SimplEnv invariants]
164 ~~~~~~~~~~~~~~~~~~~~~~~~~~
166 The in-scope part of Subst includes *all* in-scope TyVars and Ids
167 The elements of the set may have better IdInfo than the
168 occurrences of in-scope Ids, and (more important) they will
169 have a correctly-substituted type. So we use a lookup in this
170 set to replace occurrences
172 The Ids in the InScopeSet are replete with their Rules,
173 and as we gather info about the unfolding of an Id, we replace
174 it in the in-scope set.
176 The in-scope set is actually a mapping OutVar -> OutVar, and
177 in case expressions we sometimes bind
180 The substitution is *apply-once* only, because InIds and OutIds can overlap.
181 For example, we generally omit mappings
183 from the substitution, when we decide not to clone a77, but it's quite
184 legitimate to put the mapping in the substitution anyway.
186 Furthermore, consider
187 let x = case k of I# x77 -> ... in
188 let y = case k of I# x77 -> ... in ...
189 and suppose the body is strict in both x and y. Then the simplifier
190 will pull the first (case k) to the top; so the second (case k) will
191 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
194 Of course, the substitution *must* applied! Things in its domain
195 simply aren't necessarily bound in the result.
197 * substId adds a binding (DoneId new_id) to the substitution if
198 the Id's unique has changed
200 Note, though that the substitution isn't necessarily extended
201 if the type of the Id changes. Why not? Because of the next point:
203 * We *always, always* finish by looking up in the in-scope set
204 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
205 Reason: so that we never finish up with a "old" Id in the result.
206 An old Id might point to an old unfolding and so on... which gives a space leak.
208 [The DoneEx and DoneVar hits map to "new" stuff.]
210 * It follows that substExpr must not do a no-op if the substitution is empty.
211 substType is free to do so, however.
213 * When we come to a let-binding (say) we generate new IdInfo, including an
214 unfolding, attach it to the binder, and add this newly adorned binder to
215 the in-scope set. So all subsequent occurrences of the binder will get mapped
216 to the full-adorned binder, which is also the one put in the binding site.
218 * The in-scope "set" usually maps x->x; we use it simply for its domain.
219 But sometimes we have two in-scope Ids that are synomyms, and should
220 map to the same target: x->x, y->x. Notably:
222 That's why the "set" is actually a VarEnv Var
226 mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
227 mkSimplEnv switches mode
228 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
229 seMode = mode, seInScope = emptyInScopeSet,
230 seFloats = emptyFloats,
231 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
232 -- The top level "enclosing CC" is "SUBSUMED".
234 ---------------------
235 getSwitchChecker :: SimplEnv -> SwitchChecker
236 getSwitchChecker env = seChkr env
238 ---------------------
239 getMode :: SimplEnv -> SimplifierMode
240 getMode env = seMode env
242 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
243 setMode mode env = env { seMode = mode }
245 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
246 updMode upd env = env { seMode = upd (seMode env) }
248 inGentleMode :: SimplEnv -> Bool
249 inGentleMode env = case seMode env of
250 SimplGently {} -> True
253 ---------------------
254 getEnclosingCC :: SimplEnv -> CostCentreStack
255 getEnclosingCC env = seCC env
257 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
258 setEnclosingCC env cc = env {seCC = cc}
260 ---------------------
261 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
262 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
263 = env {seIdSubst = extendVarEnv subst var res}
265 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
266 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
267 = env {seTvSubst = extendVarEnv subst var res}
269 ---------------------
270 getInScope :: SimplEnv -> InScopeSet
271 getInScope env = seInScope env
273 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
274 setInScopeSet env in_scope = env {seInScope = in_scope}
276 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
277 -- Set the in-scope set, and *zap* the floats
278 setInScope env env_with_scope
279 = env { seInScope = seInScope env_with_scope,
280 seFloats = emptyFloats }
282 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
283 -- Set the in-scope set *and* the floats
284 setFloats env env_with_floats
285 = env { seInScope = seInScope env_with_floats,
286 seFloats = seFloats env_with_floats }
288 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
289 -- The new Ids are guaranteed to be freshly allocated
290 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
291 = env { seInScope = in_scope `extendInScopeSetList` vs,
292 seIdSubst = id_subst `delVarEnvList` vs }
293 -- Why delete? Consider
294 -- let x = a*b in (x, \x -> x+3)
295 -- We add [x |-> a*b] to the substitution, but we must
296 -- _delete_ it from the substitution when going inside
299 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
300 -- The variable should already be in scope, but
301 -- replace the existing version with this new one
302 -- which has more information
303 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
304 = env {seInScope = extendInScopeSet in_scope v}
306 ---------------------
307 zapSubstEnv :: SimplEnv -> SimplEnv
308 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
310 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
311 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
313 mkContEx :: SimplEnv -> InExpr -> SimplSR
314 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
319 %************************************************************************
323 %************************************************************************
325 Note [Simplifier floats]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~
327 The Floats is a bunch of bindings, classified by a FloatFlag.
329 NonRec x (y:ys) FltLifted
330 Rec [(x,rhs)] FltLifted
332 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
334 NonRec x# (a /# b) FltCareful
335 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
336 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
337 -- (where f :: Int -> Int#)
340 data Floats = Floats (OrdList OutBind) FloatFlag
341 -- See Note [Simplifier floats]
344 = FltLifted -- All bindings are lifted and lazy
345 -- Hence ok to float to top level, or recursive
347 | FltOkSpec -- All bindings are FltLifted *or*
348 -- strict (perhaps because unlifted,
349 -- perhaps because of a strict binder),
350 -- *and* ok-for-speculation
351 -- Hence ok to float out of the RHS
352 -- of a lazy non-recursive let binding
353 -- (but not to top level, or into a rec group)
355 | FltCareful -- At least one binding is strict (or unlifted)
356 -- and not guaranteed cheap
357 -- Do not float these bindings out of a lazy let
359 instance Outputable Floats where
360 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
362 instance Outputable FloatFlag where
363 ppr FltLifted = ptext (sLit "FltLifted")
364 ppr FltOkSpec = ptext (sLit "FltOkSpec")
365 ppr FltCareful = ptext (sLit "FltCareful")
367 andFF :: FloatFlag -> FloatFlag -> FloatFlag
368 andFF FltCareful _ = FltCareful
369 andFF FltOkSpec FltCareful = FltCareful
370 andFF FltOkSpec _ = FltOkSpec
371 andFF FltLifted flt = flt
373 classifyFF :: CoreBind -> FloatFlag
374 classifyFF (Rec _) = FltLifted
375 classifyFF (NonRec bndr rhs)
376 | not (isStrictId bndr) = FltLifted
377 | exprOkForSpeculation rhs = FltOkSpec
378 | otherwise = FltCareful
380 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
381 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
382 = not (isNilOL fs) && want_to_float && can_float
384 want_to_float = isTopLevel lvl || exprIsExpandable rhs
385 can_float = case ff of
387 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
388 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
393 emptyFloats :: Floats
394 emptyFloats = Floats nilOL FltLifted
396 unitFloat :: OutBind -> Floats
397 -- A single-binding float
398 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
400 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
401 -- Add a non-recursive binding and extend the in-scope set
402 -- The latter is important; the binder may already be in the
403 -- in-scope set (although it might also have been created with newId)
404 -- but it may now have more IdInfo
406 = id `seq` -- This seq forces the Id, and hence its IdInfo,
407 -- and hence any inner substitutions
408 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
409 seInScope = extendInScopeSet (seInScope env) id }
411 extendFloats :: SimplEnv -> OutBind -> SimplEnv
412 -- Add these bindings to the floats, and extend the in-scope env too
413 extendFloats env bind
414 = env { seFloats = seFloats env `addFlts` unitFloat bind,
415 seInScope = extendInScopeSetList (seInScope env) bndrs }
417 bndrs = bindersOf bind
419 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
420 -- Add the floats for env2 to env1;
421 -- *plus* the in-scope set for env2, which is bigger
422 -- than that for env1
424 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
425 seInScope = seInScope env2 }
427 addFlts :: Floats -> Floats -> Floats
428 addFlts (Floats bs1 l1) (Floats bs2 l2)
429 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
431 zapFloats :: SimplEnv -> SimplEnv
432 zapFloats env = env { seFloats = emptyFloats }
434 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
435 -- Flattens the floats from env2 into a single Rec group,
436 -- prepends the floats from env1, and puts the result back in env2
437 -- This is all very specific to the way recursive bindings are
438 -- handled; see Simplify.simplRecBind
439 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
440 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
441 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
443 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
444 wrapFloats env expr = wrapFlts (seFloats env) expr
446 wrapFlts :: Floats -> OutExpr -> OutExpr
447 -- Wrap the floats around the expression, using case-binding where necessary
448 wrapFlts (Floats bs _) body = foldrOL wrap body bs
450 wrap (Rec prs) body = Let (Rec prs) body
451 wrap (NonRec b r) body = bindNonRec b r body
453 getFloats :: SimplEnv -> [CoreBind]
454 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
456 isEmptyFloats :: SimplEnv -> Bool
457 isEmptyFloats env = isEmptyFlts (seFloats env)
459 isEmptyFlts :: Floats -> Bool
460 isEmptyFlts (Floats bs _) = isNilOL bs
462 floatBinds :: Floats -> [OutBind]
463 floatBinds (Floats bs _) = fromOL bs
467 %************************************************************************
471 %************************************************************************
473 Note [Global Ids in the substitution]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 We look up even a global (eg imported) Id in the substitution. Consider
476 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
477 The binder-swap in the occurence analyser will add a binding
478 for a LocalId version of g (with the same unique though):
479 case X.g_34 of b { (a,b) -> let g_34 = b in
480 ... case X.g_34 of { (p,q) -> ...} ... }
481 So we want to look up the inner X.g_34 in the substitution, where we'll
482 find that it has been substituted by b. (Or conceivably cloned.)
485 substId :: SimplEnv -> InId -> SimplSR
486 -- Returns DoneEx only on a non-Var expression
487 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
488 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
489 Nothing -> DoneId (refine in_scope v)
490 Just (DoneId v) -> DoneId (refine in_scope v)
491 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
492 Just res -> res -- DoneEx non-var, or ContEx
495 -- Get the most up-to-date thing from the in-scope set
496 -- Even though it isn't in the substitution, it may be in
497 -- the in-scope set with better IdInfo
498 refine :: InScopeSet -> Var -> Var
500 | isLocalId v = case lookupInScope in_scope v of
502 Nothing -> WARN( True, ppr v ) v -- This is an error!
505 lookupRecBndr :: SimplEnv -> InId -> OutId
506 -- Look up an Id which has been put into the envt by simplRecBndrs,
507 -- but where we have not yet done its RHS
508 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
509 = case lookupVarEnv ids v of
511 Just _ -> pprPanic "lookupRecBndr" (ppr v)
512 Nothing -> refine in_scope v
516 %************************************************************************
518 \section{Substituting an Id binder}
520 %************************************************************************
523 These functions are in the monad only so that they can be made strict via seq.
526 simplBinders, simplLamBndrs
527 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
528 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
529 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
532 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
533 -- Used for lambda and case-bound variables
534 -- Clone Id if necessary, substitute type
535 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
536 -- The substitution is extended only if the variable is cloned, because
537 -- we *don't* need to use it to track occurrence info.
539 | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
540 ; seqTyVar tv `seq` return (env', tv) }
541 | otherwise = do { let (env', id) = substIdBndr env bndr
542 ; seqId id `seq` return (env', id) }
545 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
546 -- Used for lambda binders. These sometimes have unfoldings added by
547 -- the worker/wrapper pass that must be preserved, because they can't
548 -- be reconstructed from context. For example:
549 -- f x = case x of (a,b) -> fw a b x
550 -- fw a b x{=(a,b)} = ...
551 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
552 simplLamBndr env bndr
553 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
554 | otherwise = simplBinder env bndr -- Normal case
556 old_unf = idUnfolding bndr
557 (env1, id1) = substIdBndr env bndr
558 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
559 env2 = modifyInScope env1 id2
562 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
563 -- A non-recursive let binder
564 simplNonRecBndr env id
565 = do { let (env1, id1) = substIdBndr env id
566 ; seqId id1 `seq` return (env1, id1) }
569 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
570 -- Recursive let binders
571 simplRecBndrs env@(SimplEnv {}) ids
572 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
573 ; seqIds ids1 `seq` return env1 }
576 substIdBndr :: SimplEnv
577 -> InBndr -- Env and binder to transform
578 -> (SimplEnv, OutBndr)
579 -- Clone Id if necessary, substitute its type
580 -- Return an Id with its
581 -- * Type substituted
582 -- * UnfoldingInfo, Rules, WorkerInfo zapped
583 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
584 -- * Robust info, retained especially arity and demand info,
585 -- so that they are available to occurrences that occur in an
586 -- earlier binding of a letrec
588 -- For the robust info, see Note [Arity robustness]
590 -- Augment the substitution if the unique changed
591 -- Extend the in-scope set with the new Id
593 -- Similar to CoreSubst.substIdBndr, except that
594 -- the type of id_subst differs
595 -- all fragile info is zapped
597 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
599 = (env { seInScope = in_scope `extendInScopeSet` new_id,
600 seIdSubst = new_subst }, new_id)
602 id1 = uniqAway in_scope old_id
603 id2 = substIdType env id1
604 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
605 -- and fragile OccInfo
607 -- Extend the substitution if the unique has changed,
608 -- or there's some useful occurrence information
609 -- See the notes with substTyVarBndr for the delSubstEnv
610 new_subst | new_id /= old_id
611 = extendVarEnv id_subst old_id (DoneId new_id)
613 = delVarEnv id_subst old_id
617 ------------------------------------
618 seqTyVar :: TyVar -> ()
619 seqTyVar b = b `seq` ()
622 seqId id = seqType (idType id) `seq`
628 seqIds (id:ids) = seqId id `seq` seqIds ids
632 Note [Arity robustness]
633 ~~~~~~~~~~~~~~~~~~~~~~~
634 We *do* transfer the arity from from the in_id of a let binding to the
635 out_id. This is important, so that the arity of an Id is visible in
636 its own RHS. For example:
637 f = \x. ....g (\y. f y)....
638 We can eta-reduce the arg to g, becuase f is a value. But that
641 This interacts with the 'state hack' too:
646 Can we eta-expand f? Only if we see that f has arity 1, and then we
647 take advantage of the 'state hack' on the result of
648 (f y) :: State# -> (State#, Int) to expand the arity one more.
650 There is a disadvantage though. Making the arity visible in the RHS
651 allows us to eta-reduce
655 which technically is not sound. This is very much a corner case, so
656 I'm not worried about it. Another idea is to ensure that f's arity
657 never decreases; its arity started as 1, and we should never eta-reduce
661 Note [Robust OccInfo]
662 ~~~~~~~~~~~~~~~~~~~~~
663 It's important that we *do* retain the loop-breaker OccInfo, because
664 that's what stops the Id getting inlined infinitely, in the body of
668 Note [Rules in a letrec]
669 ~~~~~~~~~~~~~~~~~~~~~~~~
670 After creating fresh binders for the binders of a letrec, we
671 substitute the RULES and add them back onto the binders; this is done
672 *before* processing any of the RHSs. This is important. Manuel found
673 cases where he really, really wanted a RULE for a recursive function
674 to apply in that function's own right-hand side.
676 See Note [Loop breaking and RULES] in OccAnal.
680 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
681 -- Rules are added back in to to the bin
682 addBndrRules env in_id out_id
683 | isEmptySpecInfo old_rules = (env, out_id)
684 | otherwise = (modifyInScope env final_id, final_id)
686 subst = mkCoreSubst (text "local rules") env
687 old_rules = idSpecialisation in_id
688 new_rules = CoreSubst.substSpec subst out_id old_rules
689 final_id = out_id `setIdSpecialisation` new_rules
693 %************************************************************************
695 Impedence matching to type substitution
697 %************************************************************************
700 getTvSubst :: SimplEnv -> TvSubst
701 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
702 = mkTvSubst in_scope tv_env
704 substTy :: SimplEnv -> Type -> Type
705 substTy env ty = Type.substTy (getTvSubst env) ty
707 substTyVar :: SimplEnv -> TyVar -> Type
708 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
710 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
711 substTyVarBndr env tv
712 = case Type.substTyVarBndr (getTvSubst env) tv of
713 (TvSubst in_scope' tv_env', tv')
714 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
716 -- When substituting in rules etc we can get CoreSubst to do the work
717 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
718 -- here. I think the this will not usually result in a lot of work;
719 -- the substitutions are typically small, and laziness will avoid work in many cases.
721 mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
722 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
723 = mk_subst tv_env id_env
725 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
727 fiddle (DoneEx e) = e
728 fiddle (DoneId v) = Var v
729 fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
730 -- Don't shortcut here
733 substIdType :: SimplEnv -> Id -> Id
734 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
735 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
736 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
737 -- The tyVarsOfType is cheaper than it looks
738 -- because we cache the free tyvars of the type
739 -- in a Note in the id's type itself
744 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
746 = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
747 (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
748 -- Do *not* short-cut in the case of an empty substitution
749 -- See Note [SimplEnv invariants]
751 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
752 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
753 -- Do *not* short-cut in the case of an empty substitution
754 -- See Note [SimplEnv invariants]