X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatOut.lhs;h=c598b4a4157d41d0ab2cb826adee0a128d1cc7fa;hb=5819de0c5d78effa16e4c59987268eadb96b8d1d;hp=683f71b7513356f321e2eb07d5060c535bcd4f7a;hpb=5f087cf4add4e140e7df05d896ee6b271133f822;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index 683f71b..c598b4a 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -18,12 +18,12 @@ import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
 import Id		( Id )
 import CoreLint		( showPass, endPass )
-import SetLevels	( setLevels, isInlineCtxt,
-		 	  Level(..), tOP_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}
 
 	-----------------
@@ -99,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}
@@ -152,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}
 
@@ -167,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') }
 
@@ -200,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'))
 	}
@@ -243,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
@@ -285,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') ->
@@ -307,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')
@@ -317,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])
@@ -367,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}