-
-corePrepBind top_lvl env (NonRec bndr rhs)
- = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
- cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkNonRec top_lvl bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
- returnUs (env', floats')
-
-corePrepBind top_lvl env (Rec pairs)
- -- Don't bother to try to float bindings out of RHSs
- -- (compare mkNonRec, which does try)
- = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
- mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
- returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
+--
+-- 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'))))