-corePrepTopBinds :: [CoreBind] -> UniqSM Floats
-corePrepTopBinds binds
- = go emptyCorePrepEnv binds
- where
- go env [] = returnUs emptyFloats
- go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
- go env' binds `thenUs` \ binds' ->
- returnUs (bind' `appendFloats` binds')
-
--- NB: we do need to float out of top-level bindings
--- Consider x = length [True,False]
--- We want to get
--- s1 = False : []
--- s2 = True : s1
--- x = length s2
-
--- We return a *list* of bindings, because we may start with
--- x* = f (g y)
--- where x is demanded, in which case we want to finish with
--- a = g y
--- x* = f a
--- And then x will actually end up case-bound
---
--- What happens to the CafInfo on the floated bindings? By
--- default, all the CafInfos will be set to MayHaveCafRefs,
--- which is safe.
---
--- This might be pessimistic, because eg. s1 & s2
--- might not refer to any CAFs and the GC will end up doing
--- more traversal than is necessary, but it's still better
--- than not floating the bindings at all, because then
--- the GC would have to traverse the structure in the heap
--- instead. Given this, we decided not to try to get
--- the CafInfo on the floated bindings correct, because
--- it looks difficult.
-
---------------------------------
-corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
-corePrepTopBind env (NonRec bndr rhs)
- = cloneBndr env bndr `thenUs` \ (env', bndr') ->
- corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
- returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
-
-corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
-
---------------------------------
-corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
- -- This one is used for *local* bindings
-corePrepBind env (NonRec bndr rhs)
- = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
- corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
- cloneBndr env bndr `thenUs` \ (_, bndr') ->
- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
- -- We want bndr'' in the envt, because it records
- -- the evaluated-ness of the binder
- returnUs (extendCorePrepEnv env bndr bndr'', floats')
-
-corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
-
---------------------------------
-corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
- -> [(Id,CoreExpr)] -- Recursive bindings
- -> UniqSM (CorePrepEnv, Floats)
--- Used for all recursive bindings, top level and otherwise
-corePrepRecPairs lvl env pairs
- = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
- mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
- returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
+\begin{code}
+cpeBind :: TopLevelFlag
+ -> CorePrepEnv -> CoreBind
+ -> UniqSM (CorePrepEnv, Floats)
+cpeBind top_lvl env (NonRec bndr rhs)
+ = do { (_, bndr1) <- cloneBndr env bndr
+ ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
+ is_unlifted = isUnLiftedType (idType bndr)
+ ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
+ (is_strict || is_unlifted)
+ env bndr1 rhs
+ ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
+
+ -- We want bndr'' in the envt, because it records
+ -- the evaluated-ness of the binder
+ ; return (extendCorePrepEnv env bndr bndr2,
+ addFloat floats new_float) }
+
+cpeBind top_lvl env (Rec pairs)
+ = do { let (bndrs,rhss) = unzip pairs
+ ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
+ ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
+
+ ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
+ all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+ (concatFloats floats_s)
+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
+ unitFloat (FloatLet (Rec all_pairs))) }