[project @ 2003-08-20 18:48:20 by sof]

[ghc-hetmet.git] / ghc / compiler / simplCore / FloatOut.lhs

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index a1cb821..c598b4a 100644 (file)
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -18,10 +18,12 @@ import ErrUtils             ( dumpIfSet_dyn )
 import CostCentre      ( dupifyCC, CostCentre )
 import Id              ( Id )
 import CoreLint                ( showPass, endPass )
-import SetLevels       ( setLevels, Level(..), ltMajLvl, ltLvl, isTopLvl )
+import SetLevels       ( Level(..), LevelledExpr, LevelledBind,
+                         setLevels, ltMajLvl, ltLvl, isTopLvl )
 import UniqSupply       ( UniqSupply )
 import List            ( partition )
 import Outputable
+import Util             ( notNull )
 \end{code}
 
        -----------------
@@ -97,8 +99,6 @@ vwhich might usefully be separated to
 Well, maybe.  We don't do this at the moment.
 
 \begin{code}
-type LevelledExpr  = TaggedExpr Level
-type LevelledBind  = TaggedBind Level
 type FloatBind     = (Level, CoreBind)
 type FloatBinds    = [FloatBind]
 \end{code}
@@ -150,7 +150,7 @@ floatTopBind bind@(NonRec _ _)
 
 floatTopBind bind@(Rec _)
   = case (floatBind bind) of { (fs, floats, Rec pairs') ->
-    WARN( not (null floats), ppr bind $$ ppr floats )
+    WARN( notNull floats, ppr bind $$ ppr floats )
     (fs, [Rec (floatsToBindPairs floats ++ pairs')]) }
 \end{code}
 
@@ -165,7 +165,7 @@ floatTopBind bind@(Rec _)
 floatBind :: LevelledBind
          -> (FloatStats, FloatBinds, CoreBind)
 
-floatBind (NonRec (name,level) rhs)
+floatBind (NonRec (TB name level) rhs)
   = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
     (fs, rhs_floats, NonRec name rhs') }
 
@@ -198,7 +198,7 @@ floatBind bind@(Rec pairs)
   where
     bind_level = getBindLevel bind
 
-    do_pair ((name, level), rhs)
+    do_pair (TB name level, rhs)
       = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
        (fs, rhs_floats, (name, rhs'))
        }
@@ -241,7 +241,8 @@ floatExpr lvl (App e a)
 floatExpr lvl lam@(Lam _ _)
   = let
        (bndrs_w_lvls, body) = collectBinders lam
-       (bndrs, lvls)        = unzip bndrs_w_lvls
+       bndrs                = [b | TB b _ <- bndrs_w_lvls]
+       lvls                 = [l | TB b 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
@@ -283,9 +284,12 @@ floatExpr lvl (Note note@(SCC cc) expr)
 
 floatExpr lvl (Note InlineMe expr)     -- Other than SCCs
   = case floatExpr InlineCtxt expr of { (fs, floating_defns, expr') ->
-    WARN( not (null floating_defns),
-         ppr expr $$ ppr floating_defns )      -- We do no floating out of Inlines
-    (fs, [], Note InlineMe expr') }    -- See notes in SetLevels
+       -- There can be some floating_defns, arising from
+       -- ordinary lets that were there all the time.  It seems
+       -- more efficient to test once here than to avoid putting
+       -- them into floating_defns (which would mean testing for
+       -- inlineCtxt  at every let)
+    (fs, [], Note InlineMe (install floating_defns expr')) }   -- See notes in SetLevels
 
 floatExpr lvl (Note note expr) -- Other than SCCs
   = case (floatExpr lvl expr)    of { (fs, floating_defns, expr') ->
@@ -305,7 +309,7 @@ floatExpr lvl (Let bind body)
   where
     bind_lvl = getBindLevel bind
 
-floatExpr lvl (Case scrut (case_bndr, case_lvl) alts)
+floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts)
   = case floatExpr lvl scrut   of { (fse, fde, scrut') ->
     case floatList float_alt alts      of { (fsa, fda, alts')  ->
     (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
@@ -315,7 +319,7 @@ floatExpr lvl (Case scrut (case_bndr, case_lvl) alts)
        -- 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, map fst bs, rhs')) }
+         (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
 
 
 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
@@ -365,8 +369,8 @@ add_to_stats (FlS a b c) floats
 %************************************************************************
 
 \begin{code}
-getBindLevel (NonRec (_, lvl) _)      = lvl
-getBindLevel (Rec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (TB _ lvl) _)      = lvl
+getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
 \end{code}
 
 \begin{code}