Fix a long-standing bug the float-out pass

We were failing to float out a binding that could be floated,
because of a confusion in the Lam case of floatExpr.

In investigating this I also discoverd that there is really
no point at all in giving a different level to variables in
a binding group, so I've now given them all the same (in
SetLevels.lvlLamBndrs

The overall difference is quite minor in a nofib run:

        Program           Size    Allocs   Runtime   Elapsed
-------------------------------------------------------------
            Min          +0.0%     -8.5%    -28.4%    -28.7%
            Max          +0.0%     +0.7%     -0.7%     -1.1%
 Geometric Mean          +0.0%     -0.0%    -11.6%    -11.8%

I don't trust those runtimes, but smaller is good!  The 8.5%
improvement in allocation in fulsom, and seems real.  The
0.7% allocation increase only happens in programs with
very small allocation.  I tracked one down to a call of this form

  GHC.IO.Handle.Internals.mkDuplexHandle5
    = \ args -> GHC.IO.Handle.Internals.openTextEncoding1
                  mb_codec ha_type
                  (\mb_encoder mb_decoder -> blah)

With the new floater the argument of openTextEncoding1 becomes

     (let lvl = .. in \mb_encoder mb_decoder -> blah)

And rightly so.  However in fact this argument is a continuation
and hence is called once, so the floating is fruitless.

Roll on one-shot-function analysis (which I know how to do
but fail to get to!).

diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index fba88e7..2a51a21 100644 (file)
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -24,9 +24,11 @@ import UniqSupply       ( UniqSupply )
 import Bag
 import Util
 import Maybes
-import UniqFM
 import Outputable
 import FastString
+import qualified Data.IntMap as M
+
+#include "HsVersions.h"
 \end{code}
 
        -----------------
@@ -230,27 +232,20 @@ floatExpr lvl (App e a)
     case (floatRhs lvl a)      of { (fsa, floats_a, a') ->
     (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
 
-floatExpr _ lam@(Lam _ _)
-  = let
-       (bndrs_w_lvls, body) = collectBinders lam
+floatExpr _ lam@(Lam (TB _ lam_lvl) _)
+  = let (bndrs_w_lvls, body) = collectBinders lam
        bndrs                = [b | TB b _ <- bndrs_w_lvls]
-       lvls                 = [l | TB _ l <- bndrs_w_lvls]
-
-       -- For the all-tyvar case we are prepared to pull 
-       -- the lets out, to implement the float-out-of-big-lambda
-       -- transform; but otherwise we only float bindings that are
-       -- going to escape a value lambda.
-       -- In particular, for one-shot lambdas we don't float things
-       -- out; we get no saving by so doing.
-       partition_fn | all isTyCoVar bndrs = partitionByLevel
-                    | otherwise         = partitionByMajorLevel
+       -- All the binders have the same level
+       -- See SetLevels.lvlLamBndrs
     in
-    case (floatExpr (last lvls) body) of { (fs, floats, body') ->
-
-       -- Dump any bindings which absolutely cannot go any further
-    case (partition_fn (head lvls) floats)     of { (floats', heres) ->
-
-    (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
+    case (floatExpr lam_lvl body) of { (fs, floats, body1) ->
+
+        -- Dump anything that is captured by this lambda
+       -- Eg  \x -> ...(\y -> let v = <blah> in ...)...
+       -- We'll have the binding (v = <blah>) in the floats,
+       -- but must dump it at the lambda-x
+    case (partitionByLevel lam_lvl floats)     of { (floats1, heres) ->
+    (add_to_stats fs floats1, floats1, mkLams bndrs (install heres body1))
     }}
 
 floatExpr lvl (Note note@(SCC cc) expr)
@@ -401,34 +396,39 @@ data FloatBinds  = FB !(Bag FloatBind)            -- Destined for top level
                      !MajorEnv                 -- Levels other than top
      -- See Note [Representation of FloatBinds]
 
-type MajorEnv = UniqFM MinorEnv                        -- Keyed by major level
-type MinorEnv = UniqFM (Bag FloatBind)         -- Keyed by minor level
+instance Outputable FloatBinds where
+  ppr (FB fbs env) = ptext (sLit "FB") <+> (braces $ vcat
+                       [ ptext (sLit "binds =") <+> ppr fbs
+                       , ptext (sLit "env =") <+> ppr env ])
+
+type MajorEnv = M.IntMap MinorEnv                      -- Keyed by major level
+type MinorEnv = M.IntMap (Bag FloatBind)               -- Keyed by minor level
 
 flattenFloats :: FloatBinds -> Bag FloatBind
 flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
 
 flattenMajor :: MajorEnv -> Bag FloatBind
-flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag
+flattenMajor = M.fold (unionBags . flattenMinor) emptyBag
 
 flattenMinor :: MinorEnv -> Bag FloatBind
-flattenMinor = foldUFM unionBags emptyBag
+flattenMinor = M.fold unionBags emptyBag
 
 emptyFloats :: FloatBinds
-emptyFloats = FB emptyBag emptyUFM
+emptyFloats = FB emptyBag M.empty
 
 unitFloat :: Level -> FloatBind -> FloatBinds
 unitFloat lvl@(Level major minor) b 
-  | isTopLvl lvl = FB (unitBag b) emptyUFM
-  | otherwise    = FB emptyBag (unitUFM major (unitUFM minor (unitBag b)))
+  | isTopLvl lvl = FB (unitBag b) M.empty
+  | otherwise    = FB emptyBag (M.singleton major (M.singleton minor (unitBag b)))
 
 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
 plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
 
 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
-plusMajor = plusUFM_C plusMinor
+plusMajor = M.unionWith plusMinor
 
 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
-plusMinor = plusUFM_C unionBags
+plusMinor = M.unionWith unionBags
 
 floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 floatsToBindPairs floats binds = foldrBag add binds floats
@@ -460,26 +460,26 @@ partitionByMajorLevel, partitionByLevel
 partitionByMajorLevel (Level major _) (FB tops defns)
   = (FB tops outer, heres `unionBags` flattenMajor inner)
   where
-    (outer, mb_heres, inner) = splitUFM defns major
+    (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` unitUFM major outer_min),
+  = (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) = splitUFM defns major
+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
     (outer_min, mb_here_min, inner_min) = case mb_here_maj of
-                                            Nothing -> (emptyUFM, Nothing, emptyUFM)
-                                            Just min_defns -> splitUFM min_defns minor
+                                            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) (mapUFM (mapUFM wrap_defns) defns)
+  = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns)
   where
     wrap_defns = mapBag wrap_one 
     wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index ebfc27e..c684e7d 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -671,26 +671,15 @@ lvlLamBndrs lvl []
   = (lvl, [])
 
 lvlLamBndrs lvl bndrs
-  = go  (incMinorLvl lvl)
-       False   -- Havn't bumped major level in this group
-       [] bndrs
+  = (new_lvl, [TB bndr new_lvl | bndr <- bndrs])
+  -- All the new binders get the same level, because
+  -- any floating binding is either going to float past 
+  -- all or none.  We never separate binders
   where
-    go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
-       | isId bndr &&                  -- Go to the next major level if this is a value binder,
-         not bumped_major &&           -- and we havn't already gone to the next level (one jump per group)
-         not (isOneShotLambda bndr)    -- and it isn't a one-shot lambda
-       = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
+    new_lvl | any is_major bndrs = incMajorLvl lvl
+            | otherwise          = incMinorLvl lvl
 
-       | otherwise
-       = go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs
-
-       where
-         new_lvl = incMajorLvl old_lvl
-
-    go old_lvl _ rev_lvld_bndrs []
-       = (old_lvl, reverse rev_lvld_bndrs)
-       -- a lambda like this (\x -> coerce t (\s -> ...))
-       -- This happens quite a bit in state-transformer programs
+    is_major bndr = isId bndr && not (isOneShotLambda bndr)
 \end{code}
 
 \begin{code}