-\begin{code}
-wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
-wrapFloats binds body = foldOL Let body binds
-
-returnOutStuff :: a -> SimplM (OutStuff a)
-returnOutStuff x = getInScope `thenSmpl` \ in_scope ->
- returnSmpl (nilOL, (in_scope, x))
-
-addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addFloats floats in_scope thing_inside
- = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) ->
- returnSmpl (floats `appOL` binds, res)
-
-addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBind bind thing_inside
- = thing_inside `thenSmpl` \ (binds, res) ->
- returnSmpl (bind `consOL` binds, res)
-
-addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBinds binds1 thing_inside
- = thing_inside `thenSmpl` \ (binds2, res) ->
- returnSmpl (toOL binds1 `appOL` binds2, res)
-
-addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBinds binds1 thing_inside
- = addNewInScopeIds (bindersOfBinds binds1) $
- addLetBinds binds1 thing_inside
-
-addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind bind thing_inside
- = addNewInScopeIds (bindersOf bind) $
- addLetBind bind thing_inside
-
-needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
- -- Make a case expression instead of a let
- -- These can arise either from the desugarer,
- -- or from beta reductions: (\x.e) (x +# y)
-
-addCaseBind bndr rhs thing_inside
- = thing_inside `thenSmpl` \ (floats, (_, body)) ->
- returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
-
-addNonRecBind bndr rhs thing_inside
- -- Checks for needing a case binding
- | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
- | otherwise = addLetBind (NonRec bndr rhs) thing_inside