- incd_lvl = incMinorLvl lvl
-
- partition_fn = partitionByMajorLevel
-
-{- OMITTED
- We don't want to be too keen about floating lets out of case alternatives
- because they may benefit from seeing the evaluation done by the case.
-
- The main reason for doing this is to allocate in fewer larger blocks
- but that's really an STG-level issue.
-
- case alts of
- -- Just one alternative, then dump only
- -- what *has* to be dumped
- AlgAlts [_] NoDefault -> partitionByLevel
- AlgAlts [] (BindDefault _ _) -> partitionByLevel
- PrimAlts [_] NoDefault -> partitionByLevel
- PrimAlts [] (BindDefault _ _) -> partitionByLevel
-
- -- If there's more than one alternative, then
- -- this is a dumping point
- other -> partitionByMajorLevel
--}
-
- float_alts (AlgAlts alts deflt)
- = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
- case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
- (foldr add_stats fsd fsas,
- concat fdas ++ fdd,
- AlgAlts alts' deflt') }}
-
- float_alts (PrimAlts alts deflt)
- = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
- case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
- (foldr add_stats fsd fsas,
- concat fdas ++ fdd,
- PrimAlts alts' deflt') }}
-
- -------------
- float_alg_alt (con, bs, rhs)
- = let
- bs' = map fst bs
- new_env = growIdEnvList env bs
- in
- case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', (con, bs', install heres rhs')) }}
-
- --------------
- float_prim_alt (lit, rhs)
- = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', (lit, install heres rhs')) }}
-
- --------------
- float_deflt NoDefault = (zero_stats, [], NoDefault)
-
- float_deflt (BindDefault (b,lvl) rhs)
- = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', BindDefault b (install heres rhs')) }}
- where
- new_env = addOneToIdEnv env b lvl
+ -- Use floatRhs for the alternatives, so that we
+ -- don't gratuitiously float bindings out of the RHSs
+ float_alt (con, bs, rhs)
+ = case (floatRhs case_lvl rhs) of { (fs, rhs_floats, rhs') ->
+ (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
+
+
+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
+floatList f [] = (zeroStats, [], [])
+floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
+ case floatList f as of { (fs_as, binds_as, bs) ->
+ (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }}