X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatIn.lhs;h=be854af217a4b75b21b937b097687b78e0499f2d;hb=9e93335020e64a811dbbb223e1727c76933a93ae;hp=6fc36c8de249f3006149c890fff605980a27dd31;hpb=cfcebde74cf826af12143a92bcffa8c995eee135;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 6fc36c8..be854af 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -16,16 +16,16 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_D_verbose_core2core )
+import CmdLineOpts	( DynFlags, DynFlag(..) )
 import CoreSyn
-import CoreLint		( beginPass, endPass )
-import Const		( isDataCon )
+import CoreUtils	( exprIsValue, exprIsDupable )
+import CoreLint		( showPass, endPass )
 import CoreFVs		( CoreExprWithFVs, freeVars, freeVarsOf )
 import Id		( isOneShotLambda )
 import Var		( Id, idType, isTyVar )
 import Type		( isUnLiftedType )
 import VarSet
-import Util		( zipEqual )
+import Util		( zipEqual, zipWithEqual, count )
 import Outputable
 \end{code}
 
@@ -33,15 +33,14 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 
 \begin{code}
-floatInwards :: [CoreBind] -> IO [CoreBind]
+floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
 
-floatInwards binds
+floatInwards dflags binds
   = do {
-	beginPass "Float inwards";
+	showPass dflags "Float inwards";
 	let { binds' = map fi_top_bind binds };
-	endPass "Float inwards" 
-	 	opt_D_verbose_core2core		{- no specific flag for dumping float-in -} 
-		binds'	
+	endPass dflags "Float inwards" Opt_D_verbose_core2core binds'	
+				{- no specific flag for dumping float-in -} 
     }
 			  
   where
@@ -141,16 +140,7 @@ fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
 				 Type ty
 
-fiExpr to_drop (_, AnnCon c args)
-   | isDataCon c	-- Don't float into the args of a data construtor;
-			-- the simplifier will float straight back out
-   = mkCoLets' to_drop (Con c (map (fiExpr []) args))
-
-   | otherwise
-   = mkCoLets' drop_here (Con c args')
-   where
-     (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
-     args'	 	     = zipWith fiExpr arg_drops args
+fiExpr to_drop (_, AnnLit lit) = Lit lit
 \end{code}
 
 Applications: we do float inside applications, mainly because we
@@ -161,7 +151,7 @@ pull out any silly ones.
 fiExpr to_drop (_,AnnApp fun arg)
   = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
   where
-    [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
+    [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 \end{code}
 
 We are careful about lambdas: 
@@ -192,13 +182,17 @@ So we treat lambda in groups, using the following rule:
 fiExpr to_drop (_, AnnLam b body)
   = case collect [b] body of
       (bndrs, real_body)
-	| all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+--	| all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- [July 01: I'm experiment with getting the full laziness
+-- pass to floats bindings out past big lambdas (instead of the simplifier)
+-- so I don't want the float-in pass to just push them right back in.
+-- I'm going to try just dumping all bindings outside lambdas.]
 	| otherwise	  -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
   where
     collect bs (_, AnnLam b body) = collect (b:bs) body
     collect bs body		  = (reverse bs, body)
 
-    is_ok bndr = isTyVar bndr || isOneShotLambda bndr
+--    is_ok bndr = isTyVar bndr || isOneShotLambda bndr
 \end{code}
 
 We don't float lets inwards past an SCC.
@@ -223,11 +217,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
   = 	-- Just float in past coercion
     Note note (fiExpr to_drop expr)
-
-fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
-  =     -- Float in past term usage annotation
-        -- (for now; not sure if this is correct: KSW 1999-05)
-    Note note (fiExpr to_drop expr)
 \end{code}
 
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
@@ -265,7 +254,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 	-- No point in floating in only to float straight out again
 	-- Ditto ok-for-speculation unlifted RHSs
 
-    [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop
+    [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop
 
     new_to_drop = body_binds ++				-- the bindings used only in the body
 		  [(NonRec id rhs', rhs_fvs')] ++ 	-- the new binding itself
@@ -278,7 +267,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where
-    (binders, rhss) = unzip bindings
+    rhss = map snd bindings
 
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
@@ -301,7 +290,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
     get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
 			      | otherwise	   = emptyVarSet
 
-    (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop
+    (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop
 
     new_to_drop = -- the bindings used only in the body
 		  body_binds ++
@@ -329,12 +318,20 @@ alternatives/default [default FVs always {\em first}!].
 
 \begin{code}
 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
-  = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
-			      (zipWith fi_alt alts_drops alts))
+  = mkCoLets' drop_here1 $
+    mkCoLets' drop_here2 $
+    Case (fiExpr scrut_drops scrut) case_bndr
+	 (zipWith fi_alt alts_drops_s alts)
   where
-    (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
-    scrut_fvs = freeVarsOf scrut
-    alts_fvs  = map alt_fvs alts
+	-- Float into the scrut and alts-considered-together just like App
+    [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
+
+	-- Float into the alts with the is_case flag set
+    (drop_here2 : alts_drops_s)           = sepBindsByDropPoint True alts_fvs alts_drops
+
+    scrut_fvs    = freeVarsOf scrut
+    alts_fvs     = map alt_fvs alts
+    all_alts_fvs = unionVarSets alts_fvs
     alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
 				-- Delete case_bndr and args from free vars of rhs 
 				-- to get free vars of alt
@@ -342,9 +339,17 @@ fiExpr to_drop (_, AnnCase scrut case_bndr alts)
     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 
 noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam _ _)   	    = True
-noFloatIntoRhs (AnnCon con _)       = isDataCon con
-noFloatIntoRhs other	            = False
+noFloatIntoRhs (AnnLam b _)   	    = not (isId b && isOneShotLambda b)
+	-- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
+	-- This makes a big difference for things like
+	--	f x# = let x = I# x#
+	--	       in let j = \() -> ...x...
+	--		  in if <condition> then normal-path else j ()
+	-- If x is used only in the error case join point, j, we must float the
+	-- boxing constructor into it, else we box it every time which is very bad
+	-- news indeed.
+
+noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs)	-- We'd just float rigt back out again...
 \end{code}
 
 
@@ -371,7 +376,8 @@ We have to maintain the order on these drop-point-related lists.
 
 \begin{code}
 sepBindsByDropPoint
-    :: [FreeVarsSet]	    -- One set of FVs per drop point
+    :: Bool		    -- True <=> is case expression
+    -> [FreeVarsSet]	    -- One set of FVs per drop point
     -> FloatingBinds 	    -- Candidate floaters
     -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
 			    -- inside any drop point; the rest correspond
@@ -383,38 +389,60 @@ sepBindsByDropPoint
 -- a binding (let x = E in B) might have a specialised version of
 -- x (say x') stored inside x, but x' isn't free in E or B.
 
-sepBindsByDropPoint drop_pts []
+type DropBox = (FreeVarsSet, FloatingBinds)
+
+sepBindsByDropPoint is_case drop_pts []
   = [] : [[] | p <- drop_pts]	-- cut to the chase scene; it happens
 
-sepBindsByDropPoint drop_pts floaters
+sepBindsByDropPoint is_case drop_pts floaters
   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
   where
-    go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
+    go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
 	-- The *first* one in the argument list is the drop_here set
 	-- The FloatingBinds in the lists are in the reverse of
 	-- the normal FloatingBinds order; that is, they are the right way round!
 
     go [] drop_boxes = map (reverse . snd) drop_boxes
 
-    go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes
-	= go binds (insert drop_boxes (drop_here : used_in_flags))
-		-- insert puts the find in box whose True flag comes first
+    go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
+	= go binds new_boxes
 	where
+	  -- "here" means the group of bindings dropped at the top of the fork
+
 	  (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
 					| (fvs, drops) <- drop_boxes]
 
-	  drop_here = used_here || not (exactlyOneTrue used_in_flags)
+	  drop_here = used_here || not can_push
 
-	  insert ((fvs,drops) : drop_boxes) (True : _)
-		= ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes)
-	  insert (drop_box : drop_boxes) (False : others)
-		= drop_box : insert drop_boxes others
-	  insert _ _ = panic "sepBindsByDropPoint"	-- Should never happen
+		-- For case expressions we duplicate the binding if it is
+		-- reasonably small, and if it is not used in all the RHSs
+		-- This is good for situations like
+		--	let x = I# y in
+		--	case e of
+		--	  C -> error x
+		-- 	  D -> error x
+		--	  E -> ...not mentioning x...
+
+	  n_alts      = length used_in_flags
+	  n_used_alts = count id used_in_flags -- returns number of Trues in list.
+
+	  can_push = n_used_alts == 1		-- Used in just one branch
+		   || (is_case && 		-- We are looking at case alternatives
+		       n_used_alts > 1 && 	-- It's used in more than one
+		       n_used_alts < n_alts &&	-- ...but not all
+		       bindIsDupable bind)	-- and we can duplicate the binding
+
+	  new_boxes | drop_here = (insert here_box : fork_boxes)
+		    | otherwise = (here_box : new_fork_boxes)
+
+	  new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
+
+	  insert :: DropBox -> DropBox
+	  insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
+
+	  insert_maybe box True  = insert box
+	  insert_maybe box False = box
 
-exactlyOneTrue :: [Bool] -> Bool
-exactlyOneTrue flags = case [() | True <- flags] of
-			[_]   -> True
-			other -> False
 
 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 floatedBindsFVs binds = unionVarSets (map snd binds)
@@ -422,4 +450,7 @@ floatedBindsFVs binds = unionVarSets (map snd binds)
 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 	-- Remember to_drop is in *reverse* dependency order
+
+bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
+bindIsDupable (NonRec b r) = exprIsDupable r
 \end{code}