From 605ed32b4cd3972520f156d3f2924ba3c2af4505 Mon Sep 17 00:00:00 2001 From: simonpj 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 18c4aec..587406a 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 4985493..b1d6664 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 f4eef9f..8bde138 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 9886e6b..ab4edec 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 -- 1.7.10.4