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, SimplEnv.extendCvSubst,
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,
29 getCvSubst, substCo, substCoVar,
33 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
34 wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
35 doFloatFromRhs, getFloats
38 #include "HsVersions.h"
41 import CoreMonad ( SimplifierMode(..) )
53 import qualified CoreSubst
55 import Type hiding ( substTy, substTyVarBndr, substTyVar )
56 import qualified Coercion
57 import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
66 %************************************************************************
68 \subsection[Simplify-types]{Type declarations}
70 %************************************************************************
73 type InBndr = CoreBndr
74 type InVar = Var -- Not yet cloned
75 type InId = Id -- Not yet cloned
76 type InType = Type -- Ditto
77 type InBind = CoreBind
78 type InExpr = CoreExpr
81 type InCoercion = Coercion
83 type OutBndr = CoreBndr
84 type OutVar = Var -- Cloned
85 type OutId = Id -- Cloned
86 type OutTyVar = TyVar -- Cloned
87 type OutType = Type -- Cloned
88 type OutCoercion = Coercion
89 type OutBind = CoreBind
90 type OutExpr = CoreExpr
95 %************************************************************************
97 \subsubsection{The @SimplEnv@ type}
99 %************************************************************************
105 ----------- Static part of the environment -----------
106 -- Static in the sense of lexically scoped,
107 -- wrt the original expression
109 seMode :: SimplifierMode,
110 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
112 -- The current substitution
113 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
114 seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion
115 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
117 ----------- Dynamic part of the environment -----------
118 -- Dynamic in the sense of describing the setup where
119 -- the expression finally ends up
121 -- The current set of in-scope variables
122 -- They are all OutVars, and all bound in this module
123 seInScope :: InScopeSet, -- OutVars only
124 -- Includes all variables bound by seFloats
126 -- See Note [Simplifier floats]
129 type StaticEnv = SimplEnv -- Just the static part is relevant
131 pprSimplEnv :: SimplEnv -> SDoc
132 -- Used for debugging; selective
134 = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
135 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
136 ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
139 in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
140 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
143 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
144 -- See Note [Extending the Subst] in CoreSubst
147 = DoneEx OutExpr -- Completed term
148 | DoneId OutId -- Completed term variable
149 | ContEx TvSubstEnv -- A suspended substitution
154 instance Outputable SimplSR where
155 ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
156 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
157 ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
158 ppr (filter_env tv), ppr (filter_env id) -}]
160 -- fvs = exprFreeVars e
161 -- filter_env env = filterVarEnv_Directly keep env
162 -- keep uniq _ = uniq `elemUFM_Directly` fvs
165 Note [SimplEnv invariants]
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~
168 The in-scope part of Subst includes *all* in-scope TyVars and Ids
169 The elements of the set may have better IdInfo than the
170 occurrences of in-scope Ids, and (more important) they will
171 have a correctly-substituted type. So we use a lookup in this
172 set to replace occurrences
174 The Ids in the InScopeSet are replete with their Rules,
175 and as we gather info about the unfolding of an Id, we replace
176 it in the in-scope set.
178 The in-scope set is actually a mapping OutVar -> OutVar, and
179 in case expressions we sometimes bind
182 The substitution is *apply-once* only, because InIds and OutIds can overlap.
183 For example, we generally omit mappings
185 from the substitution, when we decide not to clone a77, but it's quite
186 legitimate to put the mapping in the substitution anyway.
188 Furthermore, consider
189 let x = case k of I# x77 -> ... in
190 let y = case k of I# x77 -> ... in ...
191 and suppose the body is strict in both x and y. Then the simplifier
192 will pull the first (case k) to the top; so the second (case k) will
193 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
196 Of course, the substitution *must* applied! Things in its domain
197 simply aren't necessarily bound in the result.
199 * substId adds a binding (DoneId new_id) to the substitution if
200 the Id's unique has changed
202 Note, though that the substitution isn't necessarily extended
203 if the type of the Id changes. Why not? Because of the next point:
205 * We *always, always* finish by looking up in the in-scope set
206 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
207 Reason: so that we never finish up with a "old" Id in the result.
208 An old Id might point to an old unfolding and so on... which gives a space leak.
210 [The DoneEx and DoneVar hits map to "new" stuff.]
212 * It follows that substExpr must not do a no-op if the substitution is empty.
213 substType is free to do so, however.
215 * When we come to a let-binding (say) we generate new IdInfo, including an
216 unfolding, attach it to the binder, and add this newly adorned binder to
217 the in-scope set. So all subsequent occurrences of the binder will get mapped
218 to the full-adorned binder, which is also the one put in the binding site.
220 * The in-scope "set" usually maps x->x; we use it simply for its domain.
221 But sometimes we have two in-scope Ids that are synomyms, and should
222 map to the same target: x->x, y->x. Notably:
224 That's why the "set" is actually a VarEnv Var
228 mkSimplEnv :: SimplifierMode -> SimplEnv
230 = SimplEnv { seCC = subsumedCCS
232 , seInScope = init_in_scope
233 , seFloats = emptyFloats
234 , seTvSubst = emptyVarEnv
235 , seCvSubst = emptyVarEnv
236 , seIdSubst = emptyVarEnv }
237 -- The top level "enclosing CC" is "SUBSUMED".
239 init_in_scope :: InScopeSet
240 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
241 -- See Note [WildCard binders]
244 Note [WildCard binders]
245 ~~~~~~~~~~~~~~~~~~~~~~~
246 The program to be simplified may have wild binders
247 case e of wild { p -> ... }
248 We want to *rename* them away, so that there are no
249 occurrences of 'wild-id' (with wildCardKey). The easy
250 way to do that is to start of with a representative
251 Id in the in-scope set
253 There can be be *occurrences* of wild-id. For example,
254 MkCore.mkCoreApp transforms
255 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
256 This is ok provided 'wild' isn't free in 'e', and that's the delicate
257 thing. Generally, you want to run the simplifier to get rid of the
258 wild-ids before doing much else.
260 It's a very dark corner of GHC. Maybe it should be cleaned up.
263 getMode :: SimplEnv -> SimplifierMode
264 getMode env = seMode env
266 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
267 setMode mode env = env { seMode = mode }
269 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
270 updMode upd env = env { seMode = upd (seMode env) }
272 ---------------------
273 getEnclosingCC :: SimplEnv -> CostCentreStack
274 getEnclosingCC env = seCC env
276 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
277 setEnclosingCC env cc = env {seCC = cc}
279 ---------------------
280 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
281 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
282 = ASSERT2( isId var && not (isCoVar var), ppr var )
283 env {seIdSubst = extendVarEnv subst var res}
285 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
286 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
287 = env {seTvSubst = extendVarEnv subst var res}
289 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
290 extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
291 = env {seCvSubst = extendVarEnv subst var res}
293 ---------------------
294 getInScope :: SimplEnv -> InScopeSet
295 getInScope env = seInScope env
297 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
298 setInScopeSet env in_scope = env {seInScope = in_scope}
300 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
301 -- Set the in-scope set, and *zap* the floats
302 setInScope env env_with_scope
303 = env { seInScope = seInScope env_with_scope,
304 seFloats = emptyFloats }
306 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
307 -- Set the in-scope set *and* the floats
308 setFloats env env_with_floats
309 = env { seInScope = seInScope env_with_floats,
310 seFloats = seFloats env_with_floats }
312 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
313 -- The new Ids are guaranteed to be freshly allocated
314 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
315 = env { seInScope = in_scope `extendInScopeSetList` vs,
316 seIdSubst = id_subst `delVarEnvList` vs }
317 -- Why delete? Consider
318 -- let x = a*b in (x, \x -> x+3)
319 -- We add [x |-> a*b] to the substitution, but we must
320 -- _delete_ it from the substitution when going inside
323 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
324 -- The variable should already be in scope, but
325 -- replace the existing version with this new one
326 -- which has more information
327 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
328 = env {seInScope = extendInScopeSet in_scope v}
330 ---------------------
331 zapSubstEnv :: SimplEnv -> SimplEnv
332 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
334 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
335 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
337 mkContEx :: SimplEnv -> InExpr -> SimplSR
338 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
343 %************************************************************************
347 %************************************************************************
349 Note [Simplifier floats]
350 ~~~~~~~~~~~~~~~~~~~~~~~~~
351 The Floats is a bunch of bindings, classified by a FloatFlag.
353 NonRec x (y:ys) FltLifted
354 Rec [(x,rhs)] FltLifted
356 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
358 NonRec x# (a /# b) FltCareful
359 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
360 NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
361 -- (where f :: Int -> Int#)
364 data Floats = Floats (OrdList OutBind) FloatFlag
365 -- See Note [Simplifier floats]
368 = FltLifted -- All bindings are lifted and lazy
369 -- Hence ok to float to top level, or recursive
371 | FltOkSpec -- All bindings are FltLifted *or*
372 -- strict (perhaps because unlifted,
373 -- perhaps because of a strict binder),
374 -- *and* ok-for-speculation
375 -- Hence ok to float out of the RHS
376 -- of a lazy non-recursive let binding
377 -- (but not to top level, or into a rec group)
379 | FltCareful -- At least one binding is strict (or unlifted)
380 -- and not guaranteed cheap
381 -- Do not float these bindings out of a lazy let
383 instance Outputable Floats where
384 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
386 instance Outputable FloatFlag where
387 ppr FltLifted = ptext (sLit "FltLifted")
388 ppr FltOkSpec = ptext (sLit "FltOkSpec")
389 ppr FltCareful = ptext (sLit "FltCareful")
391 andFF :: FloatFlag -> FloatFlag -> FloatFlag
392 andFF FltCareful _ = FltCareful
393 andFF FltOkSpec FltCareful = FltCareful
394 andFF FltOkSpec _ = FltOkSpec
395 andFF FltLifted flt = flt
397 classifyFF :: CoreBind -> FloatFlag
398 classifyFF (Rec _) = FltLifted
399 classifyFF (NonRec bndr rhs)
400 | not (isStrictId bndr) = FltLifted
401 | exprOkForSpeculation rhs = FltOkSpec
402 | otherwise = FltCareful
404 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
405 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
406 = not (isNilOL fs) && want_to_float && can_float
408 want_to_float = isTopLevel lvl || exprIsExpandable rhs
409 can_float = case ff of
411 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
412 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
417 emptyFloats :: Floats
418 emptyFloats = Floats nilOL FltLifted
420 unitFloat :: OutBind -> Floats
421 -- A single-binding float
422 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
424 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
425 -- Add a non-recursive binding and extend the in-scope set
426 -- The latter is important; the binder may already be in the
427 -- in-scope set (although it might also have been created with newId)
428 -- but it may now have more IdInfo
430 = id `seq` -- This seq forces the Id, and hence its IdInfo,
431 -- and hence any inner substitutions
432 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
433 seInScope = extendInScopeSet (seInScope env) id }
435 extendFloats :: SimplEnv -> OutBind -> SimplEnv
436 -- Add these bindings to the floats, and extend the in-scope env too
437 extendFloats env bind
438 = env { seFloats = seFloats env `addFlts` unitFloat bind,
439 seInScope = extendInScopeSetList (seInScope env) bndrs }
441 bndrs = bindersOf bind
443 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
444 -- Add the floats for env2 to env1;
445 -- *plus* the in-scope set for env2, which is bigger
446 -- than that for env1
448 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
449 seInScope = seInScope env2 }
451 addFlts :: Floats -> Floats -> Floats
452 addFlts (Floats bs1 l1) (Floats bs2 l2)
453 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
455 zapFloats :: SimplEnv -> SimplEnv
456 zapFloats env = env { seFloats = emptyFloats }
458 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
459 -- Flattens the floats from env2 into a single Rec group,
460 -- prepends the floats from env1, and puts the result back in env2
461 -- This is all very specific to the way recursive bindings are
462 -- handled; see Simplify.simplRecBind
463 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
464 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
465 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
467 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
468 wrapFloats env expr = wrapFlts (seFloats env) expr
470 wrapFlts :: Floats -> OutExpr -> OutExpr
471 -- Wrap the floats around the expression, using case-binding where necessary
472 wrapFlts (Floats bs _) body = foldrOL wrap body bs
474 wrap (Rec prs) body = Let (Rec prs) body
475 wrap (NonRec b r) body = bindNonRec b r body
477 getFloats :: SimplEnv -> [CoreBind]
478 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
480 isEmptyFloats :: SimplEnv -> Bool
481 isEmptyFloats env = isEmptyFlts (seFloats env)
483 isEmptyFlts :: Floats -> Bool
484 isEmptyFlts (Floats bs _) = isNilOL bs
486 floatBinds :: Floats -> [OutBind]
487 floatBinds (Floats bs _) = fromOL bs
491 %************************************************************************
495 %************************************************************************
497 Note [Global Ids in the substitution]
498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
499 We look up even a global (eg imported) Id in the substitution. Consider
500 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
501 The binder-swap in the occurence analyser will add a binding
502 for a LocalId version of g (with the same unique though):
503 case X.g_34 of b { (a,b) -> let g_34 = b in
504 ... case X.g_34 of { (p,q) -> ...} ... }
505 So we want to look up the inner X.g_34 in the substitution, where we'll
506 find that it has been substituted by b. (Or conceivably cloned.)
509 substId :: SimplEnv -> InId -> SimplSR
510 -- Returns DoneEx only on a non-Var expression
511 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
512 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
513 Nothing -> DoneId (refine in_scope v)
514 Just (DoneId v) -> DoneId (refine in_scope v)
515 Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
516 Just res -> res -- DoneEx non-var, or ContEx
518 -- Get the most up-to-date thing from the in-scope set
519 -- Even though it isn't in the substitution, it may be in
520 -- the in-scope set with better IdInfo
521 refine :: InScopeSet -> Var -> Var
523 | isLocalId v = case lookupInScope in_scope v of
525 Nothing -> WARN( True, ppr v ) v -- This is an error!
528 lookupRecBndr :: SimplEnv -> InId -> OutId
529 -- Look up an Id which has been put into the envt by simplRecBndrs,
530 -- but where we have not yet done its RHS
531 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
532 = case lookupVarEnv ids v of
534 Just _ -> pprPanic "lookupRecBndr" (ppr v)
535 Nothing -> refine in_scope v
539 %************************************************************************
541 \section{Substituting an Id binder}
543 %************************************************************************
546 These functions are in the monad only so that they can be made strict via seq.
549 simplBinders, simplLamBndrs
550 :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
551 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
552 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
555 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
556 -- Used for lambda and case-bound variables
557 -- Clone Id if necessary, substitute type
558 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
559 -- The substitution is extended only if the variable is cloned, because
560 -- we *don't* need to use it to track occurrence info.
562 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
563 ; seqTyVar tv `seq` return (env', tv) }
564 | otherwise = do { let (env', id) = substIdBndr env bndr
565 ; seqId id `seq` return (env', id) }
568 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
569 -- Used for lambda binders. These sometimes have unfoldings added by
570 -- the worker/wrapper pass that must be preserved, because they can't
571 -- be reconstructed from context. For example:
572 -- f x = case x of (a,b) -> fw a b x
573 -- fw a b x{=(a,b)} = ...
574 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
575 simplLamBndr env bndr
576 | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
577 | otherwise = simplBinder env bndr -- Normal case
579 old_unf = idUnfolding bndr
580 (env1, id1) = substIdBndr env bndr
581 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
582 env2 = modifyInScope env1 id2
585 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
586 -- A non-recursive let binder
587 simplNonRecBndr env id
588 = do { let (env1, id1) = substIdBndr env id
589 ; seqId id1 `seq` return (env1, id1) }
592 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
593 -- Recursive let binders
594 simplRecBndrs env@(SimplEnv {}) ids
595 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
596 ; seqIds ids1 `seq` return env1 }
599 substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
600 -- Might be a coercion variable
602 | isCoVar bndr = substCoVarBndr env bndr
603 | otherwise = substNonCoVarIdBndr env bndr
608 -> InBndr -- Env and binder to transform
609 -> (SimplEnv, OutBndr)
610 -- Clone Id if necessary, substitute its type
611 -- Return an Id with its
612 -- * Type substituted
613 -- * UnfoldingInfo, Rules, WorkerInfo zapped
614 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
615 -- * Robust info, retained especially arity and demand info,
616 -- so that they are available to occurrences that occur in an
617 -- earlier binding of a letrec
619 -- For the robust info, see Note [Arity robustness]
621 -- Augment the substitution if the unique changed
622 -- Extend the in-scope set with the new Id
624 -- Similar to CoreSubst.substIdBndr, except that
625 -- the type of id_subst differs
626 -- all fragile info is zapped
627 substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
629 = ASSERT2( not (isCoVar old_id), ppr old_id )
630 (env { seInScope = in_scope `extendInScopeSet` new_id,
631 seIdSubst = new_subst }, new_id)
633 id1 = uniqAway in_scope old_id
634 id2 = substIdType env id1
635 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
636 -- and fragile OccInfo
638 -- Extend the substitution if the unique has changed,
639 -- or there's some useful occurrence information
640 -- See the notes with substTyVarBndr for the delSubstEnv
641 new_subst | new_id /= old_id
642 = extendVarEnv id_subst old_id (DoneId new_id)
644 = delVarEnv id_subst old_id
648 ------------------------------------
649 seqTyVar :: TyVar -> ()
650 seqTyVar b = b `seq` ()
653 seqId id = seqType (idType id) `seq`
659 seqIds (id:ids) = seqId id `seq` seqIds ids
663 Note [Arity robustness]
664 ~~~~~~~~~~~~~~~~~~~~~~~
665 We *do* transfer the arity from from the in_id of a let binding to the
666 out_id. This is important, so that the arity of an Id is visible in
667 its own RHS. For example:
668 f = \x. ....g (\y. f y)....
669 We can eta-reduce the arg to g, becuase f is a value. But that
672 This interacts with the 'state hack' too:
677 Can we eta-expand f? Only if we see that f has arity 1, and then we
678 take advantage of the 'state hack' on the result of
679 (f y) :: State# -> (State#, Int) to expand the arity one more.
681 There is a disadvantage though. Making the arity visible in the RHS
682 allows us to eta-reduce
686 which technically is not sound. This is very much a corner case, so
687 I'm not worried about it. Another idea is to ensure that f's arity
688 never decreases; its arity started as 1, and we should never eta-reduce
692 Note [Robust OccInfo]
693 ~~~~~~~~~~~~~~~~~~~~~
694 It's important that we *do* retain the loop-breaker OccInfo, because
695 that's what stops the Id getting inlined infinitely, in the body of
699 Note [Rules in a letrec]
700 ~~~~~~~~~~~~~~~~~~~~~~~~
701 After creating fresh binders for the binders of a letrec, we
702 substitute the RULES and add them back onto the binders; this is done
703 *before* processing any of the RHSs. This is important. Manuel found
704 cases where he really, really wanted a RULE for a recursive function
705 to apply in that function's own right-hand side.
707 See Note [Loop breaking and RULES] in OccAnal.
711 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
712 -- Rules are added back in to to the bin
713 addBndrRules env in_id out_id
714 | isEmptySpecInfo old_rules = (env, out_id)
715 | otherwise = (modifyInScope env final_id, final_id)
717 subst = mkCoreSubst (text "local rules") env
718 old_rules = idSpecialisation in_id
719 new_rules = CoreSubst.substSpec subst out_id old_rules
720 final_id = out_id `setIdSpecialisation` new_rules
724 %************************************************************************
726 Impedence matching to type substitution
728 %************************************************************************
731 getTvSubst :: SimplEnv -> TvSubst
732 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
733 = mkTvSubst in_scope tv_env
735 getCvSubst :: SimplEnv -> CvSubst
736 getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
737 = CvSubst in_scope tv_env cv_env
739 substTy :: SimplEnv -> Type -> Type
740 substTy env ty = Type.substTy (getTvSubst env) ty
742 substTyVar :: SimplEnv -> TyVar -> Type
743 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
745 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
746 substTyVarBndr env tv
747 = case Type.substTyVarBndr (getTvSubst env) tv of
748 (TvSubst in_scope' tv_env', tv')
749 -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
751 substCoVar :: SimplEnv -> CoVar -> Coercion
752 substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
754 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
755 substCoVarBndr env cv
756 = case Coercion.substCoVarBndr (getCvSubst env) cv of
757 (CvSubst in_scope' tv_env' cv_env', cv')
758 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
760 substCo :: SimplEnv -> Coercion -> Coercion
761 substCo env co = Coercion.substCo (getCvSubst env) co
763 -- When substituting in rules etc we can get CoreSubst to do the work
764 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
765 -- here. I think the this will not usually result in a lot of work;
766 -- the substitutions are typically small, and laziness will avoid work in many cases.
768 mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
769 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
770 = mk_subst tv_env cv_env id_env
772 mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
774 fiddle (DoneEx e) = e
775 fiddle (DoneId v) = Var v
776 fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
777 -- Don't shortcut here
780 substIdType :: SimplEnv -> Id -> Id
781 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
782 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
783 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
784 -- The tyVarsOfType is cheaper than it looks
785 -- because we cache the free tyvars of the type
786 -- in a Note in the id's type itself
791 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
793 = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
794 (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
795 -- Do *not* short-cut in the case of an empty substitution
796 -- See Note [SimplEnv invariants]
798 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
799 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
800 -- Do *not* short-cut in the case of an empty substitution
801 -- See Note [SimplEnv invariants]