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,
11 -- The simplifier mode
15 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
16 isAmongSimpl, intSwitchSet, switchIsOn,
18 setEnclosingCC, getEnclosingCC,
21 SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
22 zapSubstEnv, setSubstEnv,
23 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
24 getRules, refineSimplEnv,
26 SimplSR(..), mkContEx, substId,
28 simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
29 simplBinder, simplBinders, addLetIdInfo,
33 FloatsWith, FloatsWithExpr,
34 Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
35 allLifted, wrapFloats, floatBinds,
39 #include "HsVersions.h"
42 import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
43 import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
44 arityInfo, setArityInfo, workerInfo, setWorkerInfo,
45 unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
46 unknownArity, workerExists
49 import Unify ( TypeRefinement )
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, composeTvSubst,
62 isUnLiftedType, seqType, tyVarsOfType )
63 import BasicTypes ( OccInfo(..), isFragileOcc )
64 import DynFlags ( SimplifierMode(..) )
65 import Util ( mapAccumL )
69 %************************************************************************
71 \subsection[Simplify-types]{Type declarations}
73 %************************************************************************
76 type InBinder = CoreBndr
77 type InId = Id -- Not yet cloned
78 type InType = Type -- Ditto
79 type InBind = CoreBind
80 type InExpr = CoreExpr
84 type OutBinder = CoreBndr
85 type OutId = Id -- Cloned
86 type OutTyVar = TyVar -- Cloned
87 type OutType = Type -- Cloned
88 type OutBind = CoreBind
89 type OutExpr = CoreExpr
94 %************************************************************************
96 \subsubsection{The @SimplEnv@ type}
98 %************************************************************************
104 seMode :: SimplifierMode,
105 seChkr :: SwitchChecker,
106 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
108 -- Rules from other modules
109 seExtRules :: RuleBase,
111 -- The current set of in-scope variables
112 -- They are all OutVars, and all bound in this module
113 seInScope :: InScopeSet, -- OutVars only
115 -- The current substitution
116 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
117 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
120 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
123 = DoneEx OutExpr -- Completed term
124 | DoneId OutId OccInfo -- Completed term variable, with occurrence info
125 | ContEx TvSubstEnv -- A suspended substitution
132 The in-scope part of Subst includes *all* in-scope TyVars and Ids
133 The elements of the set may have better IdInfo than the
134 occurrences of in-scope Ids, and (more important) they will
135 have a correctly-substituted type. So we use a lookup in this
136 set to replace occurrences
138 The Ids in the InScopeSet are replete with their Rules,
139 and as we gather info about the unfolding of an Id, we replace
140 it in the in-scope set.
142 The in-scope set is actually a mapping OutVar -> OutVar, and
143 in case expressions we sometimes bind
146 The substitution is *apply-once* only, because InIds and OutIds can overlap.
147 For example, we generally omit mappings
149 from the substitution, when we decide not to clone a77, but it's quite
150 legitimate to put the mapping in the substitution anyway.
152 Indeed, we do so when we want to pass fragile OccInfo to the
153 occurrences of the variable; we add a substitution
154 x77 -> DoneId x77 occ
155 to record x's occurrence information.]
157 Furthermore, consider
158 let x = case k of I# x77 -> ... in
159 let y = case k of I# x77 -> ... in ...
160 and suppose the body is strict in both x and y. Then the simplifier
161 will pull the first (case k) to the top; so the second (case k) will
162 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
165 Of course, the substitution *must* applied! Things in its domain
166 simply aren't necessarily bound in the result.
168 * substId adds a binding (DoneId new_id occ) to the substitution if
169 EITHER the Id's unique has changed
170 OR the Id has interesting occurrence information
171 So in effect you can only get to interesting occurrence information
172 by looking up the *old* Id; it's not really attached to the new id
175 Note, though that the substitution isn't necessarily extended
176 if the type changes. Why not? Because of the next point:
178 * We *always, always* finish by looking up in the in-scope set
179 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
180 Reason: so that we never finish up with a "old" Id in the result.
181 An old Id might point to an old unfolding and so on... which gives a space leak.
183 [The DoneEx and DoneVar hits map to "new" stuff.]
185 * It follows that substExpr must not do a no-op if the substitution is empty.
186 substType is free to do so, however.
188 * When we come to a let-binding (say) we generate new IdInfo, including an
189 unfolding, attach it to the binder, and add this newly adorned binder to
190 the in-scope set. So all subsequent occurrences of the binder will get mapped
191 to the full-adorned binder, which is also the one put in the binding site.
193 * The in-scope "set" usually maps x->x; we use it simply for its domain.
194 But sometimes we have two in-scope Ids that are synomyms, and should
195 map to the same target: x->x, y->x. Notably:
197 That's why the "set" is actually a VarEnv Var
200 Note [GADT type refinement]
201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
202 When we come to a GADT pattern match that refines the in-scope types, we
203 a) Refine the types of the Ids in the in-scope set, seInScope.
204 For exmaple, consider
206 Foo :: T (Bool -> Bool)
208 (\ (x::T a) (y::a) -> case x of { Foo -> y True }
210 Technically this is well-typed, but exprType will barf on the
211 (y True) unless we refine the type on y's occurrence.
213 b) Refine the range of the type substitution, seTvSubst.
214 Very similar reason to (a).
216 NB: we don't refine the range of the SimplIdSubst, because it's always
217 interpreted relative to the seInScope (see substId)
219 For (b) we need to be a little careful. Specifically, we compose the refinement
220 with the type substitution. Suppose
221 The substitution was [a->b, b->a]
222 and the refinement was [b->Int]
223 Then we want [a->Int, b->a]
226 The substitution was [a->b]
227 and the refinement was [b->Int]
228 Then we want [a->Int, b->Int]
229 becuase b might be both an InTyVar and OutTyVar
233 mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
234 mkSimplEnv mode switches rules
235 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
236 seMode = mode, seInScope = emptyInScopeSet,
238 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
239 -- The top level "enclosing CC" is "SUBSUMED".
241 ---------------------
242 getSwitchChecker :: SimplEnv -> SwitchChecker
243 getSwitchChecker env = seChkr env
245 ---------------------
246 getMode :: SimplEnv -> SimplifierMode
247 getMode env = seMode env
249 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
250 setMode mode env = env { seMode = mode }
252 ---------------------
253 getEnclosingCC :: SimplEnv -> CostCentreStack
254 getEnclosingCC env = seCC env
256 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
257 setEnclosingCC env cc = env {seCC = cc}
259 ---------------------
260 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
261 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
262 = env {seIdSubst = extendVarEnv subst var res}
264 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
265 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
266 = env {seTvSubst = extendVarEnv subst var res}
268 ---------------------
269 getInScope :: SimplEnv -> InScopeSet
270 getInScope env = seInScope env
272 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
273 setInScopeSet env in_scope = env {seInScope = in_scope}
275 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
276 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
278 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
279 -- The new Ids are guaranteed to be freshly allocated
280 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
281 = env { seInScope = in_scope `extendInScopeSetList` vs,
282 seIdSubst = id_subst `delVarEnvList` vs }
283 -- Why delete? Consider
284 -- let x = a*b in (x, \x -> x+3)
285 -- We add [x |-> a*b] to the substitution, but we must
286 -- *delete* it from the substitution when going inside
289 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
290 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
291 = env {seInScope = modifyInScopeSet in_scope v v'}
293 ---------------------
294 zapSubstEnv :: SimplEnv -> SimplEnv
295 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
297 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
298 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
300 mkContEx :: SimplEnv -> InExpr -> SimplSR
301 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
303 isEmptySimplSubst :: SimplEnv -> Bool
304 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
305 = isEmptyVarEnv tvs && isEmptyVarEnv ids
307 ---------------------
308 getRules :: SimplEnv -> RuleBase
309 getRules = seExtRules
314 Given an idempotent substitution, generated by the unifier, use it to
315 refine the environment
318 refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
319 -- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
320 refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
321 (refine_tv_subst, all_bound_here)
322 = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
323 seInScope = in_scope' }
326 | all_bound_here = in_scope
327 -- The tvs are the tyvars bound here. If only they
328 -- are refined, there's no need to do anything
329 | otherwise = mapInScopeSet refine_id in_scope
331 refine_id v -- Only refine its type; any rules will get
332 -- refined if they are used (I hope)
333 | isId v = setIdType v (Type.substTy refine_subst (idType v))
335 refine_subst = TvSubst in_scope refine_tv_subst
338 %************************************************************************
342 %************************************************************************
346 substId :: SimplEnv -> Id -> SimplSR
347 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
350 | otherwise -- A local Id
351 = case lookupVarEnv ids v of
352 Just (DoneId v occ) -> DoneId (refine v) occ
354 Nothing -> let v' = refine v
355 in DoneId v' (idOccInfo v')
356 -- We don't put LoopBreakers in the substitution (unless then need
357 -- to be cloned for name-clash rasons), so the idOccInfo is
358 -- very important! If isFragileOcc returned True for
359 -- loop breakers we could avoid this call, but at the expense
360 -- of adding more to the substitution, and building new Ids
361 -- a bit more often than really necessary
363 -- Get the most up-to-date thing from the in-scope set
364 -- Even though it isn't in the substitution, it may be in
365 -- the in-scope set with a different type (we only use the
366 -- substitution if the unique changes).
367 refine v = case lookupInScope in_scope v of
369 Nothing -> WARN( True, ppr v ) v -- This is an error!
373 %************************************************************************
375 \section{Substituting an Id binder}
377 %************************************************************************
380 These functions are in the monad only so that they can be made strict via seq.
383 simplBinders, simplLamBndrs
384 :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
385 simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
386 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
389 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
390 -- Used for lambda and case-bound variables
391 -- Clone Id if necessary, substitute type
392 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
393 -- The substitution is extended only if the variable is cloned, because
394 -- we *don't* need to use it to track occurrence info.
396 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
397 ; seqTyVar tv `seq` return (env', tv) }
398 | otherwise = do { let (env', id) = substIdBndr env bndr
399 ; seqId id `seq` return (env', id) }
402 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
403 -- Used for lambda binders. These sometimes have unfoldings added by
404 -- the worker/wrapper pass that must be preserved, becuase they can't
405 -- be reconstructed from context. For example:
406 -- f x = case x of (a,b) -> fw a b x
407 -- fw a b x{=(a,b)} = ...
408 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
409 simplLamBndr env bndr
410 | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
411 | otherwise = seqId id2 `seq` return (env', id2)
413 old_unf = idUnfolding bndr
414 (env', id1) = substIdBndr env bndr
415 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
418 substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
419 -> (SimplEnv, Id) -- Transformed pair
422 -- * Unique changed if necessary
423 -- * Type substituted
424 -- * Unfolding zapped
425 -- * Rules, worker, lbvar info all substituted
426 -- * Fragile occurrence info zapped
427 -- * The in-scope set extended with the returned Id
428 -- * The substitution extended with a DoneId if unique changed
429 -- In this case, the var in the DoneId is the same as the
432 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
434 = (env { seInScope = in_scope `extendInScopeSet` new_id,
435 seIdSubst = new_subst }, new_id)
437 -- id1 is cloned if necessary
438 id1 = uniqAway in_scope old_id
440 -- id2 has its type zapped
441 id2 = substIdType env id1
443 -- new_id has the final IdInfo
444 subst = mkCoreSubst env
445 new_id = maybeModifyIdInfo (substIdInfo subst) id2
447 -- Extend the substitution if the unique has changed
448 -- See the notes with substTyVarBndr for the delSubstEnv
449 new_subst | new_id /= old_id
450 = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
452 = delVarEnv id_subst old_id
457 seqTyVar :: TyVar -> ()
458 seqTyVar b = b `seq` ()
461 seqId id = seqType (idType id) `seq`
467 seqIds (id:ids) = seqId id `seq` seqIds ids
471 %************************************************************************
475 %************************************************************************
477 Simplifying let binders
478 ~~~~~~~~~~~~~~~~~~~~~~~
479 Rename the binders if necessary,
482 simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
483 simplNonRecBndr env id
484 = do { let (env1, id1) = substLetIdBndr env id
485 ; seqId id1 `seq` return (env1, id1) }
488 simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
489 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
490 = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
491 ; seqIds ids1 `seq` return (env1, ids1) }
494 substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
495 -> (SimplEnv, OutBinder)
496 -- C.f. CoreSubst.substIdBndr
497 -- Clone Id if necessary, substitute its type
498 -- Return an Id with completely zapped IdInfo
499 -- [addLetIdInfo, below, will restore its IdInfo]
500 -- Augment the subtitution
501 -- if the unique changed, *or*
502 -- if there's interesting occurrence info
504 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
505 = (env { seInScope = in_scope `extendInScopeSet` new_id,
506 seIdSubst = new_subst }, new_id)
508 id1 = uniqAway in_scope old_id
509 id2 = substIdType env id1
510 new_id = setIdInfo id2 vanillaIdInfo
512 -- Extend the substitution if the unique has changed,
513 -- or there's some useful occurrence information
514 -- See the notes with substTyVarBndr for the delSubstEnv
515 occ_info = occInfo (idInfo old_id)
516 new_subst | new_id /= old_id || isFragileOcc occ_info
517 = extendVarEnv id_subst old_id (DoneId new_id occ_info)
519 = delVarEnv id_subst old_id
522 Add IdInfo back onto a let-bound Id
523 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
524 We must transfer the IdInfo of the original binder to the new binder.
525 This is crucial, to preserve
529 etc. To do this we must apply the current substitution,
530 which incorporates earlier substitutions in this very letrec group.
532 NB 1. We do this *before* processing the RHS of the binder, so that
533 its substituted rules are visible in its own RHS.
534 This is important. Manuel found cases where he really, really
535 wanted a RULE for a recursive function to apply in that function's
538 NB 2: We do not transfer the arity (see Subst.substIdInfo)
539 The arity of an Id should not be visible
540 in its own RHS, else we eta-reduce
544 which isn't sound. And it makes the arity in f's IdInfo greater than
545 the manifest arity, which isn't good.
546 The arity will get added later.
548 NB 3: It's important that we *do* transer the loop-breaker OccInfo,
549 because that's what stops the Id getting inlined infinitely, in the body
552 NB 4: does no harm for non-recursive bindings
554 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
559 Here, we'll do postInlineUnconditionally on f, and we must "see" that
560 when substituting in h's RULE.
563 addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
564 addLetIdInfo env in_id out_id
565 = (modifyInScope env out_id final_id, final_id)
567 final_id = out_id `setIdInfo` new_info
568 subst = mkCoreSubst env
569 old_info = idInfo in_id
570 new_info = case substIdInfo subst old_info of
572 Just new_info -> new_info
574 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
579 -- Keep only 'robust' OccInfo
582 -- Seq'ing on the returned IdInfo is enough to cause all the
583 -- substitutions to happen completely
585 substIdInfo subst info
586 | nothing_to_do = Nothing
587 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
588 `setArityInfo` (if keep_arity then old_arity else unknownArity)
589 `setSpecInfo` CoreSubst.substSpec subst old_rules
590 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
591 `setUnfoldingInfo` noUnfolding)
592 -- setSpecInfo does a seq
593 -- setWorkerInfo does a seq
595 nothing_to_do = keep_occ && keep_arity &&
596 isEmptySpecInfo old_rules &&
597 not (workerExists old_wrkr) &&
598 not (hasUnfolding (unfoldingInfo info))
600 keep_occ = not (isFragileOcc old_occ)
601 keep_arity = old_arity == unknownArity
602 old_arity = arityInfo info
603 old_occ = occInfo info
604 old_rules = specInfo info
605 old_wrkr = workerInfo info
608 substIdType :: SimplEnv -> Id -> Id
609 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
610 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
611 | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
612 -- The tyVarsOfType is cheaper than it looks
613 -- because we cache the free tyvars of the type
614 -- in a Note in the id's type itself
619 substUnfolding env NoUnfolding = NoUnfolding
620 substUnfolding env (OtherCon cons) = OtherCon cons
621 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
622 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
626 %************************************************************************
628 Impedence matching to type substitution
630 %************************************************************************
633 substTy :: SimplEnv -> Type -> Type
634 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
635 = Type.substTy (TvSubst in_scope tv_env) ty
637 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
638 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
639 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
640 (TvSubst in_scope' tv_env', tv')
641 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
643 -- When substituting in rules etc we can get CoreSubst to do the work
644 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
645 -- here. I think the this will not usually result in a lot of work;
646 -- the substitutions are typically small, and laziness will avoid work in many cases.
648 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
649 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
650 = mk_subst tv_env id_env
652 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
654 fiddle (DoneEx e) = e
655 fiddle (DoneId v occ) = Var v
656 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
658 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
660 | isEmptySimplSubst env = expr
661 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
665 %************************************************************************
669 %************************************************************************
672 type FloatsWithExpr = FloatsWith OutExpr
673 type FloatsWith a = (Floats, a)
674 -- We return something equivalent to (let b in e), but
675 -- in pieces to avoid the quadratic blowup when floating
676 -- incrementally. Comments just before simplExprB in Simplify.lhs
678 data Floats = Floats (OrdList OutBind)
679 InScopeSet -- Environment "inside" all the floats
680 Bool -- True <=> All bindings are lifted
682 allLifted :: Floats -> Bool
683 allLifted (Floats _ _ is_lifted) = is_lifted
685 wrapFloats :: Floats -> OutExpr -> OutExpr
686 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
688 isEmptyFloats :: Floats -> Bool
689 isEmptyFloats (Floats bs _ _) = isNilOL bs
691 floatBinds :: Floats -> [OutBind]
692 floatBinds (Floats bs _ _) = fromOL bs
694 flattenFloats :: Floats -> Floats
695 -- Flattens into a single Rec group
696 flattenFloats (Floats bs is is_lifted)
697 = ASSERT2( is_lifted, ppr (fromOL bs) )
698 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
702 emptyFloats :: SimplEnv -> Floats
703 emptyFloats env = Floats nilOL (getInScope env) True
705 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
706 -- A single non-rec float; extend the in-scope set
707 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
708 (extendInScopeSet (getInScope env) var)
709 (not (isUnLiftedType (idType var)))
711 addFloats :: SimplEnv -> Floats
712 -> (SimplEnv -> SimplM (FloatsWith a))
713 -> SimplM (FloatsWith a)
714 addFloats env (Floats b1 is1 l1) thing_inside
718 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
719 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
721 addLetBind :: OutBind -> Floats -> Floats
722 addLetBind bind (Floats binds in_scope lifted)
723 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
725 is_lifted_bind (Rec _) = True
726 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
728 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
729 -- * extends the in-scope env
730 -- * assumes it's a let-bindable thing
731 addAuxiliaryBind :: SimplEnv -> OutBind
732 -> (SimplEnv -> SimplM (FloatsWith a))
733 -> SimplM (FloatsWith a)
734 -- Extends the in-scope environment as well as wrapping the bindings
735 addAuxiliaryBind env bind thing_inside
736 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
737 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
738 returnSmpl (addLetBind bind floats, x)