X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=6104d3390144db993b9abb080ad2afad4dda1deb;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hp=3832f547de2c019d184976fd877547946e263dac;hpb=96cb07b5940f98f35ac292e40d0129db5d3748ce;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 3832f54..6104d33 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -32,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"
@@ -44,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 )
@@ -59,8 +57,9 @@ import Coercion
 import BasicTypes	
 import DynFlags
 import Util
-import UniqFM
 import Outputable
+
+import Data.List
 \end{code}
 
 %************************************************************************
@@ -104,9 +103,6 @@ data SimplEnv
 	seChkr      :: SwitchChecker,
 	seCC        :: CostCentreStack,	-- The enclosing CCS (when profiling)
 
-	-- Rules from other modules
-	seExtRules  :: RuleBase,
-
 	-- The current set of in-scope variables
 	-- They are all OutVars, and all bound in this module
 	seInScope   :: InScopeSet,	-- OutVars only
@@ -210,11 +206,11 @@ seIdSubst:
 
 
 \begin{code}
-mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
-mkSimplEnv mode switches rules
+mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
+mkSimplEnv mode switches
   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
 	       seMode = mode, seInScope = emptyInScopeSet, 
-	       seExtRules = rules, seFloats = emptyFloats,
+	       seFloats = emptyFloats,
 	       seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
 	-- The top level "enclosing CC" is "SUBSUMED".
 
@@ -292,10 +288,6 @@ mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 isEmptySimplSubst :: SimplEnv -> Bool
 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
   = isEmptyVarEnv tvs && isEmptyVarEnv ids
-
----------------------
-getRules :: SimplEnv -> RuleBase
-getRules = seExtRules
 \end{code}
 
 
@@ -312,11 +304,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
@@ -359,14 +353,15 @@ classifyFF (NonRec bndr rhs)
   | 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}
 
 
@@ -387,6 +382,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 
@@ -629,8 +634,8 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old
 	      = delVarEnv id_subst old_id
 \end{code}
 
-Add IdInfo back onto a let-bound Id
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Add IdInfo back onto a let-bound Id]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must transfer the IdInfo of the original binder to the new binder.
 This is crucial, to preserve
 	strictness