[project @ 2000-01-25 19:18:42 by sewardj]

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

diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 32d8d6b..af977c5 100644 (file)
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -39,6 +39,7 @@ module SimplMonad (
        getEnclosingCC, setEnclosingCC,
 
        -- Environments
+       getEnv, setAllExceptInScope,
        getSubst, setSubst,
        getSubstEnv, extendSubst, extendSubstList,
        getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
@@ -50,13 +51,15 @@ module SimplMonad (
 #include "HsVersions.h"
 
 import Const           ( Con(DEFAULT) )
-import Id              ( Id, mkSysLocal, idMustBeINLINEd )
+import Id              ( Id, mkSysLocal, getIdUnfolding )
 import IdInfo          ( InlinePragInfo(..) )
 import Demand          ( Demand )
 import CoreSyn
+import CoreUnfold      ( isCompulsoryUnfolding )
 import PprCore         ()      -- Instances
 import Rules           ( RuleBase )
 import CostCentre      ( CostCentreStack, subsumedCCS )
+import Name            ( isLocallyDefined )
 import Var             ( TyVar )
 import VarEnv
 import VarSet
@@ -146,7 +149,7 @@ data SimplCont              -- Strict contexts
                                --      f (error "foo") ==> coerce t (error "foo")
                                -- when f is strict
                                -- We need to know the type t, to which to coerce.
-           (OutExpr -> SimplM OutExprStuff)    -- What to do with the result
+            (OutExpr -> SimplM OutExprStuff)   -- What to do with the result
 
 instance Outputable SimplCont where
   ppr (Stop _)                      = ptext SLIT("Stop")
@@ -568,7 +571,6 @@ data Tick
   | FillInCaseDefault          Id      -- Case binder
 
   | BottomFound                
-  | LeafVisit
   | SimplifierDone             -- Ticked at each iteration of the simplifier
 
 isRuleFired (RuleFired _) = True
@@ -599,7 +601,6 @@ tickToTag (CaseElim _)                      = 11
 tickToTag (CaseIdentity _)             = 12
 tickToTag (FillInCaseDefault _)                = 13
 tickToTag BottomFound                  = 14
-tickToTag LeafVisit                    = 15
 tickToTag SimplifierDone               = 16
 
 tickString :: Tick -> String
@@ -619,7 +620,6 @@ tickString (CaseIdentity _)         = "CaseIdentity"
 tickString (FillInCaseDefault _)       = "FillInCaseDefault"
 tickString BottomFound                 = "BottomFound"
 tickString SimplifierDone              = "SimplifierDone"
-tickString LeafVisit                   = "LeafVisit"
 
 pprTickCts :: Tick -> SDoc
 pprTickCts (PreInlineUnconditionally v)        = ppr v
@@ -745,7 +745,30 @@ environment seems like wild overkill.
 \begin{code}
 switchOffInlining :: SimplM a -> SimplM a
 switchOffInlining m env us sc
-  = m (env { seBlackList = \v -> True  }) us sc
+  = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (getIdUnfolding v)) &&
+                                ((v `isInScope` subst) || not (isLocallyDefined v))
+          }) us sc
+       -- Black list anything that is in scope or imported.
+       -- The in-scope thing arranges *not* to black list inlinings that are
+       -- completely inside the switch-off-inlining block.
+       -- This allows simplification to proceed un-hindered inside the block.
+       --
+       -- At one time I had an exception for constant Ids (constructors, primops)
+       --                    && (old_black_list v || not (isConstantId v ))
+       -- because (a) some don't have bindings, so we never want not to inline them
+       --         (b) their defns are very seldom big, so there's no size penalty
+       --             to inline them
+       -- But that failed because if we inline (say) [] in build's rhs, then
+       -- the exported thing doesn't match rules
+       --
+       -- But we must inline primops (which have compulsory unfoldings) in the
+       -- last phase of simplification, because they don't have bindings.
+       -- The simplifier now *never* inlines blacklisted things (even if they
+       -- have compulsory unfoldings) so we must not black-list compulsory
+       -- unfoldings inside INLINE prags.
+  where
+    subst         = seSubst env
+    old_black_list = seBlackList env
 \end{code}
 
 
@@ -780,6 +803,14 @@ emptySimplEnv sw_chkr in_scope black_list
               seSubst = mkSubst in_scope emptySubstEnv }
        -- The top level "enclosing CC" is "SUBSUMED".
 
+getEnv :: SimplM SimplEnv
+getEnv env us sc = (env, us, sc)
+
+setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
+setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m 
+                           (SimplEnv {seSubst = old_subst}) us sc 
+  = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
+
 getSubst :: SimplM Subst
 getSubst env us sc = (seSubst env, us, sc)
 
@@ -807,15 +838,9 @@ setInScope :: InScopeSet -> SimplM a -> SimplM a
 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
   = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
 
-modifyInScope :: CoreBndr -> SimplM a -> SimplM a
-modifyInScope v m env us sc 
-#ifdef DEBUG
-  | not (v `isInScope` seSubst env)
-  = pprTrace "modifyInScope: not in scope:" (ppr v)
-    m env us sc
-#endif
-  | otherwise
-  = extendInScope v m env us sc
+modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
+modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc 
+  = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
 
 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc