X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=2fedf8755f3576ae4ce1ad5bcf8a1cd5eee6fd08;hb=b1ab4b8a607addc4d097588db5761313c996a41f;hp=245f313e8f874b4f59f60e26f2dd5ca2a26ba5cc;hpb=dbcff8ab57f64bcc6abff68448fc33691410266e;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 245f313..2fedf87 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -9,8 +9,6 @@ module SimplEnv (
 	OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
         InCoercion, OutCoercion,
 
-	isStrictBndr,
-
 	-- The simplifier mode
 	setMode, getMode, 
 
@@ -34,9 +32,9 @@ module SimplEnv (
 	substExpr, substTy, 
 
 	-- Floats
-  	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, 
-	wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats,
-	getFloats
+  	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
+	wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
+	doFloatFromRhs, getFloats
     ) where
 
 #include "HsVersions.h"
@@ -46,14 +44,12 @@ import IdInfo
 import CoreSyn
 import Rules
 import CoreUtils
-import CoreFVs
 import CostCentre
 import Var
 import VarEnv
 import VarSet
 import OrdList
 import Id
-import NewDemand
 import qualified CoreSubst	( Subst, mkSubst, substExpr, substSpec, substWorker )
 import qualified Type		( substTy, substTyVarBndr )
 import Type hiding		( substTy, substTyVarBndr )
@@ -61,7 +57,6 @@ import Coercion
 import BasicTypes	
 import DynFlags
 import Util
-import UniqFM
 import Outputable
 \end{code}
 
@@ -92,13 +87,6 @@ type OutAlt	 = CoreAlt
 type OutArg	 = CoreArg
 \end{code}
 
-\begin{code}
-isStrictBndr :: Id -> Bool
-isStrictBndr bndr
-  = ASSERT2( isId bndr, ppr bndr )
-    isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)
-\end{code}
-
 %************************************************************************
 %*									*
 \subsubsection{The @SimplEnv@ type}
@@ -321,11 +309,13 @@ The Floats is a bunch of bindings, classified by a FloatFlag.
 
   NonRec x (y:ys)	FltLifted
   Rec [(x,rhs)]		FltLifted
-  NonRec x# (y +# 3)	FltOkSpec
+
+  NonRec x# (y +# 3)	FltOkSpec	-- Unboxed, but ok-for-spec'n
+
   NonRec x# (a /# b)	FltCareful
-  NonRec x* (f y)	FltCareful	-- Might fail or diverge
-  NonRec x# (f y)	FltCareful	-- Might fail or diverge
-			  (where f :: Int -> Int#)
+  NonRec x* (f y)	FltCareful	-- Strict binding; might fail or diverge
+  NonRec x# (f y)	FltCareful	-- Unboxed binding: might fail or diverge
+					--	  (where f :: Int -> Int#)
 
 \begin{code}
 data Floats = Floats (OrdList OutBind) FloatFlag
@@ -364,18 +354,19 @@ andFF FltLifted  flt	    = flt
 classifyFF :: CoreBind -> FloatFlag
 classifyFF (Rec _) = FltLifted
 classifyFF (NonRec bndr rhs) 
-  | not (isStrictBndr bndr)  = FltLifted
+  | not (isStrictId bndr)    = FltLifted
   | exprOkForSpeculation rhs = FltOkSpec
   | otherwise		     = FltCareful
 
-canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool
-canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff}) 
-  = canFloatFlt lvl rec str ff
-
-canFloatFlt :: TopLevelFlag -> RecFlag -> Bool -> FloatFlag -> Bool
-canFloatFlt lvl rec str FltLifted  = True
-canFloatFlt lvl rec str FltOkSpec  = isNotTopLevel lvl && isNonRec rec
-canFloatFlt lvl rec str FltCareful = str && isNotTopLevel lvl && isNonRec rec
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
+  =  not (isNilOL fs) && want_to_float && can_float
+  where
+     want_to_float = isTopLevel lvl || exprIsCheap rhs
+     can_float = case ff of
+		   FltLifted  -> True
+	 	   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
+		   FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 \end{code}
 
 
@@ -396,6 +387,16 @@ addNonRec env id rhs
   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 	  seInScope = extendInScopeSet (seInScope env) id }
 
+extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
+-- Add these bindings to the floats, and extend the in-scope env too
+extendFloats env binds
+  = env { seFloats  = seFloats env `addFlts` new_floats,
+	  seInScope = extendInScopeSetList (seInScope env) bndrs }
+  where
+    bndrs = bindersOfBinds binds
+    new_floats = Floats (toOL binds) 
+			(foldr (andFF . classifyFF) FltLifted binds)
+
 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Add the floats for env2 to env1; 
 -- *plus* the in-scope set for env2, which is bigger