-
-%************************************************************************
-%* *
-\subsection{Floats}
-%* *
-%************************************************************************
-
-\begin{code}
-type FloatsWithExpr = FloatsWith OutExpr
-type FloatsWith a = (Floats, a)
- -- We return something equivalent to (let b in e), but
- -- in pieces to avoid the quadratic blowup when floating
- -- incrementally. Comments just before simplExprB in Simplify.lhs
-
-data Floats = Floats (OrdList OutBind)
- InScopeSet -- Environment "inside" all the floats
- Bool -- True <=> All bindings are lifted
-
-allLifted :: Floats -> Bool
-allLifted (Floats _ _ is_lifted) = is_lifted
-
-wrapFloats :: Floats -> OutExpr -> OutExpr
-wrapFloats (Floats bs _ _) body = foldrOL Let body bs
-
-isEmptyFloats :: Floats -> Bool
-isEmptyFloats (Floats bs _ _) = isNilOL bs
-
-floatBinds :: Floats -> [OutBind]
-floatBinds (Floats bs _ _) = fromOL bs
-
-flattenFloats :: Floats -> Floats
--- Flattens into a single Rec group
-flattenFloats (Floats bs is is_lifted)
- = ASSERT2( is_lifted, ppr (fromOL bs) )
- Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
-\end{code}
-
-\begin{code}
-emptyFloats :: SimplEnv -> Floats
-emptyFloats env = Floats nilOL (getInScope env) True
-
-unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
--- A single non-rec float; extend the in-scope set
-unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
- (extendInScopeSet (getInScope env) var)
- (not (isUnLiftedType (idType var)))
-
-addFloats :: SimplEnv -> Floats
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
-addFloats env (Floats b1 is1 l1) thing_inside
- | isNilOL b1
- = thing_inside env
- | otherwise
- = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
- returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
-
-addLetBind :: OutBind -> Floats -> Floats
-addLetBind bind (Floats binds in_scope lifted)
- = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
-
-is_lifted_bind (Rec _) = True
-is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
-
--- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
--- * extends the in-scope env
--- * assumes it's a let-bindable thing
-addAuxiliaryBind :: SimplEnv -> OutBind
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind env bind thing_inside
- = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
- thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
- returnSmpl (addLetBind bind floats, x)
-\end{code}
-
-