+
+%************************************************************************
+%* *
+\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
+ NonRec x# (a /# b) FltCareful
+ NonRec x* (f y) FltCareful -- Might fail or diverge
+ NonRec x# (f y) FltCareful -- 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
+
+canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool
+canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff})
+ = canFloatFlt lvl rec str ff
+
+canFloatFlt :: TopLevelFlag -> RecFlag -> Bool -> FloatFlag -> Bool
+canFloatFlt lvl rec str FltLifted = True
+canFloatFlt lvl rec str FltOkSpec = isNotTopLevel lvl && isNonRec rec
+canFloatFlt lvl rec str FltCareful = str && isNotTopLevel lvl && isNonRec rec
+\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 }
+
+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
+\end{code}
+
+