[project @ 1998-03-13 17:36:27 by simonpj]

Still a lingering lost-Eval-dict bug; but nearly there!

diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 18c4aec..587406a 100644 (file)
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -53,7 +53,10 @@ import CoreUnfold    ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
                          Unfolding(..), FormSummary(..),
                          calcUnfoldingGuidance )
 import CoreUtils       ( coreExprCc )
-import CostCentre      ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, costsAreSubsumed, noCostCentreAttached )
+import CostCentre      ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, 
+                         costsAreSubsumed, noCostCentreAttached, subsumedCosts,
+                         currentOrSubsumedCosts
+                       )
 import FiniteMap       -- lots of things
 import Id              ( getInlinePragma,
                          nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
@@ -177,11 +180,19 @@ type StuffAboutId = (OutId,               -- Always has the same unique as the
 nullSimplEnv :: SwitchChecker -> SimplEnv
 
 nullSimplEnv sw_chkr
-  = SimplEnv sw_chkr useCurrentCostCentre 
+  = SimplEnv sw_chkr subsumedCosts
             (emptyTyVarSet, emptyTyVarEnv)
             (nullIdEnv, nullIdEnv)
             nullConApps
 
+       -- The top level "enclosing CC" is "SUBSUMED".  But the enclosing CC
+       -- for the rhs of top level defs is "OST_CENTRE".  Consider
+       --      f = \x -> e
+       --      g = \y -> let v = f y in scc "x" (v ...)
+       -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
+       -- want to inline "v" since its CC is dynamically determined.
+
+
 getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
 getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
 
@@ -282,9 +293,6 @@ switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_app
 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 
 setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
-  | costsAreSubsumed encl_cc
-  = env
-  | otherwise
   = SimplEnv chkr encl_cc ty_env id_env con_apps
 
 getEnclosingCC :: SimplEnv -> CostCentre
@@ -643,7 +651,7 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst)
               mkSimplUnfoldingGuidance chkr out_id rhs
 
        -- Attach a cost centre to the RHS if necessary
-    rhs_w_cc  | isCurrentCostCentre encl_cc
+    rhs_w_cc  | currentOrSubsumedCosts encl_cc
              || not (noCostCentreAttached (coreExprCc rhs))
              = rhs
              | otherwise

diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 4985493..b1d6664 100644 (file)
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -172,7 +172,7 @@ When we hit a binder we may need to
 
 \begin{code}
 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
-simplBinder env (id, _)
+simplBinder env (id, occ_info)
   |  not_in_scope              -- Not in scope, so no need to clone
   && empty_ty_subst            -- No type substitution to do inside the Id
   && isNullIdEnv id_subst      -- No id substitution to do inside the Id
@@ -219,7 +219,7 @@ simplBinder env (id, _)
     empty_ty_subst      = isEmptyTyVarEnv ty_subst
     not_in_scope        = not (id `elemIdEnv` in_scope_ids)
 
-    new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', noBinderInfo, NoUnfolding)
+    new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
     
     ty                  = idType id
     ty'                 = instantiateTy ty_subst ty

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index f4eef9f..8bde138 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -500,7 +500,7 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id
 
   | otherwise  -- OK, use the big hammer
   =    -- Deal with the big lambda part
-    simplTyBinders env tyvars                  `thenSmpl` \ (lam_env, tyvars') ->
+    simplTyBinders rhs_env tyvars                      `thenSmpl` \ (lam_env, tyvars') ->
     let
        body_ty  = applyTys rhs_ty (mkTyVarTys tyvars')
     in

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 9886e6b..ab4edec 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -1167,17 +1167,32 @@ instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
 instantiateDictRhs ty_env id_env rhs
   = go rhs
   where
-    go (App e1 (VarArg a)) = App (go e1) (VarArg (lookupId id_env a))
-    go (App e1 (TyArg t))  = App (go e1) (TyArg (instantiateTy ty_env t))
-    go (Var v)            = Var (lookupId id_env v)
-    go (Lit l)            = Lit l
+    go_arg (VarArg a) = VarArg (lookupId id_env a)
+    go_arg (TyArg t)  = TyArg (instantiateTy ty_env t)
+
+    go (App e1 arg)   = App (go e1) (go_arg arg)
+    go (Var v)       = Var (lookupId id_env v)
+    go (Lit l)       = Lit l
+    go (Con con args) = Con con (map go_arg args)
+    go (Case e alts)  = Case (go e) alts               -- See comment below re alts
+    go other         = pprPanic "instantiateDictRhs" (ppr rhs)
 
 dictRhsFVs :: CoreExpr -> IdSet
        -- Cheapo function for simple RHSs
-dictRhsFVs (App e1 (VarArg a)) = dictRhsFVs e1 `addOneToIdSet` a
-dictRhsFVs (App e1 (TyArg t))  = dictRhsFVs e1
-dictRhsFVs (Var v)            = unitIdSet v
-dictRhsFVs (Lit l)            = emptyIdSet
+dictRhsFVs e
+  = go e
+  where
+    go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
+    go (App e1 (TyArg t))  = go e1
+    go (Var v)            = unitIdSet v
+    go (Lit l)            = emptyIdSet
+    go (Con _ args)        = mkIdSet [id | VarArg id <- args]
+
+    go (Case e _)         = go e       -- Claim: no free dictionaries in the alternatives
+                                       -- These case expressions are of the form
+                                       --   case d of { D a b c -> b }
+
+    go other              = pprPanic "dictRhsFVs" (ppr e)
 
 
 addIdSpecialisations id spec_stuff