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,
26 SimplSR(..), mkContEx, substId,
28 simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
29 simplBinder, simplBinders,
30 simplIdInfo, substExpr, substTy,
33 FloatsWith, FloatsWithExpr,
34 Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
35 allLifted, wrapFloats, floatBinds,
39 #include "HsVersions.h"
42 import Rules ( RuleBase, emptyRuleBase )
43 import Id ( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding )
44 import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
45 arityInfo, setArityInfo, workerInfo, setWorkerInfo,
46 unfoldingInfo, setUnfoldingInfo,
47 unknownArity, workerExists
50 import CoreUtils ( needsCaseBinding, exprIsTrivial )
51 import PprCore () -- Instances
52 import CostCentre ( CostCentreStack, subsumedCCS )
55 import VarSet ( isEmptyVarSet )
58 import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker )
59 import qualified Type ( substTy, substTyVarBndr )
61 import Type ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType )
62 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
66 import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
67 Activation, isActive, isAlwaysActive,
68 OccInfo(..), isOneOcc, isFragileOcc
70 import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
71 DynFlags, DynFlag(..), dopt,
72 opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
74 import Unique ( Unique )
75 import Util ( mapAccumL )
79 import Maybes ( expectJust )
81 import GLAEXTS ( indexArray# )
83 #if __GLASGOW_HASKELL__ < 503
84 import PrelArr ( Array(..) )
86 import GHC.Arr ( Array(..) )
89 import Array ( array, (//) )
93 %************************************************************************
95 \subsection[Simplify-types]{Type declarations}
97 %************************************************************************
100 type InBinder = CoreBndr
101 type InId = Id -- Not yet cloned
102 type InType = Type -- Ditto
103 type InBind = CoreBind
104 type InExpr = CoreExpr
108 type OutBinder = CoreBndr
109 type OutId = Id -- Cloned
110 type OutTyVar = TyVar -- Cloned
111 type OutType = Type -- Cloned
112 type OutBind = CoreBind
113 type OutExpr = CoreExpr
114 type OutAlt = CoreAlt
115 type OutArg = CoreArg
118 %************************************************************************
120 \subsubsection{The @SimplEnv@ type}
122 %************************************************************************
128 seMode :: SimplifierMode,
129 seChkr :: SwitchChecker,
130 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
132 -- Rules from other modules
133 seExtRules :: RuleBase,
135 -- The current set of in-scope variables
136 -- They are all OutVars, and all bound in this module
137 seInScope :: InScopeSet, -- OutVars only
139 -- The current substitution
140 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
141 seIdSubst :: SimplIdSubst -- InId |--> OutExpr
144 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
147 = DoneEx OutExpr -- Completed term
148 | DoneId OutId OccInfo -- Completed term variable, with occurrence info
149 | ContEx TvSubstEnv -- A suspended substitution
156 The in-scope part of Subst includes *all* in-scope TyVars and Ids
157 The elements of the set may have better IdInfo than the
158 occurrences of in-scope Ids, and (more important) they will
159 have a correctly-substituted type. So we use a lookup in this
160 set to replace occurrences
162 The Ids in the InScopeSet are replete with their Rules,
163 and as we gather info about the unfolding of an Id, we replace
164 it in the in-scope set.
166 The in-scope set is actually a mapping OutVar -> OutVar, and
167 in case expressions we sometimes bind
170 The substitution is *apply-once* only, because InIds and OutIds can overlap.
171 For example, we generally omit mappings
173 from the substitution, when we decide not to clone a77, but it's quite
174 legitimate to put the mapping in the substitution anyway.
176 Indeed, we do so when we want to pass fragile OccInfo to the
177 occurrences of the variable; we add a substitution
178 x77 -> DoneId x77 occ
179 to record x's occurrence information.]
181 Furthermore, consider
182 let x = case k of I# x77 -> ... in
183 let y = case k of I# x77 -> ... in ...
184 and suppose the body is strict in both x and y. Then the simplifier
185 will pull the first (case k) to the top; so the second (case k) will
186 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
189 Of course, the substitution *must* applied! Things in its domain
190 simply aren't necessarily bound in the result.
192 * substId adds a binding (DoneId new_id occ) to the substitution if
193 EITHER the Id's unique has changed
194 OR the Id has interesting occurrence information
195 So in effect you can only get to interesting occurrence information
196 by looking up the *old* Id; it's not really attached to the new id
199 Note, though that the substitution isn't necessarily extended
200 if the type changes. Why not? Because of the next point:
202 * We *always, always* finish by looking up in the in-scope set
203 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
204 Reason: so that we never finish up with a "old" Id in the result.
205 An old Id might point to an old unfolding and so on... which gives a space leak.
207 [The DoneEx and DoneVar hits map to "new" stuff.]
209 * It follows that substExpr must not do a no-op if the substitution is empty.
210 substType is free to do so, however.
212 * When we come to a let-binding (say) we generate new IdInfo, including an
213 unfolding, attach it to the binder, and add this newly adorned binder to
214 the in-scope set. So all subsequent occurrences of the binder will get mapped
215 to the full-adorned binder, which is also the one put in the binding site.
217 * The in-scope "set" usually maps x->x; we use it simply for its domain.
218 But sometimes we have two in-scope Ids that are synomyms, and should
219 map to the same target: x->x, y->x. Notably:
221 That's why the "set" is actually a VarEnv Var
224 Note [GADT type refinement]
225 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
226 When we come to a GADT pattern match that refines the in-scope types, we
227 a) Refine the types of the Ids in the in-scope set, seInScope.
228 For exmaple, consider
230 Foo :: T (Bool -> Bool)
232 (\ (x::T a) (y::a) -> case x of { Foo -> y True }
234 Technically this is well-typed, but exprType will barf on the
235 (y True) unless we refine the type on y's occurrence.
237 b) Refine the range of the type substitution, seTvSubst.
238 Very similar reason to (a).
240 NB: we don't refine the range of the SimplIdSubst, because it's always
241 interpreted relative to the seInScope (see substId)
243 For (b) we need to be a little careful. Specifically, we compose the refinement
244 with the type substitution. Suppose
245 The substitution was [a->b, b->a]
246 and the refinement was [b->Int]
247 Then we want [a->Int, b->a]
250 The substitution was [a->b]
251 and the refinement was [b->Int]
252 Then we want [a->Int, b->Int]
253 becuase b might be both an InTyVar and OutTyVar
257 mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
258 mkSimplEnv mode switches rules
259 = SimplEnv { seChkr = switches, seCC = subsumedCCS,
260 seMode = mode, seInScope = emptyInScopeSet,
262 seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
263 -- The top level "enclosing CC" is "SUBSUMED".
265 ---------------------
266 getSwitchChecker :: SimplEnv -> SwitchChecker
267 getSwitchChecker env = seChkr env
269 ---------------------
270 getMode :: SimplEnv -> SimplifierMode
271 getMode env = seMode env
273 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
274 setMode mode env = env { seMode = mode }
276 ---------------------
277 getEnclosingCC :: SimplEnv -> CostCentreStack
278 getEnclosingCC env = seCC env
280 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
281 setEnclosingCC env cc = env {seCC = cc}
283 ---------------------
284 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
285 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
286 = env {seIdSubst = extendVarEnv subst var res}
288 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
289 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
290 = env {seTvSubst = extendVarEnv subst var res}
292 ---------------------
293 getInScope :: SimplEnv -> InScopeSet
294 getInScope env = seInScope env
296 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
297 setInScopeSet env in_scope = env {seInScope = in_scope}
299 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
300 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
302 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
303 -- The new Ids are guaranteed to be freshly allocated
304 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
305 = env { seInScope = in_scope `extendInScopeSetList` vs,
306 seIdSubst = id_subst `delVarEnvList` vs } -- Why delete?
308 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
309 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
310 = env {seInScope = modifyInScopeSet in_scope v v'}
312 ---------------------
313 zapSubstEnv :: SimplEnv -> SimplEnv
314 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
316 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
317 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
319 mkContEx :: SimplEnv -> InExpr -> SimplSR
320 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
322 isEmptySimplSubst :: SimplEnv -> Bool
323 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
324 = isEmptyVarEnv tvs && isEmptyVarEnv ids
326 ---------------------
327 getRules :: SimplEnv -> RuleBase
328 getRules = seExtRules
332 %************************************************************************
336 %************************************************************************
340 substId :: SimplEnv -> Id -> SimplSR
341 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
344 | otherwise -- A local Id
345 = case lookupVarEnv ids v of
346 Just (DoneId v occ) -> DoneId (refine v) occ
348 Nothing -> let v' = refine v
349 in DoneId v' (idOccInfo v')
350 -- We don't put LoopBreakers in the substitution (unless then need
351 -- to be cloned for name-clash rasons), so the idOccInfo is
352 -- very important! If isFragileOcc returned True for
353 -- loop breakers we could avoid this call, but at the expense
354 -- of adding more to the substitution, and building new Ids
355 -- a bit more often than really necessary
357 -- Get the most up-to-date thing from the in-scope set
358 -- Even though it isn't in the substitution, it may be in
359 -- the in-scope set with a different type (we only use the
360 -- substitution if the unique changes).
361 refine v = case lookupInScope in_scope v of
363 Nothing -> WARN( True, ppr v ) v -- This is an error!
368 %************************************************************************
370 \section{Substituting an Id binder}
372 %************************************************************************
375 These functions are in the monad only so that they can be made strict via seq.
378 simplBinders, simplLamBndrs, simplLetBndrs
379 :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
380 simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
381 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
382 simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs
385 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
386 -- Used for lambda and case-bound variables
387 -- Clone Id if necessary, substitute type
388 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
389 -- The substitution is extended only if the variable is cloned, because
390 -- we *don't* need to use it to track occurrence info.
392 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
393 ; seqTyVar tv `seq` return (env', tv) }
394 | otherwise = do { let (env', id) = substIdBndr False env env bndr
395 ; seqId id `seq` return (env', id) }
398 simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
399 simplLetBndr env id = do { let (env', id') = substLetId env id
400 ; seqId id' `seq` return (env', id') }
403 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
404 -- Used for lambda binders. These sometimes have unfoldings added by
405 -- the worker/wrapper pass that must be preserved, becuase they can't
406 -- be reconstructed from context. For example:
407 -- f x = case x of (a,b) -> fw a b x
408 -- fw a b x{=(a,b)} = ...
409 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
410 simplLamBndr env bndr
411 | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
412 | otherwise = seqId id2 `seq` return (env', id2)
414 old_unf = idUnfolding bndr
415 (env', id1) = substIdBndr False env env bndr
416 id2 = id1 `setIdUnfolding` substUnfolding env old_unf
419 seqTyVar :: TyVar -> ()
420 seqTyVar b = b `seq` ()
423 seqId id = seqType (idType id) `seq`
429 -- substBndr and friends are used when doing expression substitution only
430 -- In this case we can *preserve* occurrence information, and indeed we *want*
431 -- to do so else lose useful occ info in rules.
433 substBndr :: SimplEnv -> Var -> (SimplEnv, Var)
435 | isTyVar bndr = substTyVarBndr subst bndr
436 | otherwise = substIdBndr True {- keep fragile info -} subst subst bndr
438 substBndrs :: SimplEnv -> [Var] -> (SimplEnv, [Var])
439 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
441 substRecBndrs :: SimplEnv -> [Id] -> (SimplEnv, [Id])
442 -- Substitute a mutually recursive group
443 substRecBndrs subst bndrs
444 = (new_subst, new_bndrs)
446 -- Here's the reason we need to pass rec_subst to substIdBndr
447 (new_subst, new_bndrs) = mapAccumL (substIdBndr True {- keep fragile info -} new_subst)
453 substIdBndr :: Bool -- True <=> keep fragile info
454 -> SimplEnv -- Substitution to use for the IdInfo
455 -> SimplEnv -> Id -- Substitition and Id to transform
456 -> (SimplEnv, Id) -- Transformed pair
459 -- * Unique changed if necessary
460 -- * Type substituted
461 -- * Unfolding zapped
462 -- * Rules, worker, lbvar info all substituted
463 -- * Occurrence info zapped if is_fragile_occ returns True
464 -- * The in-scope set extended with the returned Id
465 -- * The substitution extended with a DoneId if unique changed
466 -- In this case, the var in the DoneId is the same as the
469 substIdBndr keep_fragile rec_env
470 env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
472 = (env { seInScope = in_scope `extendInScopeSet` new_id,
473 seIdSubst = new_subst }, new_id)
475 -- id1 is cloned if necessary
476 id1 = uniqAway in_scope old_id
478 -- id2 has its type zapped
479 id2 = substIdType env id1
481 -- new_id has the right IdInfo
482 -- The lazy-set is because we're in a loop here, with
483 -- rec_env, when dealing with a mutually-recursive group
484 new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_env) id2
486 -- Extend the substitution if the unique has changed
487 -- See the notes with substTyVarBndr for the delSubstEnv
488 new_subst | new_id /= old_id
489 = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
491 = delVarEnv id_subst old_id
493 substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
494 -- A variant for let-bound Ids
495 -- Clone Id if necessary
496 -- Substitute its type
497 -- Return an Id with completely zapped IdInfo
498 -- [A subsequent substIdInfo will restore its IdInfo]
499 -- Augment the subtitution
500 -- if the unique changed, *or*
501 -- if there's interesting occurrence info
503 substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
504 = (env { seInScope = in_scope `extendInScopeSet` new_id,
505 seIdSubst = new_subst }, new_id)
507 old_info = idInfo old_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 old_info
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
523 %************************************************************************
525 Impedence matching to type substitution
527 %************************************************************************
530 substTy :: SimplEnv -> Type -> Type
531 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
532 = Type.substTy (TvSubst in_scope tv_env) ty
534 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
535 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
536 = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
537 (TvSubst in_scope' tv_env', tv')
538 -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
540 -- When substituting in rules etc we can get CoreSubst to do the work
541 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
542 -- here. I think the this will not usually result in a lot of work;
543 -- the substitutions are typically small, and laziness will avoid work in many cases.
545 mkCoreSubst :: SimplEnv -> CoreSubst.Subst
546 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
547 = mk_subst tv_env id_env
549 mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
551 fiddle (DoneEx e) = e
552 fiddle (DoneId v occ) = Var v
553 fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
555 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
557 | isEmptySimplSubst env = expr
558 | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
562 %************************************************************************
564 \section{IdInfo substitution}
566 %************************************************************************
569 simplIdInfo :: SimplEnv -> IdInfo -> IdInfo
570 -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
571 -- subsequent to simplLetId having zapped its IdInfo
572 simplIdInfo env old_info
573 = case substIdInfo False env old_info of
574 Just new_info -> new_info
577 substIdInfo :: Bool -- True <=> keep even fragile info
581 -- The keep_fragile flag is True when we are running a simple expression
582 -- substitution that preserves all structure, so that arity and occurrence
583 -- info are unaffected. The False state is used more often.
589 -- If keep_fragile then
593 -- keep only 'robust' OccInfo
596 -- Seq'ing on the returned IdInfo is enough to cause all the
597 -- substitutions to happen completely
599 substIdInfo keep_fragile env info
600 | nothing_to_do = Nothing
601 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
602 `setArityInfo` (if keep_arity then old_arity else unknownArity)
603 `setSpecInfo` CoreSubst.substRules subst old_rules
604 `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
605 `setUnfoldingInfo` noUnfolding)
606 -- setSpecInfo does a seq
607 -- setWorkerInfo does a seq
609 subst = mkCoreSubst env
610 nothing_to_do = keep_occ && keep_arity &&
611 isEmptyCoreRules old_rules &&
612 not (workerExists old_wrkr) &&
613 not (hasUnfolding (unfoldingInfo info))
615 keep_occ = keep_fragile || not (isFragileOcc old_occ)
616 keep_arity = keep_fragile || old_arity == unknownArity
617 old_arity = arityInfo info
618 old_occ = occInfo info
619 old_rules = specInfo info
620 old_wrkr = workerInfo info
623 substIdType :: SimplEnv -> Id -> Id
624 substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
625 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
626 | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
627 -- The tyVarsOfType is cheaper than it looks
628 -- because we cache the free tyvars of the type
629 -- in a Note in the id's type itself
634 substUnfolding env NoUnfolding = NoUnfolding
635 substUnfolding env (OtherCon cons) = OtherCon cons
636 substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
637 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
641 %************************************************************************
645 %************************************************************************
648 type FloatsWithExpr = FloatsWith OutExpr
649 type FloatsWith a = (Floats, a)
650 -- We return something equivalent to (let b in e), but
651 -- in pieces to avoid the quadratic blowup when floating
652 -- incrementally. Comments just before simplExprB in Simplify.lhs
654 data Floats = Floats (OrdList OutBind)
655 InScopeSet -- Environment "inside" all the floats
656 Bool -- True <=> All bindings are lifted
658 allLifted :: Floats -> Bool
659 allLifted (Floats _ _ is_lifted) = is_lifted
661 wrapFloats :: Floats -> OutExpr -> OutExpr
662 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
664 isEmptyFloats :: Floats -> Bool
665 isEmptyFloats (Floats bs _ _) = isNilOL bs
667 floatBinds :: Floats -> [OutBind]
668 floatBinds (Floats bs _ _) = fromOL bs
670 flattenFloats :: Floats -> Floats
671 -- Flattens into a single Rec group
672 flattenFloats (Floats bs is is_lifted)
673 = ASSERT2( is_lifted, ppr (fromOL bs) )
674 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
678 emptyFloats :: SimplEnv -> Floats
679 emptyFloats env = Floats nilOL (getInScope env) True
681 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
682 -- A single non-rec float; extend the in-scope set
683 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
684 (extendInScopeSet (getInScope env) var)
685 (not (isUnLiftedType (idType var)))
687 addFloats :: SimplEnv -> Floats
688 -> (SimplEnv -> SimplM (FloatsWith a))
689 -> SimplM (FloatsWith a)
690 addFloats env (Floats b1 is1 l1) thing_inside
694 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
695 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
697 addLetBind :: OutBind -> Floats -> Floats
698 addLetBind bind (Floats binds in_scope lifted)
699 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
701 is_lifted_bind (Rec _) = True
702 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
704 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
705 -- * extends the in-scope env
706 -- * assumes it's a let-bindable thing
707 addAuxiliaryBind :: SimplEnv -> OutBind
708 -> (SimplEnv -> SimplM (FloatsWith a))
709 -> SimplM (FloatsWith a)
710 -- Extends the in-scope environment as well as wrapping the bindings
711 addAuxiliaryBind env bind thing_inside
712 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
713 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
714 returnSmpl (addLetBind bind floats, x)