2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
9 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
10 InCoercion, OutCoercion,
12 -- The simplifier mode
16 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
17 isAmongSimpl, intSwitchSet, switchIsOn,
19 setEnclosingCC, getEnclosingCC,
22 SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
23 zapSubstEnv, setSubstEnv,
24 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
27 SimplSR(..), mkContEx, substId,
29 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
30 simplBinder, simplBinders, addLetIdInfo,
34 FloatsWith, FloatsWithExpr,
35 Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
36 allLifted, wrapFloats, floatBinds,
40 #include "HsVersions.h"
43 import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
44 import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
45 arityInfo, workerInfo, setWorkerInfo,
46 unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
50 import Rules ( RuleBase )
51 import CoreUtils ( needsCaseBinding )
52 import CostCentre ( CostCentreStack, subsumedCCS )
55 import VarSet ( isEmptyVarSet )
58 import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
59 import qualified Type ( substTy, substTyVarBndr )
61 import Type ( Type, TvSubst(..), TvSubstEnv,
62 isUnLiftedType, seqType, tyVarsOfType )
63 import Coercion ( Coercion )
64 import BasicTypes ( OccInfo(..), isFragileOcc )
65 import DynFlags ( SimplifierMode(..) )
66 import Util ( mapAccumL )
70 %************************************************************************
72 \subsection[Simplify-types]{Type declarations}
74 %************************************************************************
77 type InBinder = CoreBndr
78 type InId = Id -- Not yet cloned
79 type InType = Type -- Ditto
80 type InBind = CoreBind
81 type InExpr = CoreExpr
84 type InCoercion = Coercion
86 type OutBinder = CoreBndr
87 type OutId = Id -- Cloned
88 type OutTyVar = TyVar -- Cloned
89 type OutType = Type -- Cloned
90 type OutCoercion = Coercion
91 type OutBind = CoreBind
92 type OutExpr = CoreExpr
97 %************************************************************************
99 \subsubsection{The @SimplEnv@ type}
101 %************************************************************************
107 seMode :: SimplifierMode,
108 seChkr :: SwitchChecker,
109 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
111 -- Rules from other modules
112 seExtRules :: RuleBase,
114 -- The current set of in-scope variables
115 -- They are all OutVars, and all bound in this module
116 seInScope :: InScopeSet, -- OutVars only
118 -- The current substitution
119 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
120 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
123 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
126 = DoneEx OutExpr -- Completed term
127 | DoneId OutId -- Completed term variable
128 | ContEx TvSubstEnv -- A suspended substitution
135 The in-scope part of Subst includes *all* in-scope TyVars and Ids
136 The elements of the set may have better IdInfo than the
137 occurrences of in-scope Ids, and (more important) they will
138 have a correctly-substituted type. So we use a lookup in this
139 set to replace occurrences
141 The Ids in the InScopeSet are replete with their Rules,
142 and as we gather info about the unfolding of an Id, we replace
143 it in the in-scope set.
145 The in-scope set is actually a mapping OutVar -> OutVar, and
146 in case expressions we sometimes bind
149 The substitution is *apply-once* only, because InIds and OutIds can overlap.
150 For example, we generally omit mappings
152 from the substitution, when we decide not to clone a77, but it's quite
153 legitimate to put the mapping in the substitution anyway.
155 Furthermore, consider
156 let x = case k of I# x77 -> ... in
157 let y = case k of I# x77 -> ... in ...
158 and suppose the body is strict in both x and y. Then the simplifier
159 will pull the first (case k) to the top; so the second (case k) will
160 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
163 Of course, the substitution *must* applied! Things in its domain
164 simply aren't necessarily bound in the result.
166 * substId adds a binding (DoneId new_id) to the substitution if
167 the Id's unique has changed
170 Note, though that the substitution isn't necessarily extended
171 if the type changes. Why not? Because of the next point:
173 * We *always, always* finish by looking up in the in-scope set
174 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
175 Reason: so that we never finish up with a "old" Id in the result.
176 An old Id might point to an old unfolding and so on... which gives a space leak.
178 [The DoneEx and DoneVar hits map to "new" stuff.]
180 * It follows that substExpr must not do a no-op if the substitution is empty.
181 substType is free to do so, however.
183 * When we come to a let-binding (say) we generate new IdInfo, including an
184 unfolding, attach it to the binder, and add this newly adorned binder to
185 the in-scope set. So all subsequent occurrences of the binder will get mapped
186 to the full-adorned binder, which is also the one put in the binding site.
188 * The in-scope "set" usually maps x->x; we use it simply for its domain.
189 But sometimes we have two in-scope Ids that are synomyms, and should
190 map to the same target: x->x, y->x. Notably:
192 That's why the "set" is actually a VarEnv Var
196 mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
197 mkSimplEnv mode switches rules
198 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
199 seMode = mode, seInScope = emptyInScopeSet,
201 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
202 -- The top level "enclosing CC" is "SUBSUMED".
204 ---------------------
205 getSwitchChecker :: SimplEnv -> SwitchChecker
206 getSwitchChecker env = seChkr env
208 ---------------------
209 getMode :: SimplEnv -> SimplifierMode
210 getMode env = seMode env
212 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
213 setMode mode env = env { seMode = mode }
215 ---------------------
216 getEnclosingCC :: SimplEnv -> CostCentreStack
217 getEnclosingCC env = seCC env
219 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
220 setEnclosingCC env cc = env {seCC = cc}
222 ---------------------
223 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
224 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
225 = env {seIdSubst = extendVarEnv subst var res}
227 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
228 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
229 = env {seTvSubst = extendVarEnv subst var res}
231 ---------------------
232 getInScope :: SimplEnv -> InScopeSet
233 getInScope env = seInScope env
235 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
236 setInScopeSet env in_scope = env {seInScope = in_scope}
238 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
239 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
241 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
242 -- The new Ids are guaranteed to be freshly allocated
243 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
244 = env { seInScope = in_scope `extendInScopeSetList` vs,
245 seIdSubst = id_subst `delVarEnvList` vs }
246 -- Why delete? Consider
247 -- let x = a*b in (x, \x -> x+3)
248 -- We add [x |-> a*b] to the substitution, but we must
249 -- *delete* it from the substitution when going inside
252 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
253 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
254 = env {seInScope = modifyInScopeSet in_scope v v'}
256 ---------------------
257 zapSubstEnv :: SimplEnv -> SimplEnv
258 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
260 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
261 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
263 mkContEx :: SimplEnv -> InExpr -> SimplSR
264 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
266 isEmptySimplSubst :: SimplEnv -> Bool
267 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
268 = isEmptyVarEnv tvs && isEmptyVarEnv ids
270 ---------------------
271 getRules :: SimplEnv -> RuleBase
272 getRules = seExtRules
276 %************************************************************************
280 %************************************************************************
284 substId :: SimplEnv -> Id -> SimplSR
285 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
288 | otherwise -- A local Id
289 = case lookupVarEnv ids v of
290 Just (DoneId v) -> DoneId (refine v)
292 Nothing -> DoneId (refine v)
294 -- Get the most up-to-date thing from the in-scope set
295 -- Even though it isn't in the substitution, it may be in
296 -- the in-scope set with better IdInfo
297 refine v = case lookupInScope in_scope v of
299 Nothing -> WARN( True, ppr v ) v -- This is an error!
303 %************************************************************************
305 \section{Substituting an Id binder}
307 %************************************************************************
310 These functions are in the monad only so that they can be made strict via seq.
313 simplBinders, simplLamBndrs
314 :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
315 simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
316 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
319 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
320 -- Used for lambda and case-bound variables
321 -- Clone Id if necessary, substitute type
322 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
323 -- The substitution is extended only if the variable is cloned, because
324 -- we *don't* need to use it to track occurrence info.
326 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
327 ; seqTyVar tv `seq` return (env', tv) }
328 | otherwise = do { let (env', id) = substIdBndr env bndr
329 ; seqId id `seq` return (env', id) }
332 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
333 -- Used for lambda binders. These sometimes have unfoldings added by
334 -- the worker/wrapper pass that must be preserved, becuase they can't
335 -- be reconstructed from context. For example:
336 -- f x = case x of (a,b) -> fw a b x
337 -- fw a b x{=(a,b)} = ...
338 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
339 simplLamBndr env bndr
340 | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
341 | otherwise = seqId id2 `seq` return (env', id2)
343 old_unf = idUnfolding bndr
344 (env', id1) = substIdBndr env bndr
345 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
348 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
349 -> (SimplEnv, Id) -- Transformed pair
352 -- * Unique changed if necessary
353 -- * Type substituted
354 -- * Unfolding zapped
355 -- * Rules, worker, lbvar info all substituted
356 -- * Fragile occurrence info zapped
357 -- * The in-scope set extended with the returned Id
358 -- * The substitution extended with a DoneId if unique changed
359 -- In this case, the var in the DoneId is the same as the
362 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
364 = (env { seInScope = in_scope `extendInScopeSet` new_id,
365 seIdSubst = new_subst }, new_id)
367 -- id1 is cloned if necessary
368 id1 = uniqAway in_scope old_id
370 -- id2 has its type zapped
371 id2 = substIdType env id1
373 -- new_id has the final IdInfo
374 subst = mkCoreSubst env
375 new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
377 -- Extend the substitution if the unique has changed
378 -- See the notes with substTyVarBndr for the delSubstEnv
379 new_subst | new_id /= old_id
380 = extendVarEnv id_subst old_id (DoneId new_id)
382 = delVarEnv id_subst old_id
387 seqTyVar :: TyVar -> ()
388 seqTyVar b = b `seq` ()
391 seqId id = seqType (idType id) `seq`
397 seqIds (id:ids) = seqId id `seq` seqIds ids
401 %************************************************************************
405 %************************************************************************
407 Simplifying let binders
408 ~~~~~~~~~~~~~~~~~~~~~~~
409 Rename the binders if necessary,
412 simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
413 simplNonRecBndr env id
414 = do { let (env1, id1) = substLetIdBndr env id
415 ; seqId id1 `seq` return (env1, id1) }
418 simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
419 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
420 = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
421 ; seqIds ids1 `seq` return (env1, ids1) }
424 substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
425 -> (SimplEnv, OutBinder)
426 -- C.f. CoreSubst.substIdBndr
427 -- Clone Id if necessary, substitute its type
428 -- Return an Id with completely zapped IdInfo
429 -- [addLetIdInfo, below, will restore its IdInfo]
430 -- Augment the subtitution
431 -- if the unique changed, *or*
432 -- if there's interesting occurrence info
434 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
435 = (env { seInScope = in_scope `extendInScopeSet` new_id,
436 seIdSubst = new_subst }, new_id)
438 id1 = uniqAway in_scope old_id
439 id2 = substIdType env id1
440 new_id = setIdInfo id2 vanillaIdInfo
442 -- Extend the substitution if the unique has changed,
443 -- or there's some useful occurrence information
444 -- See the notes with substTyVarBndr for the delSubstEnv
445 occ_info = occInfo (idInfo old_id)
446 new_subst | new_id /= old_id
447 = extendVarEnv id_subst old_id (DoneId new_id)
449 = delVarEnv id_subst old_id
452 Add IdInfo back onto a let-bound Id
453 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
454 We must transfer the IdInfo of the original binder to the new binder.
455 This is crucial, to preserve
459 etc. To do this we must apply the current substitution,
460 which incorporates earlier substitutions in this very letrec group.
462 NB 1. We do this *before* processing the RHS of the binder, so that
463 its substituted rules are visible in its own RHS.
464 This is important. Manuel found cases where he really, really
465 wanted a RULE for a recursive function to apply in that function's
468 NB 2: ARITY. We *do* transfer the arity. This is important, so that
469 the arity of an Id is visible in its own RHS. For example:
470 f = \x. ....g (\y. f y)....
471 We can eta-reduce the arg to g, becuase f is a value. But that
474 This interacts with the 'state hack' too:
479 Can we eta-expand f? Only if we see that f has arity 1, and then we
480 take advantage of the 'state hack' on the result of
481 (f y) :: State# -> (State#, Int) to expand the arity one more.
483 There is a disadvantage though. Making the arity visible in the RHA
484 allows us to eta-reduce
488 which technically is not sound. This is very much a corner case, so
489 I'm not worried about it. Another idea is to ensure that f's arity
490 never decreases; its arity started as 1, and we should never eta-reduce
493 NB 3: OccInfo. It's important that we *do* transer the loop-breaker
494 OccInfo, because that's what stops the Id getting inlined infinitely,
495 in the body of the letrec.
497 NB 4: does no harm for non-recursive bindings
499 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
504 Here, we'll do postInlineUnconditionally on f, and we must "see" that
505 when substituting in h's RULE.
508 addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
509 addLetIdInfo env in_id out_id
510 = (modifyInScope env out_id final_id, final_id)
512 final_id = out_id `setIdInfo` new_info
513 subst = mkCoreSubst env
514 old_info = idInfo in_id
515 new_info = case substIdInfo subst old_info of
517 Just new_info -> new_info
519 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
524 -- Keep only 'robust' OccInfo
527 -- Seq'ing on the returned IdInfo is enough to cause all the
528 -- substitutions to happen completely
530 substIdInfo subst info
531 | nothing_to_do = Nothing
532 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
533 `setSpecInfo` CoreSubst.substSpec subst old_rules
534 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
535 `setUnfoldingInfo` noUnfolding)
536 -- setSpecInfo does a seq
537 -- setWorkerInfo does a seq
539 nothing_to_do = keep_occ &&
540 isEmptySpecInfo old_rules &&
541 not (workerExists old_wrkr) &&
542 not (hasUnfolding (unfoldingInfo info))
544 keep_occ = not (isFragileOcc old_occ)
545 old_occ = occInfo info
546 old_rules = specInfo info
547 old_wrkr = workerInfo info
550 substIdType :: SimplEnv -> Id -> Id
551 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
552 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
553 | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
554 -- The tyVarsOfType is cheaper than it looks
555 -- because we cache the free tyvars of the type
556 -- in a Note in the id's type itself
561 substUnfolding env NoUnfolding = NoUnfolding
562 substUnfolding env (OtherCon cons) = OtherCon cons
563 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
564 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
568 %************************************************************************
570 Impedence matching to type substitution
572 %************************************************************************
575 substTy :: SimplEnv -> Type -> Type
576 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
577 = Type.substTy (TvSubst in_scope tv_env) ty
579 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
580 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
581 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
582 (TvSubst in_scope' tv_env', tv')
583 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
585 -- When substituting in rules etc we can get CoreSubst to do the work
586 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
587 -- here. I think the this will not usually result in a lot of work;
588 -- the substitutions are typically small, and laziness will avoid work in many cases.
590 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
591 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
592 = mk_subst tv_env id_env
594 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
596 fiddle (DoneEx e) = e
597 fiddle (DoneId v) = Var v
598 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
600 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
602 | isEmptySimplSubst env = expr
603 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
607 %************************************************************************
611 %************************************************************************
614 type FloatsWithExpr = FloatsWith OutExpr
615 type FloatsWith a = (Floats, a)
616 -- We return something equivalent to (let b in e), but
617 -- in pieces to avoid the quadratic blowup when floating
618 -- incrementally. Comments just before simplExprB in Simplify.lhs
620 data Floats = Floats (OrdList OutBind)
621 InScopeSet -- Environment "inside" all the floats
622 Bool -- True <=> All bindings are lifted
624 allLifted :: Floats -> Bool
625 allLifted (Floats _ _ is_lifted) = is_lifted
627 wrapFloats :: Floats -> OutExpr -> OutExpr
628 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
630 isEmptyFloats :: Floats -> Bool
631 isEmptyFloats (Floats bs _ _) = isNilOL bs
633 floatBinds :: Floats -> [OutBind]
634 floatBinds (Floats bs _ _) = fromOL bs
636 flattenFloats :: Floats -> Floats
637 -- Flattens into a single Rec group
638 flattenFloats (Floats bs is is_lifted)
639 = ASSERT2( is_lifted, ppr (fromOL bs) )
640 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
644 emptyFloats :: SimplEnv -> Floats
645 emptyFloats env = Floats nilOL (getInScope env) True
647 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
648 -- A single non-rec float; extend the in-scope set
649 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
650 (extendInScopeSet (getInScope env) var)
651 (not (isUnLiftedType (idType var)))
653 addFloats :: SimplEnv -> Floats
654 -> (SimplEnv -> SimplM (FloatsWith a))
655 -> SimplM (FloatsWith a)
656 addFloats env (Floats b1 is1 l1) thing_inside
660 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
661 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
663 addLetBind :: OutBind -> Floats -> Floats
664 addLetBind bind (Floats binds in_scope lifted)
665 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
667 is_lifted_bind (Rec _) = True
668 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
670 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
671 -- * extends the in-scope env
672 -- * assumes it's a let-bindable thing
673 addAuxiliaryBind :: SimplEnv -> OutBind
674 -> (SimplEnv -> SimplM (FloatsWith a))
675 -> SimplM (FloatsWith a)
676 -- Extends the in-scope environment as well as wrapping the bindings
677 addAuxiliaryBind env bind thing_inside
678 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
679 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
680 returnSmpl (addLetBind bind floats, x)