[project @ 2004-11-09 17:38:01 by simonpj]
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplMonad.lhs
index 5edfd2c..206e8d0 100644 (file)
@@ -35,10 +35,9 @@ module SimplMonad (
        getEnclosingCC, setEnclosingCC,
 
        -- Environments
-       SimplEnv, emptySimplEnv, getSubst, setSubst,
-       getSubstEnv, extendSubst, extendSubstList,
-       getInScope, setInScope, modifyInScope, addNewInScopeIds,
-       setSubstEnv, zapSubstEnv,
+       SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst, 
+       zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv,
+       getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
 
        -- Floats
        Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
@@ -59,14 +58,10 @@ import PprCore              ()      -- Instances
 import CostCentre      ( CostCentreStack, subsumedCCS )
 import Var     
 import VarEnv
-import VarSet
 import OrdList
 import qualified Subst
-import Subst           ( Subst, mkSubst, substEnv, 
-                         InScopeSet, mkInScopeSet, substInScope,
-                         isInScope 
-                       )
-import Type             ( Type, isUnLiftedType )
+import Subst           ( Subst, SubstResult, emptySubst, substInScope, isInScope )
+import Type             ( Type, TvSubst, TvSubstEnv, isUnLiftedType )
 import UniqSupply      ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
                          UniqSupply
                        )
@@ -77,7 +72,7 @@ import BasicTypes     ( TopLevelFlag, isTopLevel, isLoopBreaker,
                        )
 import CmdLineOpts     ( SimplifierSwitch(..), SimplifierMode(..),
                          DynFlags, DynFlag(..), dopt, 
-                         opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
+                         opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
                        )
 import Unique          ( Unique )
 import Outputable
@@ -166,7 +161,7 @@ emptyFloats env = Floats nilOL (getInScope env) True
 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 -- A single non-rec float; extend the in-scope set
 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
-                              (Subst.extendInScopeSet (getInScope env) var)
+                              (extendInScopeSet (getInScope env) var)
                               (not (isUnLiftedType (idType var)))
 
 addFloats :: SimplEnv -> Floats 
@@ -597,10 +592,10 @@ data SimplEnv
        -- have a correctly-substituted type.  So we use a lookup in this
        -- set to replace occurrences
 
-emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
-emptySimplEnv mode switches in_scope
-  = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
-              seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
+emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> SimplEnv
+emptySimplEnv mode switches
+  = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, 
+              seMode = mode, seSubst = emptySubst }
        -- The top level "enclosing CC" is "SUBSUMED".
 
 ---------------------
@@ -625,16 +620,23 @@ setEnclosingCC env cc = env {seCC = cc}
 getSubst :: SimplEnv -> Subst
 getSubst env = seSubst env
 
+getTvSubst :: SimplEnv -> TvSubst
+getTvSubst env = Subst.getTvSubst (seSubst env)
+
+setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv
+setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env
+  = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env}
+
 setSubst :: SimplEnv -> Subst -> SimplEnv
 setSubst env subst = env {seSubst = subst}
 
-extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
-extendSubst env@(SimplEnv {seSubst = subst}) var res
-  = env {seSubst = Subst.extendSubst subst var res}
+extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv
+extendIdSubst env@(SimplEnv {seSubst = subst}) var res
+  = env {seSubst = Subst.extendIdSubst subst var res}
 
-extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
-extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
-  = env {seSubst = Subst.extendSubstList subst vars ress}
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seSubst = subst}) var res
+  = env {seSubst = Subst.extendTvSubst subst var res}
 
 ---------------------
 getInScope :: SimplEnv -> InScopeSet
@@ -645,28 +647,25 @@ setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_sco
 
 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
-  = env {seSubst = Subst.setInScope subst in_scope}
+  = env {seSubst = Subst.setInScopeSet subst in_scope}
 
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
        -- The new Ids are guaranteed to be freshly allocated
 addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
-  = env {seSubst = Subst.extendNewInScopeList subst vs}
+  = env {seSubst = Subst.extendInScopeIds subst vs}
 
 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
 modifyInScope env@(SimplEnv {seSubst = subst}) v v'
   = env {seSubst = Subst.modifyInScope subst v v'}
 
 ---------------------
-getSubstEnv :: SimplEnv -> SubstEnv
-getSubstEnv env = substEnv (seSubst env)
-
-setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
-setSubstEnv env@(SimplEnv {seSubst = subst}) senv
-  = env {seSubst = Subst.setSubstEnv subst senv}
-
 zapSubstEnv :: SimplEnv -> SimplEnv
 zapSubstEnv env@(SimplEnv {seSubst = subst})
   = env {seSubst = Subst.zapSubstEnv subst}
+
+setSubstEnv :: SimplEnv -> Subst -> SimplEnv
+setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env
+  = env {seSubst = Subst.setSubstEnv subst subst_with_env}
 \end{code}
 
 
@@ -899,22 +898,13 @@ postInlineUnconditionally env bndr occ_info rhs
                   SimplGently  -> isAlwaysActive prag
                   SimplPhase n -> isActive n prag
     prag = idInlinePragma bndr
-\end{code}
-
-blackListInline tells if we must not inline at a call site because the
-Id's inline pragma says not to do so.
-
-However, blackListInline is ignored for things with with Compulsory inlinings,
-because they don't have bindings, so we must inline them no matter how
-gentle we are being.
 
-\begin{code}
 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 activeInline env id occ
   = case getMode env of
-      SimplGently -> isAlwaysActive prag && isOneOcc occ 
+      SimplGently -> isOneOcc occ && isAlwaysActive prag
        -- No inlining at all when doing gentle stuff,
-       -- except for things that occur once
+       -- except for local things that occur once
        -- The reason is that too little clean-up happens if you 
        -- don't inline use-once things.   Also a bit of inlining is *good* for
        -- full laziness; it can expose constant sub-expressions.
@@ -935,8 +925,15 @@ activeInline env id occ
 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 activeRule env
+  | opt_RulesOff = Nothing
+  | otherwise
   = case getMode env of
-       SimplGently  -> Nothing         -- No rules in gentle mode
+       SimplGently  -> Just isAlwaysActive
+                       -- Used to be Nothing (no rules in gentle mode)
+                       -- Main motivation for changing is that I wanted
+                       --      lift String ===> ...
+                       -- to work in Template Haskell when simplifying
+                       -- splices, so we get simpler code for literal strings
        SimplPhase n -> Just (isActive n)
 \end{code}