+
+
+%************************************************************************
+%* *
+\subsection{Floats}
+%* *
+%************************************************************************
+
+Note [Simplifier floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The Floats is a bunch of bindings, classified by a FloatFlag.
+
+ NonRec x (y:ys) FltLifted
+ Rec [(x,rhs)] FltLifted
+
+ NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
+
+ NonRec x# (a /# b) FltCareful
+ NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
+ NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge
+ -- (where f :: Int -> Int#)
+
+\begin{code}
+data Floats = Floats (OrdList OutBind) FloatFlag
+ -- See Note [Simplifier floats]
+
+data FloatFlag
+ = FltLifted -- All bindings are lifted and lazy
+ -- Hence ok to float to top level, or recursive
+
+ | FltOkSpec -- All bindings are FltLifted *or*
+ -- strict (perhaps because unlifted,
+ -- perhaps because of a strict binder),
+ -- *and* ok-for-speculation
+ -- Hence ok to float out of the RHS
+ -- of a lazy non-recursive let binding
+ -- (but not to top level, or into a rec group)
+
+ | FltCareful -- At least one binding is strict (or unlifted)
+ -- and not guaranteed cheap
+ -- Do not float these bindings out of a lazy let
+
+instance Outputable Floats where
+ ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
+
+instance Outputable FloatFlag where
+ ppr FltLifted = ptext SLIT("FltLifted")
+ ppr FltOkSpec = ptext SLIT("FltOkSpec")
+ ppr FltCareful = ptext SLIT("FltCareful")
+
+andFF :: FloatFlag -> FloatFlag -> FloatFlag
+andFF FltCareful _ = FltCareful
+andFF FltOkSpec FltCareful = FltCareful
+andFF FltOkSpec flt = FltOkSpec
+andFF FltLifted flt = flt
+
+classifyFF :: CoreBind -> FloatFlag
+classifyFF (Rec _) = FltLifted
+classifyFF (NonRec bndr rhs)
+ | not (isStrictId bndr) = FltLifted
+ | exprOkForSpeculation rhs = FltOkSpec
+ | otherwise = FltCareful
+
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
+ = not (isNilOL fs) && want_to_float && can_float
+ where
+ want_to_float = isTopLevel lvl || exprIsCheap rhs
+ can_float = case ff of
+ FltLifted -> True
+ FltOkSpec -> isNotTopLevel lvl && isNonRec rec
+ FltCareful -> isNotTopLevel lvl && isNonRec rec && str
+\end{code}
+
+
+\begin{code}
+emptyFloats :: Floats
+emptyFloats = Floats nilOL FltLifted
+
+unitFloat :: OutBind -> Floats
+-- A single-binding float
+unitFloat bind = Floats (unitOL bind) (classifyFF bind)
+
+addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+-- Add a non-recursive binding and extend the in-scope set
+-- The latter is important; the binder may already be in the
+-- in-scope set (although it might also have been created with newId)
+-- but it may now have more IdInfo
+addNonRec env id rhs
+ = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
+ seInScope = extendInScopeSet (seInScope env) id }
+
+extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
+-- Add these bindings to the floats, and extend the in-scope env too
+extendFloats env binds
+ = env { seFloats = seFloats env `addFlts` new_floats,
+ seInScope = extendInScopeSetList (seInScope env) bndrs }
+ where
+ bndrs = bindersOfBinds binds
+ new_floats = Floats (toOL binds)
+ (foldr (andFF . classifyFF) FltLifted binds)
+
+addFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Add the floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addFloats env1 env2
+ = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
+ seInScope = seInScope env2 }
+
+addFlts :: Floats -> Floats -> Floats
+addFlts (Floats bs1 l1) (Floats bs2 l2)
+ = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+zapFloats :: SimplEnv -> SimplEnv
+zapFloats env = env { seFloats = emptyFloats }
+
+addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Flattens the floats from env2 into a single Rec group,
+-- prepends the floats from env1, and puts the result back in env2
+-- This is all very specific to the way recursive bindings are
+-- handled; see Simplify.simplRecBind
+addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
+ = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
+ env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
+
+wrapFloats :: SimplEnv -> OutExpr -> OutExpr
+wrapFloats env expr = wrapFlts (seFloats env) expr
+
+wrapFlts :: Floats -> OutExpr -> OutExpr
+-- Wrap the floats around the expression, using case-binding where necessary
+wrapFlts (Floats bs _) body = foldrOL wrap body bs
+ where
+ wrap (Rec prs) body = Let (Rec prs) body
+ wrap (NonRec b r) body = bindNonRec b r body
+
+getFloats :: SimplEnv -> [CoreBind]
+getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
+
+isEmptyFloats :: SimplEnv -> Bool
+isEmptyFloats env = isEmptyFlts (seFloats env)
+
+isEmptyFlts :: Floats -> Bool
+isEmptyFlts (Floats bs _) = isNilOL bs
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _) = fromOL bs