X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=026bdef7c1a07c4b528c57937fa1cc1d95b2734e;hb=1cf8d965aeb55701efa47dace761c4d673c06987;hp=a2e06a0bf78a74876940a8ede7aa001e300fa530;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index a2e06a0..026bdef 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -10,7 +10,7 @@ module SimplEnv (
         InCoercion, OutCoercion,
 
 	-- The simplifier mode
-	setMode, getMode, 
+	setMode, getMode, updMode,
 
 	-- Switch checker
 	SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
@@ -19,17 +19,17 @@ module SimplEnv (
 	setEnclosingCC, getEnclosingCC,
 
 	-- Environments
-	SimplEnv(..), pprSimplEnv,	-- Temp not abstract
+	SimplEnv(..), StaticEnv, pprSimplEnv,	-- Temp not abstract
 	mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
 	zapSubstEnv, setSubstEnv, 
 	getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-	getSimplRules, 
+	getSimplRules, inGentleMode,
 
 	SimplSR(..), mkContEx, substId, lookupRecBndr,
 
 	simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
  	simplBinder, simplBinders, addBndrRules,
-	substExpr, substWorker, substTy, 
+	substExpr, substTy, mkCoreSubst,
 
 	-- Floats
   	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -49,7 +49,7 @@ import VarEnv
 import VarSet
 import OrdList
 import Id
-import qualified CoreSubst	( Subst, mkSubst, substExpr, substSpec, substWorker )
+import qualified CoreSubst	( Subst, mkSubst, substExpr, substSpec, substUnfolding )
 import qualified Type		( substTy, substTyVarBndr )
 import Type hiding		( substTy, substTyVarBndr )
 import Coercion
@@ -99,23 +99,32 @@ type OutArg	 = CoreArg
 \begin{code}
 data SimplEnv
   = SimplEnv {
+     ----------- Static part of the environment -----------
+     -- Static in the sense of lexically scoped, 
+     -- wrt the original expression
+
 	seMode 	    :: SimplifierMode,
 	seChkr      :: SwitchChecker,
 	seCC        :: CostCentreStack,	-- The enclosing CCS (when profiling)
 
+	-- The current substitution
+	seTvSubst   :: TvSubstEnv,	-- InTyVar |--> OutType
+	seIdSubst   :: SimplIdSubst,	-- InId    |--> OutExpr
+
+     ----------- Dynamic part of the environment -----------
+     -- Dynamic in the sense of describing the setup where
+     -- the expression finally ends up
+
 	-- The current set of in-scope variables
 	-- They are all OutVars, and all bound in this module
 	seInScope   :: InScopeSet,	-- OutVars only
 		-- Includes all variables bound by seFloats
-	seFloats    :: Floats,
+	seFloats    :: Floats
 		-- See Note [Simplifier floats]
-
-	-- The current substitution
-	seTvSubst   :: TvSubstEnv,	-- InTyVar |--> OutType
-	seIdSubst   :: SimplIdSubst	-- InId    |--> OutExpr
-
     }
 
+type StaticEnv = SimplEnv 	-- Just the static part is relevant
+
 pprSimplEnv :: SimplEnv -> SDoc
 -- Used for debugging; selective
 pprSimplEnv env
@@ -206,8 +215,8 @@ seIdSubst:
 
 
 \begin{code}
-mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
-mkSimplEnv mode switches
+mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
+mkSimplEnv switches mode
   = SimplEnv { seChkr = switches, seCC = subsumedCCS, 
 	       seMode = mode, seInScope = emptyInScopeSet, 
 	       seFloats = emptyFloats,
@@ -225,6 +234,14 @@ getMode env = seMode env
 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 setMode mode env = env { seMode = mode }
 
+updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
+updMode upd env = env { seMode = upd (seMode env) }
+
+inGentleMode :: SimplEnv -> Bool
+inGentleMode env = case seMode env of
+	                SimplGently {} -> True
+		        _other         -> False
+
 ---------------------
 getEnclosingCC :: SimplEnv -> CostCentreStack
 getEnclosingCC env = seCC env
@@ -356,7 +373,7 @@ 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
+     want_to_float = isTopLevel lvl || exprIsExpandable rhs
      can_float = case ff of
 		   FltLifted  -> True
 	 	   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
@@ -660,29 +677,6 @@ addBndrRules env in_id out_id
     old_rules = idSpecialisation in_id
     new_rules = CoreSubst.substSpec subst out_id old_rules
     final_id  = out_id `setIdSpecialisation` new_rules
-
-------------------
-substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
-  | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
-  | otherwise	= Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-		-- The tyVarsOfType is cheaper than it looks
-		-- because we cache the free tyvars of the type
-		-- in a Note in the id's type itself
-  where
-    old_ty = idType id
-
-------------------
-substUnfolding :: SimplEnv -> Unfolding -> Unfolding
-substUnfolding _   NoUnfolding     	       = NoUnfolding
-substUnfolding _   (OtherCon cons) 	       = OtherCon cons
-substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
-
-------------------
-substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
-substWorker _   NoWorker = NoWorker
-substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info
 \end{code}
 
 
@@ -718,9 +712,24 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id
     fiddle (DoneId v)       = Var v
     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 
+------------------
+substIdType :: SimplEnv -> Id -> Id
+substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
+  | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+  | otherwise	= Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+		-- The tyVarsOfType is cheaper than it looks
+		-- because we cache the free tyvars of the type
+		-- in a Note in the id's type itself
+  where
+    old_ty = idType id
+
+------------------
 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
   -- Do *not* short-cut in the case of an empty substitution
   -- See CoreSubst: Note [Extending the Subst]
+
+substUnfolding :: SimplEnv -> Unfolding -> Unfolding
+substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
 \end{code}