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) ]
136 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
137 -- See Note [Extending the Subst] in CoreSubst
140 = DoneEx OutExpr -- Completed term
141 | DoneId OutId -- Completed term variable
142 | ContEx TvSubstEnv -- A suspended substitution
146 instance Outputable SimplSR where
147 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
148 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
149 ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
150 ppr (filter_env tv), ppr (filter_env id) -}]
152 -- fvs = exprFreeVars e
153 -- filter_env env = filterVarEnv_Directly keep env
154 -- keep uniq _ = uniq `elemUFM_Directly` fvs
159 The in-scope part of Subst includes *all* in-scope TyVars and Ids
160 The elements of the set may have better IdInfo than the
161 occurrences of in-scope Ids, and (more important) they will
162 have a correctly-substituted type. So we use a lookup in this
163 set to replace occurrences
165 The Ids in the InScopeSet are replete with their Rules,
166 and as we gather info about the unfolding of an Id, we replace
167 it in the in-scope set.
169 The in-scope set is actually a mapping OutVar -> OutVar, and
170 in case expressions we sometimes bind
173 The substitution is *apply-once* only, because InIds and OutIds can overlap.
174 For example, we generally omit mappings
176 from the substitution, when we decide not to clone a77, but it's quite
177 legitimate to put the mapping in the substitution anyway.
179 Furthermore, consider
180 let x = case k of I# x77 -> ... in
181 let y = case k of I# x77 -> ... in ...
182 and suppose the body is strict in both x and y. Then the simplifier
183 will pull the first (case k) to the top; so the second (case k) will
184 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
187 Of course, the substitution *must* applied! Things in its domain
188 simply aren't necessarily bound in the result.
190 * substId adds a binding (DoneId new_id) to the substitution if
191 the Id's unique has changed
194 Note, though that the substitution isn't necessarily extended
195 if the type changes. Why not? Because of the next point:
197 * We *always, always* finish by looking up in the in-scope set
198 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
199 Reason: so that we never finish up with a "old" Id in the result.
200 An old Id might point to an old unfolding and so on... which gives a space leak.
202 [The DoneEx and DoneVar hits map to "new" stuff.]
204 * It follows that substExpr must not do a no-op if the substitution is empty.
205 substType is free to do so, however.
207 * When we come to a let-binding (say) we generate new IdInfo, including an
208 unfolding, attach it to the binder, and add this newly adorned binder to
209 the in-scope set. So all subsequent occurrences of the binder will get mapped
210 to the full-adorned binder, which is also the one put in the binding site.
212 * The in-scope "set" usually maps x->x; we use it simply for its domain.
213 But sometimes we have two in-scope Ids that are synomyms, and should
214 map to the same target: x->x, y->x. Notably:
216 That's why the "set" is actually a VarEnv Var
220 mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
221 mkSimplEnv switches mode
222 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
223 seMode = mode, seInScope = emptyInScopeSet,
224 seFloats = emptyFloats,
225 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
226 -- The top level "enclosing CC" is "SUBSUMED".
228 ---------------------
229 getSwitchChecker :: SimplEnv -> SwitchChecker
230 getSwitchChecker env = seChkr env
232 ---------------------
233 getMode :: SimplEnv -> SimplifierMode
234 getMode env = seMode env
236 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
237 setMode mode env = env { seMode = mode }
239 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
240 updMode upd env = env { seMode = upd (seMode env) }
242 inGentleMode :: SimplEnv -> Bool
243 inGentleMode env = case seMode env of
244 SimplGently {} -> True
247 ---------------------
248 getEnclosingCC :: SimplEnv -> CostCentreStack
249 getEnclosingCC env = seCC env
251 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
252 setEnclosingCC env cc = env {seCC = cc}
254 ---------------------
255 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
256 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
257 = env {seIdSubst = extendVarEnv subst var res}
259 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
260 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
261 = env {seTvSubst = extendVarEnv subst var res}
263 ---------------------
264 getInScope :: SimplEnv -> InScopeSet
265 getInScope env = seInScope env
267 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
268 setInScopeSet env in_scope = env {seInScope = in_scope}
270 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
271 -- Set the in-scope set, and *zap* the floats
272 setInScope env env_with_scope
273 = env { seInScope = seInScope env_with_scope,
274 seFloats = emptyFloats }
276 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
277 -- Set the in-scope set *and* the floats
278 setFloats env env_with_floats
279 = env { seInScope = seInScope env_with_floats,
280 seFloats = seFloats env_with_floats }
282 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
283 -- The new Ids are guaranteed to be freshly allocated
284 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
285 = env { seInScope = in_scope `extendInScopeSetList` vs,
286 seIdSubst = id_subst `delVarEnvList` vs }
287 -- Why delete? Consider
288 -- let x = a*b in (x, \x -> x+3)
289 -- We add [x |-> a*b] to the substitution, but we must
290 -- _delete_ it from the substitution when going inside
293 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
294 -- The variable should already be in scope, but
295 -- replace the existing version with this new one
296 -- which has more information
297 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
298 = env {seInScope = extendInScopeSet in_scope v}
300 ---------------------
301 zapSubstEnv :: SimplEnv -> SimplEnv
302 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
304 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
305 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
307 mkContEx :: SimplEnv -> InExpr -> SimplSR
308 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
313 %************************************************************************
317 %************************************************************************
319 Note [Simplifier floats]
320 ~~~~~~~~~~~~~~~~~~~~~~~~~
321 The Floats is a bunch of bindings, classified by a FloatFlag.
323 NonRec x (y:ys) FltLifted
324 Rec [(x,rhs)] FltLifted
326 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
328 NonRec x# (a /# b) FltCareful
329 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
330 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
331 -- (where f :: Int -> Int#)
334 data Floats = Floats (OrdList OutBind) FloatFlag
335 -- See Note [Simplifier floats]
338 = FltLifted -- All bindings are lifted and lazy
339 -- Hence ok to float to top level, or recursive
341 | FltOkSpec -- All bindings are FltLifted *or*
342 -- strict (perhaps because unlifted,
343 -- perhaps because of a strict binder),
344 -- *and* ok-for-speculation
345 -- Hence ok to float out of the RHS
346 -- of a lazy non-recursive let binding
347 -- (but not to top level, or into a rec group)
349 | FltCareful -- At least one binding is strict (or unlifted)
350 -- and not guaranteed cheap
351 -- Do not float these bindings out of a lazy let
353 instance Outputable Floats where
354 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
356 instance Outputable FloatFlag where
357 ppr FltLifted = ptext (sLit "FltLifted")
358 ppr FltOkSpec = ptext (sLit "FltOkSpec")
359 ppr FltCareful = ptext (sLit "FltCareful")
361 andFF :: FloatFlag -> FloatFlag -> FloatFlag
362 andFF FltCareful _ = FltCareful
363 andFF FltOkSpec FltCareful = FltCareful
364 andFF FltOkSpec _ = FltOkSpec
365 andFF FltLifted flt = flt
367 classifyFF :: CoreBind -> FloatFlag
368 classifyFF (Rec _) = FltLifted
369 classifyFF (NonRec bndr rhs)
370 | not (isStrictId bndr) = FltLifted
371 | exprOkForSpeculation rhs = FltOkSpec
372 | otherwise = FltCareful
374 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
375 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
376 = not (isNilOL fs) && want_to_float && can_float
378 want_to_float = isTopLevel lvl || exprIsExpandable rhs
379 can_float = case ff of
381 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
382 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
387 emptyFloats :: Floats
388 emptyFloats = Floats nilOL FltLifted
390 unitFloat :: OutBind -> Floats
391 -- A single-binding float
392 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
394 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
395 -- Add a non-recursive binding and extend the in-scope set
396 -- The latter is important; the binder may already be in the
397 -- in-scope set (although it might also have been created with newId)
398 -- but it may now have more IdInfo
400 = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
401 seInScope = extendInScopeSet (seInScope env) id }
403 extendFloats :: SimplEnv -> OutBind -> SimplEnv
404 -- Add these bindings to the floats, and extend the in-scope env too
405 extendFloats env bind
406 = env { seFloats = seFloats env `addFlts` unitFloat bind,
407 seInScope = extendInScopeSetList (seInScope env) bndrs }
409 bndrs = bindersOf bind
411 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
412 -- Add the floats for env2 to env1;
413 -- *plus* the in-scope set for env2, which is bigger
414 -- than that for env1
416 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
417 seInScope = seInScope env2 }
419 addFlts :: Floats -> Floats -> Floats
420 addFlts (Floats bs1 l1) (Floats bs2 l2)
421 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
423 zapFloats :: SimplEnv -> SimplEnv
424 zapFloats env = env { seFloats = emptyFloats }
426 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
427 -- Flattens the floats from env2 into a single Rec group,
428 -- prepends the floats from env1, and puts the result back in env2
429 -- This is all very specific to the way recursive bindings are
430 -- handled; see Simplify.simplRecBind
431 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
432 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
433 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
435 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
436 wrapFloats env expr = wrapFlts (seFloats env) expr
438 wrapFlts :: Floats -> OutExpr -> OutExpr
439 -- Wrap the floats around the expression, using case-binding where necessary
440 wrapFlts (Floats bs _) body = foldrOL wrap body bs
442 wrap (Rec prs) body = Let (Rec prs) body
443 wrap (NonRec b r) body = bindNonRec b r body
445 getFloats :: SimplEnv -> [CoreBind]
446 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
448 isEmptyFloats :: SimplEnv -> Bool
449 isEmptyFloats env = isEmptyFlts (seFloats env)
451 isEmptyFlts :: Floats -> Bool
452 isEmptyFlts (Floats bs _) = isNilOL bs
454 floatBinds :: Floats -> [OutBind]
455 floatBinds (Floats bs _) = fromOL bs
459 %************************************************************************
463 %************************************************************************
465 Note [Global Ids in the substitution]
466 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
467 We look up even a global (eg imported) Id in the substitution. Consider
468 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
469 The binder-swap in the occurence analyser will add a binding
470 for a LocalId version of g (with the same unique though):
471 case X.g_34 of b { (a,b) -> let g_34 = b in
472 ... case X.g_34 of { (p,q) -> ...} ... }
473 So we want to look up the inner X.g_34 in the substitution, where we'll
474 find that it has been substituted by b. (Or conceivably cloned.)
477 substId :: SimplEnv -> InId -> SimplSR
478 -- Returns DoneEx only on a non-Var expression
479 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
480 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
481 Nothing -> DoneId (refine in_scope v)
482 Just (DoneId v) -> DoneId (refine in_scope v)
483 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
484 Just res -> res -- DoneEx non-var, or ContEx
487 -- Get the most up-to-date thing from the in-scope set
488 -- Even though it isn't in the substitution, it may be in
489 -- the in-scope set with better IdInfo
490 refine :: InScopeSet -> Var -> Var
492 | isLocalId v = case lookupInScope in_scope v of
494 Nothing -> WARN( True, ppr v ) v -- This is an error!
497 lookupRecBndr :: SimplEnv -> InId -> OutId
498 -- Look up an Id which has been put into the envt by simplRecBndrs,
499 -- but where we have not yet done its RHS
500 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
501 = case lookupVarEnv ids v of
503 Just _ -> pprPanic "lookupRecBndr" (ppr v)
504 Nothing -> refine in_scope v
508 %************************************************************************
510 \section{Substituting an Id binder}
512 %************************************************************************
515 These functions are in the monad only so that they can be made strict via seq.
518 simplBinders, simplLamBndrs
519 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
520 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
521 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
524 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
525 -- Used for lambda and case-bound variables
526 -- Clone Id if necessary, substitute type
527 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
528 -- The substitution is extended only if the variable is cloned, because
529 -- we *don't* need to use it to track occurrence info.
531 | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
532 ; seqTyVar tv `seq` return (env', tv) }
533 | otherwise = do { let (env', id) = substIdBndr env bndr
534 ; seqId id `seq` return (env', id) }
537 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
538 -- Used for lambda binders. These sometimes have unfoldings added by
539 -- the worker/wrapper pass that must be preserved, because they can't
540 -- be reconstructed from context. For example:
541 -- f x = case x of (a,b) -> fw a b x
542 -- fw a b x{=(a,b)} = ...
543 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
544 simplLamBndr env bndr
545 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
546 | otherwise = simplBinder env bndr -- Normal case
548 old_unf = idUnfolding bndr
549 (env1, id1) = substIdBndr env bndr
550 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
551 env2 = modifyInScope env1 id2
554 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
555 -- A non-recursive let binder
556 simplNonRecBndr env id
557 = do { let (env1, id1) = substIdBndr env id
558 ; seqId id1 `seq` return (env1, id1) }
561 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
562 -- Recursive let binders
563 simplRecBndrs env@(SimplEnv {}) ids
564 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
565 ; seqIds ids1 `seq` return env1 }
568 substIdBndr :: SimplEnv
569 -> InBndr -- Env and binder to transform
570 -> (SimplEnv, OutBndr)
571 -- Clone Id if necessary, substitute its type
572 -- Return an Id with its
573 -- * Type substituted
574 -- * UnfoldingInfo, Rules, WorkerInfo zapped
575 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
576 -- * Robust info, retained especially arity and demand info,
577 -- so that they are available to occurrences that occur in an
578 -- earlier binding of a letrec
580 -- For the robust info, see Note [Arity robustness]
582 -- Augment the substitution if the unique changed
583 -- Extend the in-scope set with the new Id
585 -- Similar to CoreSubst.substIdBndr, except that
586 -- the type of id_subst differs
587 -- all fragile info is zapped
589 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
591 = (env { seInScope = in_scope `extendInScopeSet` new_id,
592 seIdSubst = new_subst }, new_id)
594 id1 = uniqAway in_scope old_id
595 id2 = substIdType env id1
596 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
597 -- and fragile OccInfo
599 -- Extend the substitution if the unique has changed,
600 -- or there's some useful occurrence information
601 -- See the notes with substTyVarBndr for the delSubstEnv
602 new_subst | new_id /= old_id
603 = extendVarEnv id_subst old_id (DoneId new_id)
605 = delVarEnv id_subst old_id
609 ------------------------------------
610 seqTyVar :: TyVar -> ()
611 seqTyVar b = b `seq` ()
614 seqId id = seqType (idType id) `seq`
620 seqIds (id:ids) = seqId id `seq` seqIds ids
624 Note [Arity robustness]
625 ~~~~~~~~~~~~~~~~~~~~~~~
626 We *do* transfer the arity from from the in_id of a let binding to the
627 out_id. This is important, so that the arity of an Id is visible in
628 its own RHS. For example:
629 f = \x. ....g (\y. f y)....
630 We can eta-reduce the arg to g, becuase f is a value. But that
633 This interacts with the 'state hack' too:
638 Can we eta-expand f? Only if we see that f has arity 1, and then we
639 take advantage of the 'state hack' on the result of
640 (f y) :: State# -> (State#, Int) to expand the arity one more.
642 There is a disadvantage though. Making the arity visible in the RHS
643 allows us to eta-reduce
647 which technically is not sound. This is very much a corner case, so
648 I'm not worried about it. Another idea is to ensure that f's arity
649 never decreases; its arity started as 1, and we should never eta-reduce
653 Note [Robust OccInfo]
654 ~~~~~~~~~~~~~~~~~~~~~
655 It's important that we *do* retain the loop-breaker OccInfo, because
656 that's what stops the Id getting inlined infinitely, in the body of
660 Note [Rules in a letrec]
661 ~~~~~~~~~~~~~~~~~~~~~~~~
662 After creating fresh binders for the binders of a letrec, we
663 substitute the RULES and add them back onto the binders; this is done
664 *before* processing any of the RHSs. This is important. Manuel found
665 cases where he really, really wanted a RULE for a recursive function
666 to apply in that function's own right-hand side.
668 See Note [Loop breaking and RULES] in OccAnal.
672 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
673 -- Rules are added back in to to the bin
674 addBndrRules env in_id out_id
675 | isEmptySpecInfo old_rules = (env, out_id)
676 | otherwise = (modifyInScope env final_id, final_id)
678 subst = mkCoreSubst (text "local rules") env
679 old_rules = idSpecialisation in_id
680 new_rules = CoreSubst.substSpec subst out_id old_rules
681 final_id = out_id `setIdSpecialisation` new_rules
685 %************************************************************************
687 Impedence matching to type substitution
689 %************************************************************************
692 getTvSubst :: SimplEnv -> TvSubst
693 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
694 = mkTvSubst in_scope tv_env
696 substTy :: SimplEnv -> Type -> Type
697 substTy env ty = Type.substTy (getTvSubst env) ty
699 substTyVar :: SimplEnv -> TyVar -> Type
700 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
702 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
703 substTyVarBndr env tv
704 = case Type.substTyVarBndr (getTvSubst env) tv of
705 (TvSubst in_scope' tv_env', tv')
706 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
708 -- When substituting in rules etc we can get CoreSubst to do the work
709 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
710 -- here. I think the this will not usually result in a lot of work;
711 -- the substitutions are typically small, and laziness will avoid work in many cases.
713 mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
714 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
715 = mk_subst tv_env id_env
717 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
719 fiddle (DoneEx e) = e
720 fiddle (DoneId v) = Var v
721 fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
722 -- Don't shortcut here
725 substIdType :: SimplEnv -> Id -> Id
726 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
727 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
728 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
729 -- The tyVarsOfType is cheaper than it looks
730 -- because we cache the free tyvars of the type
731 -- in a Note in the id's type itself
736 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
738 = CoreSubst.substExprSC (text "SimplEnv.substExpr1" <+> doc)
739 (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
740 -- Do *not* short-cut in the case of an empty substitution
741 -- See CoreSubst: Note [Extending the Subst]
743 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
744 substUnfolding env unf = CoreSubst.substUnfoldingSC (mkCoreSubst (text "subst-unfolding") env) unf