Minor refactoring to remove redundant code

[ghc-hetmet.git] / compiler / simplCore / SimplEnv.lhs

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 12b3ce5..026bdef 100644 (file)
--- 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, substTy, substUnfolding,
+       substExpr, substTy, mkCoreSubst,
 
        -- Floats
        Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -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
@@ -528,7 +545,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 +729,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}