X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=5d8b16c89aae05e2910f1be803de1329b88963d4;hb=51c4d029be44a5a629daf51b55cbca7cb734c172;hp=12b3ce56ce377453d57d739699f62a81266f93ad;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 12b3ce5..5d8b16c 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -23,13 +23,13 @@ module SimplEnv (
 	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, substTy, substUnfolding,
+	substExpr, substTy, mkCoreSubst,
 
 	-- Floats
   	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -206,8 +206,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 +225,11 @@ getMode env = seMode env
 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 setMode mode env = env { seMode = mode }
 
+inGentleMode :: SimplEnv -> Bool
+inGentleMode env = case seMode env of
+	                SimplGently {} -> True
+		        _other         -> False
+
 ---------------------
 getEnclosingCC :: SimplEnv -> CostCentreStack
 getEnclosingCC env = seCC env
@@ -356,7 +361,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
@@ -528,7 +533,7 @@ simplLamBndr env bndr
   where
     old_unf = idUnfolding bndr
     (env1, id1) = substIdBndr env bndr
-    id2  = id1 `setIdUnfolding` substUnfolding env False old_unf
+    id2  = id1 `setIdUnfolding` substUnfolding env old_unf
     env2 = modifyInScope env1 id2
 
 ---------------
@@ -712,11 +717,7 @@ 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 -> Bool -> Unfolding -> Unfolding
-substUnfolding env is_top_lvl unf 
-  | InlineRule {} <- unf' = unf' { uf_is_top = is_top_lvl }
-  | otherwise             = unf'
-  where
-    unf' = CoreSubst.substUnfolding (mkCoreSubst env) unf
+substUnfolding :: SimplEnv -> Unfolding -> Unfolding
+substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
 \end{code}