From 605ed32b4cd3972520f156d3f2924ba3c2af4505 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 13 Mar 1998 17:36:36 +0000
Subject: [PATCH] [project @ 1998-03-13 17:36:27 by simonpj] Still a lingering
lost-Eval-dict bug; but nearly there!
---
ghc/compiler/simplCore/SimplEnv.lhs | 20 ++++++++++++-----
ghc/compiler/simplCore/SimplVar.lhs | 4 ++--
ghc/compiler/simplCore/Simplify.lhs | 2 +-
ghc/compiler/specialise/Specialise.lhs | 31 +++++++++++++++++++-------
4 files changed, 40 insertions(+), 17 deletions(-)
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 18c4aec68244..587406afad7a 100644
--- 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 498549379b7a..b1d6664f63c8 100644
--- 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 f4eef9f93046..8bde1385247a 100644
--- 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 9886e6bcf778..ab4edecf4fcd 100644
--- 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
--
GitLab