+ = foldrBag install_group expr defn_groups
+ where
+ install_group defns body = Let defns body
+
+partitionByMajorLevel, partitionByLevel
+ :: Level -- Partitioning level
+ -> FloatBinds -- Defns to be divided into 2 piles...
+ -> (FloatBinds, -- Defns with level strictly < partition level,
+ Bag FloatBind) -- The rest
+
+-- ---- partitionByMajorLevel ----
+-- Float it if we escape a value lambda, *or* if we get to the top level
+-- If we can get to the top level, say "yes" anyway. This means that
+-- x = f e
+-- transforms to
+-- lvl = e
+-- x = f lvl
+-- which is as it should be
+
+partitionByMajorLevel (Level major _) (FB tops defns)
+ = (FB tops outer, heres `unionBags` flattenMajor inner)
+ where
+ (outer, mb_heres, inner) = M.splitLookup major defns
+ heres = case mb_heres of
+ Nothing -> emptyBag
+ Just h -> flattenMinor h
+
+partitionByLevel (Level major minor) (FB tops defns)
+ = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),
+ here_min `unionBags` flattenMinor inner_min
+ `unionBags` flattenMajor inner_maj)
+
+ where
+ (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
+ (outer_min, mb_here_min, inner_min) = case mb_here_maj of
+ Nothing -> (M.empty, Nothing, M.empty)
+ Just min_defns -> M.splitLookup minor min_defns
+ here_min = mb_here_min `orElse` emptyBag
+
+wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
+wrapCostCentre cc (FB tops defns)
+ = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns)