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(..) )
51 import qualified CoreSubst
52 import qualified Type ( substTy, substTyVarBndr, substTyVar )
53 import Type hiding ( substTy, substTyVarBndr, substTyVar )
63 %************************************************************************
65 \subsection[Simplify-types]{Type declarations}
67 %************************************************************************
70 type InBndr = CoreBndr
71 type InVar = Var -- Not yet cloned
72 type InId = Id -- Not yet cloned
73 type InType = Type -- Ditto
74 type InBind = CoreBind
75 type InExpr = CoreExpr
78 type InCoercion = Coercion
80 type OutBndr = CoreBndr
81 type OutVar = Var -- Cloned
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 ----------- Static part of the environment -----------
103 -- Static in the sense of lexically scoped,
104 -- wrt the original expression
106 seMode :: SimplifierMode,
107 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
109 -- The current substitution
110 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
111 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
113 ----------- Dynamic part of the environment -----------
114 -- Dynamic in the sense of describing the setup where
115 -- the expression finally ends up
117 -- The current set of in-scope variables
118 -- They are all OutVars, and all bound in this module
119 seInScope :: InScopeSet, -- OutVars only
120 -- Includes all variables bound by seFloats
122 -- See Note [Simplifier floats]
125 type StaticEnv = SimplEnv -- Just the static part is relevant
127 pprSimplEnv :: SimplEnv -> SDoc
128 -- Used for debugging; selective
130 = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
131 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
132 ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
135 in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
136 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
139 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
140 -- See Note [Extending the Subst] in CoreSubst
143 = DoneEx OutExpr -- Completed term
144 | DoneId OutId -- Completed term variable
145 | ContEx TvSubstEnv -- A suspended substitution
149 instance Outputable SimplSR where
150 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
151 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
152 ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
153 ppr (filter_env tv), ppr (filter_env id) -}]
155 -- fvs = exprFreeVars e
156 -- filter_env env = filterVarEnv_Directly keep env
157 -- keep uniq _ = uniq `elemUFM_Directly` fvs
160 Note [SimplEnv invariants]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~
163 The in-scope part of Subst includes *all* in-scope TyVars and Ids
164 The elements of the set may have better IdInfo than the
165 occurrences of in-scope Ids, and (more important) they will
166 have a correctly-substituted type. So we use a lookup in this
167 set to replace occurrences
169 The Ids in the InScopeSet are replete with their Rules,
170 and as we gather info about the unfolding of an Id, we replace
171 it in the in-scope set.
173 The in-scope set is actually a mapping OutVar -> OutVar, and
174 in case expressions we sometimes bind
177 The substitution is *apply-once* only, because InIds and OutIds can overlap.
178 For example, we generally omit mappings
180 from the substitution, when we decide not to clone a77, but it's quite
181 legitimate to put the mapping in the substitution anyway.
183 Furthermore, consider
184 let x = case k of I# x77 -> ... in
185 let y = case k of I# x77 -> ... in ...
186 and suppose the body is strict in both x and y. Then the simplifier
187 will pull the first (case k) to the top; so the second (case k) will
188 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
191 Of course, the substitution *must* applied! Things in its domain
192 simply aren't necessarily bound in the result.
194 * substId adds a binding (DoneId new_id) to the substitution if
195 the Id's unique has changed
197 Note, though that the substitution isn't necessarily extended
198 if the type of the Id changes. Why not? Because of the next point:
200 * We *always, always* finish by looking up in the in-scope set
201 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
202 Reason: so that we never finish up with a "old" Id in the result.
203 An old Id might point to an old unfolding and so on... which gives a space leak.
205 [The DoneEx and DoneVar hits map to "new" stuff.]
207 * It follows that substExpr must not do a no-op if the substitution is empty.
208 substType is free to do so, however.
210 * When we come to a let-binding (say) we generate new IdInfo, including an
211 unfolding, attach it to the binder, and add this newly adorned binder to
212 the in-scope set. So all subsequent occurrences of the binder will get mapped
213 to the full-adorned binder, which is also the one put in the binding site.
215 * The in-scope "set" usually maps x->x; we use it simply for its domain.
216 But sometimes we have two in-scope Ids that are synomyms, and should
217 map to the same target: x->x, y->x. Notably:
219 That's why the "set" is actually a VarEnv Var
223 mkSimplEnv :: SimplifierMode -> SimplEnv
225 = SimplEnv { seCC = subsumedCCS
227 , seInScope = init_in_scope
228 , seFloats = emptyFloats
229 , seTvSubst = emptyVarEnv
230 , seIdSubst = emptyVarEnv }
231 -- The top level "enclosing CC" is "SUBSUMED".
233 init_in_scope :: InScopeSet
234 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
235 -- See Note [WildCard binders]
238 Note [WildCard binders]
239 ~~~~~~~~~~~~~~~~~~~~~~~
240 The program to be simplified may have wild binders
241 case e of wild { p -> ... }
242 We want to *rename* them away, so that there are no
243 occurrences of 'wild-id' (with wildCardKey). The easy
244 way to do that is to start of with a representative
245 Id in the in-scope set
247 There can be be *occurrences* of wild-id. For example,
248 MkCore.mkCoreApp transforms
249 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
250 This is ok provided 'wild' isn't free in 'e', and that's the delicate
251 thing. Generally, you want to run the simplifier to get rid of the
252 wild-ids before doing much else.
254 It's a very dark corner of GHC. Maybe it should be cleaned up.
257 getMode :: SimplEnv -> SimplifierMode
258 getMode env = seMode env
260 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
261 setMode mode env = env { seMode = mode }
263 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
264 updMode upd env = env { seMode = upd (seMode env) }
266 ---------------------
267 getEnclosingCC :: SimplEnv -> CostCentreStack
268 getEnclosingCC env = seCC env
270 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
271 setEnclosingCC env cc = env {seCC = cc}
273 ---------------------
274 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
275 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
276 = env {seIdSubst = extendVarEnv subst var res}
278 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
279 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
280 = env {seTvSubst = extendVarEnv subst var res}
282 ---------------------
283 getInScope :: SimplEnv -> InScopeSet
284 getInScope env = seInScope env
286 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
287 setInScopeSet env in_scope = env {seInScope = in_scope}
289 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
290 -- Set the in-scope set, and *zap* the floats
291 setInScope env env_with_scope
292 = env { seInScope = seInScope env_with_scope,
293 seFloats = emptyFloats }
295 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
296 -- Set the in-scope set *and* the floats
297 setFloats env env_with_floats
298 = env { seInScope = seInScope env_with_floats,
299 seFloats = seFloats env_with_floats }
301 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
302 -- The new Ids are guaranteed to be freshly allocated
303 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
304 = env { seInScope = in_scope `extendInScopeSetList` vs,
305 seIdSubst = id_subst `delVarEnvList` vs }
306 -- Why delete? Consider
307 -- let x = a*b in (x, \x -> x+3)
308 -- We add [x |-> a*b] to the substitution, but we must
309 -- _delete_ it from the substitution when going inside
312 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
313 -- The variable should already be in scope, but
314 -- replace the existing version with this new one
315 -- which has more information
316 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
317 = env {seInScope = extendInScopeSet in_scope v}
319 ---------------------
320 zapSubstEnv :: SimplEnv -> SimplEnv
321 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
323 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
324 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
326 mkContEx :: SimplEnv -> InExpr -> SimplSR
327 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
332 %************************************************************************
336 %************************************************************************
338 Note [Simplifier floats]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~
340 The Floats is a bunch of bindings, classified by a FloatFlag.
342 NonRec x (y:ys) FltLifted
343 Rec [(x,rhs)] FltLifted
345 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
347 NonRec x# (a /# b) FltCareful
348 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
349 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
350 -- (where f :: Int -> Int#)
353 data Floats = Floats (OrdList OutBind) FloatFlag
354 -- See Note [Simplifier floats]
357 = FltLifted -- All bindings are lifted and lazy
358 -- Hence ok to float to top level, or recursive
360 | FltOkSpec -- All bindings are FltLifted *or*
361 -- strict (perhaps because unlifted,
362 -- perhaps because of a strict binder),
363 -- *and* ok-for-speculation
364 -- Hence ok to float out of the RHS
365 -- of a lazy non-recursive let binding
366 -- (but not to top level, or into a rec group)
368 | FltCareful -- At least one binding is strict (or unlifted)
369 -- and not guaranteed cheap
370 -- Do not float these bindings out of a lazy let
372 instance Outputable Floats where
373 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
375 instance Outputable FloatFlag where
376 ppr FltLifted = ptext (sLit "FltLifted")
377 ppr FltOkSpec = ptext (sLit "FltOkSpec")
378 ppr FltCareful = ptext (sLit "FltCareful")
380 andFF :: FloatFlag -> FloatFlag -> FloatFlag
381 andFF FltCareful _ = FltCareful
382 andFF FltOkSpec FltCareful = FltCareful
383 andFF FltOkSpec _ = FltOkSpec
384 andFF FltLifted flt = flt
386 classifyFF :: CoreBind -> FloatFlag
387 classifyFF (Rec _) = FltLifted
388 classifyFF (NonRec bndr rhs)
389 | not (isStrictId bndr) = FltLifted
390 | exprOkForSpeculation rhs = FltOkSpec
391 | otherwise = FltCareful
393 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
394 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
395 = not (isNilOL fs) && want_to_float && can_float
397 want_to_float = isTopLevel lvl || exprIsExpandable rhs
398 can_float = case ff of
400 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
401 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
406 emptyFloats :: Floats
407 emptyFloats = Floats nilOL FltLifted
409 unitFloat :: OutBind -> Floats
410 -- A single-binding float
411 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
413 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
414 -- Add a non-recursive binding and extend the in-scope set
415 -- The latter is important; the binder may already be in the
416 -- in-scope set (although it might also have been created with newId)
417 -- but it may now have more IdInfo
419 = id `seq` -- This seq forces the Id, and hence its IdInfo,
420 -- and hence any inner substitutions
421 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
422 seInScope = extendInScopeSet (seInScope env) id }
424 extendFloats :: SimplEnv -> OutBind -> SimplEnv
425 -- Add these bindings to the floats, and extend the in-scope env too
426 extendFloats env bind
427 = env { seFloats = seFloats env `addFlts` unitFloat bind,
428 seInScope = extendInScopeSetList (seInScope env) bndrs }
430 bndrs = bindersOf bind
432 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
433 -- Add the floats for env2 to env1;
434 -- *plus* the in-scope set for env2, which is bigger
435 -- than that for env1
437 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
438 seInScope = seInScope env2 }
440 addFlts :: Floats -> Floats -> Floats
441 addFlts (Floats bs1 l1) (Floats bs2 l2)
442 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
444 zapFloats :: SimplEnv -> SimplEnv
445 zapFloats env = env { seFloats = emptyFloats }
447 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
448 -- Flattens the floats from env2 into a single Rec group,
449 -- prepends the floats from env1, and puts the result back in env2
450 -- This is all very specific to the way recursive bindings are
451 -- handled; see Simplify.simplRecBind
452 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
453 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
454 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
456 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
457 wrapFloats env expr = wrapFlts (seFloats env) expr
459 wrapFlts :: Floats -> OutExpr -> OutExpr
460 -- Wrap the floats around the expression, using case-binding where necessary
461 wrapFlts (Floats bs _) body = foldrOL wrap body bs
463 wrap (Rec prs) body = Let (Rec prs) body
464 wrap (NonRec b r) body = bindNonRec b r body
466 getFloats :: SimplEnv -> [CoreBind]
467 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
469 isEmptyFloats :: SimplEnv -> Bool
470 isEmptyFloats env = isEmptyFlts (seFloats env)
472 isEmptyFlts :: Floats -> Bool
473 isEmptyFlts (Floats bs _) = isNilOL bs
475 floatBinds :: Floats -> [OutBind]
476 floatBinds (Floats bs _) = fromOL bs
480 %************************************************************************
484 %************************************************************************
486 Note [Global Ids in the substitution]
487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
488 We look up even a global (eg imported) Id in the substitution. Consider
489 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
490 The binder-swap in the occurence analyser will add a binding
491 for a LocalId version of g (with the same unique though):
492 case X.g_34 of b { (a,b) -> let g_34 = b in
493 ... case X.g_34 of { (p,q) -> ...} ... }
494 So we want to look up the inner X.g_34 in the substitution, where we'll
495 find that it has been substituted by b. (Or conceivably cloned.)
498 substId :: SimplEnv -> InId -> SimplSR
499 -- Returns DoneEx only on a non-Var expression
500 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
501 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
502 Nothing -> DoneId (refine in_scope v)
503 Just (DoneId v) -> DoneId (refine in_scope v)
504 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
505 Just res -> res -- DoneEx non-var, or ContEx
508 -- Get the most up-to-date thing from the in-scope set
509 -- Even though it isn't in the substitution, it may be in
510 -- the in-scope set with better IdInfo
511 refine :: InScopeSet -> Var -> Var
513 | isLocalId v = case lookupInScope in_scope v of
515 Nothing -> WARN( True, ppr v ) v -- This is an error!
518 lookupRecBndr :: SimplEnv -> InId -> OutId
519 -- Look up an Id which has been put into the envt by simplRecBndrs,
520 -- but where we have not yet done its RHS
521 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
522 = case lookupVarEnv ids v of
524 Just _ -> pprPanic "lookupRecBndr" (ppr v)
525 Nothing -> refine in_scope v
529 %************************************************************************
531 \section{Substituting an Id binder}
533 %************************************************************************
536 These functions are in the monad only so that they can be made strict via seq.
539 simplBinders, simplLamBndrs
540 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
541 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
542 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
545 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
546 -- Used for lambda and case-bound variables
547 -- Clone Id if necessary, substitute type
548 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
549 -- The substitution is extended only if the variable is cloned, because
550 -- we *don't* need to use it to track occurrence info.
552 | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
553 ; seqTyVar tv `seq` return (env', tv) }
554 | otherwise = do { let (env', id) = substIdBndr env bndr
555 ; seqId id `seq` return (env', id) }
558 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
559 -- Used for lambda binders. These sometimes have unfoldings added by
560 -- the worker/wrapper pass that must be preserved, because they can't
561 -- be reconstructed from context. For example:
562 -- f x = case x of (a,b) -> fw a b x
563 -- fw a b x{=(a,b)} = ...
564 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
565 simplLamBndr env bndr
566 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
567 | otherwise = simplBinder env bndr -- Normal case
569 old_unf = idUnfolding bndr
570 (env1, id1) = substIdBndr env bndr
571 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
572 env2 = modifyInScope env1 id2
575 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
576 -- A non-recursive let binder
577 simplNonRecBndr env id
578 = do { let (env1, id1) = substIdBndr env id
579 ; seqId id1 `seq` return (env1, id1) }
582 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
583 -- Recursive let binders
584 simplRecBndrs env@(SimplEnv {}) ids
585 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
586 ; seqIds ids1 `seq` return env1 }
589 substIdBndr :: SimplEnv
590 -> InBndr -- Env and binder to transform
591 -> (SimplEnv, OutBndr)
592 -- Clone Id if necessary, substitute its type
593 -- Return an Id with its
594 -- * Type substituted
595 -- * UnfoldingInfo, Rules, WorkerInfo zapped
596 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
597 -- * Robust info, retained especially arity and demand info,
598 -- so that they are available to occurrences that occur in an
599 -- earlier binding of a letrec
601 -- For the robust info, see Note [Arity robustness]
603 -- Augment the substitution if the unique changed
604 -- Extend the in-scope set with the new Id
606 -- Similar to CoreSubst.substIdBndr, except that
607 -- the type of id_subst differs
608 -- all fragile info is zapped
610 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
612 = (env { seInScope = in_scope `extendInScopeSet` new_id,
613 seIdSubst = new_subst }, new_id)
615 id1 = uniqAway in_scope old_id
616 id2 = substIdType env id1
617 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
618 -- and fragile OccInfo
620 -- Extend the substitution if the unique has changed,
621 -- or there's some useful occurrence information
622 -- See the notes with substTyVarBndr for the delSubstEnv
623 new_subst | new_id /= old_id
624 = extendVarEnv id_subst old_id (DoneId new_id)
626 = delVarEnv id_subst old_id
630 ------------------------------------
631 seqTyVar :: TyVar -> ()
632 seqTyVar b = b `seq` ()
635 seqId id = seqType (idType id) `seq`
641 seqIds (id:ids) = seqId id `seq` seqIds ids
645 Note [Arity robustness]
646 ~~~~~~~~~~~~~~~~~~~~~~~
647 We *do* transfer the arity from from the in_id of a let binding to the
648 out_id. This is important, so that the arity of an Id is visible in
649 its own RHS. For example:
650 f = \x. ....g (\y. f y)....
651 We can eta-reduce the arg to g, becuase f is a value. But that
654 This interacts with the 'state hack' too:
659 Can we eta-expand f? Only if we see that f has arity 1, and then we
660 take advantage of the 'state hack' on the result of
661 (f y) :: State# -> (State#, Int) to expand the arity one more.
663 There is a disadvantage though. Making the arity visible in the RHS
664 allows us to eta-reduce
668 which technically is not sound. This is very much a corner case, so
669 I'm not worried about it. Another idea is to ensure that f's arity
670 never decreases; its arity started as 1, and we should never eta-reduce
674 Note [Robust OccInfo]
675 ~~~~~~~~~~~~~~~~~~~~~
676 It's important that we *do* retain the loop-breaker OccInfo, because
677 that's what stops the Id getting inlined infinitely, in the body of
681 Note [Rules in a letrec]
682 ~~~~~~~~~~~~~~~~~~~~~~~~
683 After creating fresh binders for the binders of a letrec, we
684 substitute the RULES and add them back onto the binders; this is done
685 *before* processing any of the RHSs. This is important. Manuel found
686 cases where he really, really wanted a RULE for a recursive function
687 to apply in that function's own right-hand side.
689 See Note [Loop breaking and RULES] in OccAnal.
693 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
694 -- Rules are added back in to to the bin
695 addBndrRules env in_id out_id
696 | isEmptySpecInfo old_rules = (env, out_id)
697 | otherwise = (modifyInScope env final_id, final_id)
699 subst = mkCoreSubst (text "local rules") env
700 old_rules = idSpecialisation in_id
701 new_rules = CoreSubst.substSpec subst out_id old_rules
702 final_id = out_id `setIdSpecialisation` new_rules
706 %************************************************************************
708 Impedence matching to type substitution
710 %************************************************************************
713 getTvSubst :: SimplEnv -> TvSubst
714 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
715 = mkTvSubst in_scope tv_env
717 substTy :: SimplEnv -> Type -> Type
718 substTy env ty = Type.substTy (getTvSubst env) ty
720 substTyVar :: SimplEnv -> TyVar -> Type
721 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
723 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
724 substTyVarBndr env tv
725 = case Type.substTyVarBndr (getTvSubst env) tv of
726 (TvSubst in_scope' tv_env', tv')
727 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
729 -- When substituting in rules etc we can get CoreSubst to do the work
730 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
731 -- here. I think the this will not usually result in a lot of work;
732 -- the substitutions are typically small, and laziness will avoid work in many cases.
734 mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
735 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
736 = mk_subst tv_env id_env
738 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
740 fiddle (DoneEx e) = e
741 fiddle (DoneId v) = Var v
742 fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
743 -- Don't shortcut here
746 substIdType :: SimplEnv -> Id -> Id
747 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
748 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
749 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
750 -- The tyVarsOfType is cheaper than it looks
751 -- because we cache the free tyvars of the type
752 -- in a Note in the id's type itself
757 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
759 = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
760 (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
761 -- Do *not* short-cut in the case of an empty substitution
762 -- See Note [SimplEnv invariants]
764 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
765 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
766 -- Do *not* short-cut in the case of an empty substitution
767 -- See Note [SimplEnv invariants]