X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FsimplCore%2FFloatOut.lhs;h=01609066511199a30521f642fc5d4cec0ee77b0a;hb=7223167c4907ea114bd05935541dbbc8729e46f3;hp=e4e47f757e8390837b330518df7de5603640a2da;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index e4e47f7..0160906 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -11,20 +11,17 @@ module FloatOut ( floatOutwards ) where
 #include "HsVersions.h"
 
 import CoreSyn
+import CoreUtils	( mkSCC )
 
-import CmdLineOpts	( opt_D_verbose_core2core, opt_D_dump_simpl_stats )
-import ErrUtils		( dumpIfSet )
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt )
+import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
 import Id		( Id )
-import Const		( isWHNFCon )
 import VarEnv
-import CoreLint		( beginPass, endPass )
-import PprCore
+import CoreLint		( showPass, endPass )
 import SetLevels	( setLevels,
 		 	  Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
 			)
-import BasicTypes	( Unused )
-import Var		( TyVar )
 import UniqSupply       ( UniqSupply )
 import List		( partition )
 import Outputable
@@ -76,30 +73,35 @@ type FloatBinds    = [FloatBind]
 %************************************************************************
 
 \begin{code}
-floatOutwards :: UniqSupply -> [CoreBind] -> IO [CoreBind]
+floatOutwards :: DynFlags
+	      -> Bool 		-- True <=> float lambdas to top level
+	      -> UniqSupply 
+	      -> [CoreBind] -> IO [CoreBind]
 
-floatOutwards us pgm
+floatOutwards dflags float_lams us pgm
   = do {
-	beginPass "Float out";
+	showPass dflags float_msg ;
 
-	let { annotated_w_levels = setLevels pgm us ;
+	let { annotated_w_levels = setLevels float_lams pgm us ;
 	      (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
 	    } ;
 
-	dumpIfSet opt_D_verbose_core2core "Levels added:"
+	dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
 	          (vcat (map ppr annotated_w_levels));
 
 	let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
 
-	dumpIfSet opt_D_dump_simpl_stats "FloatOut stats:"
+	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
 		(hcat [	int tlets,  ptext SLIT(" Lets floated to top level; "),
 			int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
 			int lams,   ptext SLIT(" Lambda groups")]);
 
-	endPass "Float out" 
-	 	opt_D_verbose_core2core		{- no specific flag for dumping float-out -} 
-		(concat binds_s')
+	endPass dflags float_msg  Opt_D_verbose_core2core (concat binds_s')
+			{- no specific flag for dumping float-out -} 
     }
+  where
+    float_msg | float_lams = "Float out (floating lambdas too)"
+	      | otherwise  = "Float out (not floating lambdas)"
 
 floatTopBind bind@(NonRec _ _)
   = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
@@ -128,15 +130,11 @@ floatBind :: IdEnv Level
 	  -> (FloatStats, FloatBinds, CoreBind, IdEnv Level)
 
 floatBind env lvl (NonRec (name,level) rhs)
-  = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
-
-	-- A good dumping point
-    case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
-    (fs, rhs_floats',
-     NonRec name (install heres rhs'),
+  = case (floatRhs env level rhs) of { (fs, rhs_floats, rhs') ->
+    (fs, rhs_floats,
+     NonRec name rhs',
      extendVarEnv env name level)
-    }}
+    }
 
 floatBind env lvl bind@(Rec pairs)
   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
@@ -172,13 +170,9 @@ floatBind env lvl bind@(Rec pairs)
     bind_level = getBindLevel bind
 
     do_pair ((name, level), rhs)
-      = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
-
-		-- A good dumping point
-	case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
-	(fs, rhs_floats', (name, install heres rhs'))
-	}}
+      = case (floatRhs new_env level rhs) of { (fs, rhs_floats, rhs') ->
+	(fs, rhs_floats, (name, rhs'))
+	}
 \end{code}
 
 %************************************************************************
@@ -188,20 +182,30 @@ floatBind env lvl bind@(Rec pairs)
 %************************************************************************
 
 \begin{code}
-floatExpr :: IdEnv Level
-	  -> Level
-	  -> LevelledExpr
-	  -> (FloatStats, FloatBinds, CoreExpr)
+floatExpr, floatRhs
+	 :: IdEnv Level
+	 -> Level
+	 -> LevelledExpr
+	 -> (FloatStats, FloatBinds, CoreExpr)
+
+floatRhs env lvl arg
+  = case (floatExpr env lvl arg) of { (fsa, floats, arg') ->
+    case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
+	-- Dump bindings that aren't going to escape from a lambda
+	-- This is to avoid floating the x binding out of
+	--	f (let x = e in b)
+	-- unnecessarily.  It even causes a bug to do so if we have
+	--	y = writeArr# a n (let x = e in b)
+	-- because the y binding is an expr-ok-for-speculation one.
+    (fsa, floats', install heres arg') }}
 
 floatExpr env _ (Var v)	     = (zeroStats, [], Var v)
 floatExpr env _ (Type ty)    = (zeroStats, [], Type ty)
-floatExpr env lvl (Con con as) 
-  = case floatList (floatExpr env lvl) as of { (stats, floats, as') ->
-    (stats, floats, Con con as') }
+floatExpr env _ (Lit lit)    = (zeroStats, [], Lit lit)
 	  
 floatExpr env lvl (App e a)
   = case (floatExpr env lvl e) of { (fse, floats_e, e') ->
-    case (floatExpr env lvl a) of { (fsa, floats_a, a') ->
+    case (floatRhs env lvl a) of { (fsa, floats_a, a') ->
     (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
 
 floatExpr env lvl (Lam (tv,incd_lvl) e)
@@ -245,17 +249,20 @@ floatExpr env lvl (Note note@(SCC cc) expr)
       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
       where
 	ann_bind (NonRec binder rhs)
-	  = NonRec binder (ann_rhs rhs)
+	  = NonRec binder (mkSCC dupd_cc rhs)
 
 	ann_bind (Rec pairs)
-	  = Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs]
-
-	ann_rhs (Lam arg e)     = Lam arg (ann_rhs e)
-	ann_rhs rhs@(Con con _) | isWHNFCon con = rhs	-- no point in scc'ing WHNF data
-	ann_rhs rhs	        = Note (SCC dupd_cc) rhs
-
-	-- Note: Nested SCC's are preserved for the benefit of
-	--       cost centre stack profiling (Durham)
+	  = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs]
+
+-- At one time I tried the effect of not float anything out of an InlineMe,
+-- but it sometimes works badly.  For example, consider PrelArr.done.  It
+-- has the form 	__inline (\d. e)
+-- where e doesn't mention d.  If we float this to 
+--	__inline (let x = e in \d. x)
+-- things are bad.  The inliner doesn't even inline it because it doesn't look
+-- like a head-normal form.  So it seems a lesser evil to let things float.
+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
+-- which discourages floating out.
 
 floatExpr env lvl (Note note expr)	-- Other than SCCs
   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
@@ -355,8 +362,16 @@ partitionByMajorLevel, partitionByLevel
 partitionByMajorLevel ctxt_lvl defns
   = partition float_further defns
   where
-    float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
-				isTopLvl my_lvl
+	-- Float it if we escape a value lambda, 
+	-- or if we get to the top level
+    float_further (my_lvl, bind) = my_lvl `ltMajLvl` ctxt_lvl || isTopLvl my_lvl
+	-- The isTopLvl part says that 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
 
 partitionByLevel ctxt_lvl defns
   = partition float_further defns