X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatIn.lhs;h=b9f44c95c12854e9c54f1be1d5d71b62daf639c0;hp=f84a64ee7931a030c749228742f235084cf2ad35;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=f53e3de5fac3c5eb12f94ee6b26488b1d07d361e

diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index f84a64e..b9f44c9 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -16,16 +16,15 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
-import DynFlags	( DynFlags, DynFlag(..) )
 import CoreSyn
 import CoreUtils	( exprIsHNF, exprIsDupable )
-import CoreLint		( showPass, endPass )
-import CoreFVs		( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
-import Id		( isOneShotBndr )
-import Var		( Id, idType )
+import CoreFVs		( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
+import Id		( isOneShotBndr, idType )
+import Var
 import Type		( isUnLiftedType )
 import VarSet
 import Util		( zipEqual, zipWithEqual, count )
+import UniqFM
 import Outputable
 \end{code}
 
@@ -33,16 +32,8 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 
 \begin{code}
-floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-floatInwards dflags binds
-  = do {
-	showPass dflags "Float inwards";
-	let { binds' = map fi_top_bind binds };
-	endPass dflags "Float inwards" Opt_D_verbose_core2core binds'	
-				{- no specific flag for dumping float-in -} 
-    }
-			  
+floatInwards :: [CoreBind] -> [CoreBind]
+floatInwards = map fi_top_bind
   where
     fi_top_bind (NonRec binder rhs)
       = NonRec binder (fiExpr [] (freeVars rhs))
@@ -142,7 +133,7 @@ fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
 fiExpr to_drop (_, AnnCast expr co)
   = Cast (fiExpr to_drop expr) co	-- Just float in past coercion
 
-fiExpr to_drop (_, AnnLit lit) = Lit lit
+fiExpr _ (_, AnnLit lit) = Lit lit
 \end{code}
 
 Applications: we do float inside applications, mainly because we
@@ -156,8 +147,8 @@ fiExpr to_drop (_,AnnApp fun arg)
     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 \end{code}
 
-We are careful about lambdas: 
-
+Note [Floating in past a lambda group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * We must be careful about floating inside inside a value lambda.  
   That risks losing laziness.
   The float-out pass might rescue us, but then again it might not.
@@ -173,24 +164,30 @@ We are careful about lambdas:
   This is bad as now f is an updatable closure (update PAP)
   and has arity 0.
 
+* Hack alert!  We only float in through one-shot lambdas, 
+  not (as you might guess) through lone big lambdas.  
+  Reason: we float *out* past big lambdas (see the test in the Lam
+  case of FloatOut.floatExpr) and we don't want to float straight
+  back in again.
+  
+  It *is* important to float into one-shot lambdas, however;
+  see the remarks with noFloatIntoRhs.
+
 So we treat lambda in groups, using the following rule:
 
-	Float inside a group of lambdas only if
-	they are all either type lambdas or one-shot lambdas.
+ Float in if (a) there is at least one Id, 
+         and (b) there are no non-one-shot Ids
+
+ Otherwise drop all the bindings outside the group.
+
+This is what the 'go' function in the AnnLam case is doing.
 
-	Otherwise drop all the bindings outside the group.
+Urk! if all are tyvars, and we don't float in, we may miss an 
+      opportunity to float inside a nested case branch
 
 \begin{code}
-	-- Hack alert!  We only float in through one-shot lambdas, 
-	-- not (as you might guess) through big lambdas.  
-	-- Reason: we float *out* past big lambdas (see the test in the Lam
-	-- case of FloatOut.floatExpr) and we don't want to float straight
-	-- back in again.
-	--
-	-- It *is* important to float into one-shot lambdas, however;
-	-- see the remarks with noFloatIntoRhs.
 fiExpr to_drop lam@(_, AnnLam _ _)
-  | all is_one_shot bndrs 	-- Float in
+  | go False bndrs 	-- Float in
   = mkLams bndrs (fiExpr to_drop body)
 
   | otherwise	 	-- Dump it all here
@@ -198,6 +195,12 @@ fiExpr to_drop lam@(_, AnnLam _ _)
 
   where
     (bndrs, body) = collectAnnBndrs lam
+
+    go seen_one_shot_id [] = seen_one_shot_id
+    go seen_one_shot_id (b:bs)
+      | isTyCoVar       b = go seen_one_shot_id bs
+      | isOneShotBndr b = go True bs
+      | otherwise       = False	 -- Give up at a non-one-shot Id
 \end{code}
 
 We don't float lets inwards past an SCC.
@@ -206,14 +209,10 @@ We don't float lets inwards past an SCC.
 	cc, change current cc to the new one and float binds into expr.
 
 \begin{code}
-fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
+fiExpr to_drop (_, AnnNote note@(SCC _) expr)
   = 	-- Wimp out for now
     mkCoLets' to_drop (Note note (fiExpr [] expr))
 
-fiExpr to_drop (_, AnnNote InlineMe expr)
-  = 	-- Ditto... don't float anything into an INLINE expression
-    mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
-
 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
   = Note note (fiExpr to_drop expr)
 \end{code}
@@ -260,10 +259,12 @@ arrange to dump bindings that bind extra_fvs before the entire let.
 
 Note [extra_fvs (s): free variables of rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider let x{rule mentioning y} = rhs in body
+Consider 
+  let x{rule mentioning y} = rhs in body 
 Here y is not free in rhs or body; but we still want to dump bindings
 that bind y outside the let.  So we augment extra_fvs with the
-idRuleVars of x.
+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
+idFreeVars.
 
 
 \begin{code}
@@ -272,7 +273,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
   where
     body_fvs = freeVarsOf body
 
-    rule_fvs = idRuleVars id	-- See Note [extra_fvs (2): free variables of rules]
+    rule_fvs = idRuleAndUnfoldingVars id	-- See Note [extra_fvs (2): free variables of rules]
     extra_fvs | noFloatIntoRhs ann_rhs
 	      || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
 	      | otherwise		    = rule_fvs
@@ -290,21 +291,21 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 
 	-- Push rhs_binds into the right hand side of the binding
     rhs'     = fiExpr rhs_binds rhs
-    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
+    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs
+			-- Don't forget the rule_fvs; the binding mentions them!
 
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where
-    rhss = map snd bindings
-
+    (ids, rhss) = unzip bindings
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
 
 	-- See Note [extra_fvs (1,2)]
-    extra_fvs = foldr (unionVarSet . get_extras) emptyVarSet bindings
-    get_extras (id, (rhs_fvs, rhs)) 
-	| noFloatIntoRhs rhs = idRuleVars id `unionVarSet` rhs_fvs
-	| otherwise	     = idRuleVars id
+    rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
+    extra_fvs = rule_fvs `unionVarSet` 
+		unionVarSets [ fvs | (fvs, rhs) <- rhss
+			     , noFloatIntoRhs rhs ]
 
     (shared_binds:extra_binds:body_binds:rhss_binds) 
 	= sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
@@ -315,8 +316,9 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 		  extra_binds ++	-- Note [extra_fvs (1,2)]
 		  shared_binds		-- Used in more than one place
 
-    rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
-			   (unionVarSets (map floatedBindsFVs rhss_binds))
+    rhs_fvs' = unionVarSets rhss_fvs `unionVarSet`
+	       unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet`
+	       rule_fvs		-- Don't forget the rule variables!
 
     -- Push rhs_binds into the right hand side of the binding
     fi_bind :: [FloatingBinds]	    -- one per "drop pt" conjured w/ fvs_of_rhss
@@ -348,14 +350,14 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
     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)
+    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
 
     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 
-noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam b _)   	    = not (is_one_shot b)
+noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
+noFloatIntoRhs (AnnLam b _) = not (is_one_shot 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#
@@ -367,6 +369,7 @@ noFloatIntoRhs (AnnLam b _)   	    = not (is_one_shot b)
 
 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs)	-- We'd just float right back out again...
 
+is_one_shot :: Var -> Bool
 is_one_shot b = isId b && isOneShotBndr b
 \end{code}
 
@@ -409,8 +412,8 @@ sepBindsByDropPoint
 
 type DropBox = (FreeVarsSet, FloatingBinds)
 
-sepBindsByDropPoint is_case drop_pts []
-  = [] : [[] | p <- drop_pts]	-- cut to the chase scene; it happens
+sepBindsByDropPoint _is_case drop_pts []
+  = [] : [[] | _ <- drop_pts]	-- cut to the chase scene; it happens
 
 sepBindsByDropPoint is_case drop_pts floaters
   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
@@ -428,7 +431,7 @@ sepBindsByDropPoint is_case drop_pts floaters
 	  -- "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]
+					| (fvs, _) <- drop_boxes]
 
 	  drop_here = used_here || not can_push
 
@@ -461,6 +464,8 @@ sepBindsByDropPoint is_case drop_pts floaters
 	  insert_maybe box True  = insert box
 	  insert_maybe box False = box
 
+    go _ _ = panic "sepBindsByDropPoint/go"
+
 
 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 floatedBindsFVs binds = unionVarSets (map snd binds)
@@ -469,6 +474,7 @@ mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
 	-- Remember to_drop is in *reverse* dependency order
 
+bindIsDupable :: Bind CoreBndr -> Bool
 bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
-bindIsDupable (NonRec b r) = exprIsDupable r
+bindIsDupable (NonRec _ r) = exprIsDupable r
 \end{code}