diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2020-06-26 09:34:43 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-01 15:42:49 -0400 |
commit | b316804dbafe1d0287fd33f656b7ce5711ec34f7 (patch) | |
tree | 9ad01d19db6177bcd77733eadb2b292d65839328 /compiler/GHC/Core | |
parent | fb5a0d01d575cdb830918a6a0406f385de2749c2 (diff) | |
download | haskell-b316804dbafe1d0287fd33f656b7ce5711ec34f7.tar.gz |
Improve debug tracing for substitution
This patch improves debug tracing a bit (#18395)
* Remove the ancient SDoc argument to substitution, replacing it
with a HasDebugCallStack constraint. The latter does the same
job (indicate the call site) but much better.
* Add HasDebugCallStack to simpleOptExpr, exprIsConApp_maybe
I needed this to help nail the lookupIdSubst panic in
#18326, #17784
Diffstat (limited to 'compiler/GHC/Core')
-rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/CSE.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Rules.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Core/Subst.hs | 62 |
8 files changed, 59 insertions, 58 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 5df571ee1c..8d51457ae0 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1023,7 +1023,7 @@ etaInfoApp subst (Tick t e) eis etaInfoApp subst expr _ | (Var fun, _) <- collectArgs expr - , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun + , Var fun' <- lookupIdSubst subst fun , isJoinId fun' = subst_expr subst expr @@ -1132,13 +1132,16 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty --------------- --- Don't use short-cutting substitution - we may be changing the types of join --- points, so applying the in-scope set is necessary --- TODO Check if we actually *are* changing any join points' types - +------------ subst_expr :: Subst -> CoreExpr -> CoreExpr -subst_expr = substExpr (text "GHC.Core.Opt.Arity:substExpr") +-- Apply a substitution to an expression. We use substExpr +-- not substExprSC (short-cutting substitution) because +-- we may be changing the types of join points, so applying +-- the in-scope set is necessary. +-- +-- ToDo: we could instead check if we actually *are* +-- changing any join points' types, and if not use substExprSC. +subst_expr = substExpr -------------- diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index d6f37f6eb5..019b578db2 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -775,7 +775,7 @@ csEnvSubst :: CSEnv -> Subst csEnvSubst = cs_subst lookupSubst :: CSEnv -> Id -> OutExpr -lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index a57550ddd2..b4b0ad7062 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -1804,7 +1804,7 @@ abstractFloats dflags top_lvl main_tvs floats body = ASSERT( notNull body_floats ) ASSERT( isNilOL (sfJoinFloats floats) ) do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) } + ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where is_top_lvl = isTopLevel top_lvl main_tv_set = mkVarSet main_tvs @@ -1818,7 +1818,7 @@ abstractFloats dflags top_lvl main_tvs floats body subst' = GHC.Core.Subst.extendIdSubst subst id poly_app ; return (subst', NonRec poly_id2 poly_rhs) } where - rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs + rhs' = GHC.Core.Subst.substExpr subst rhs -- tvs_here: see Note [Which type variables to abstract over] tvs_here = scopedSort $ @@ -1831,8 +1831,7 @@ abstractFloats dflags top_lvl main_tvs floats body ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) poly_pairs = [ mk_poly2 poly_id tvs_here rhs' | (poly_id, rhs) <- poly_ids `zip` rhss - , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats") - subst' rhs ] + , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] ; return (subst', Rec poly_pairs) } where (ids,rhss) = unzip prs diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 8bb47215a1..ee0590061c 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -860,7 +860,7 @@ lookupHowBound :: ScEnv -> Id -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id scSubstId :: ScEnv -> Id -> CoreExpr -scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v +scSubstId env v = lookupIdSubst (sc_subst env) v scSubstTy :: ScEnv -> Type -> Type scSubstTy env ty = substTy (sc_subst env) ty diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index ae3d1cb287..31b7541b50 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1008,7 +1008,7 @@ instance Outputable SpecEnv where , text "interesting =" <+> ppr interesting ]) specVar :: SpecEnv -> Id -> CoreExpr -specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v +specVar env v = Core.lookupIdSubst (se_subst env) v specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index e8be7389b2..f80f1951ed 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -917,7 +917,7 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) Var v2 | v1' == rnOccR rn_env v2 -> Just subst - | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 + | Var v2' <- lookupIdSubst flt_env v2 , v1' == v2' -> Just subst @@ -965,7 +965,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) where -- e2' is the result of applying flt_env to e2 e2' | isEmptyVarSet let_bndrs = e2 - | otherwise = substExpr (text "match_tmpl_var") flt_env e2 + | otherwise = substExpr flt_env e2 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' -- No further renaming to do on e2', diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index b2d67a5fad..8525fb292f 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -93,7 +93,7 @@ little dance in action; the full Simplifier is a lot more complicated. -} -simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr +simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr -- See Note [The simple optimiser] -- Do simple optimisation on an expression -- The optimisation is very straightforward: just @@ -125,7 +125,7 @@ simpleOptExpr dflags expr -- It's a bit painful to call exprFreeVars, because it makes -- three passes instead of two (occ-anal, and go) -simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr +simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith dflags subst expr = simple_opt_expr init_env (occurAnalyseExpr expr) @@ -218,7 +218,7 @@ simple_opt_expr env expr | Just clo <- lookupVarEnv (soe_inl env) v = simple_opt_clo env clo | otherwise - = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v + = lookupIdSubst (soe_subst env) v go (App e1 e2) = simple_app env e1 [(env,e2)] go (Type ty) = Type (substTy subst ty) @@ -293,7 +293,7 @@ mk_cast e co | isReflexiveCo co = e ---------------------- -- simple_app collects arguments for beta reduction -simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr +simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr simple_app env (Var v) as | Just (env', e) <- lookupVarEnv (soe_inl env) v @@ -306,7 +306,7 @@ simple_app env (Var v) as = simple_app (soeZapSubst env) (unfoldingTemplate unf) as | otherwise - , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v + , let out_fn = lookupIdSubst (soe_subst env) v = finish_app env out_fn as simple_app env (App e1 e2) as @@ -1064,7 +1064,8 @@ data ConCont = CC [CoreExpr] Coercion -- -- We also return the incoming InScopeSet, augmented with -- the binders from any [FloatBind] that we return -exprIsConApp_maybe :: InScopeEnv -> CoreExpr +exprIsConApp_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe (in_scope, id_unf) expr = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) @@ -1118,7 +1119,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr go (Right sub) floats (Var v) cont = go (Left (substInScope sub)) floats - (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + (lookupIdSubst sub v) cont go (Left in_scope) floats (Var fun) cont@(CC args co) @@ -1141,7 +1142,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr , bndrs `equalLength` args -- See Note [DFun arity check] , let subst = mkOpenSubst in_scope (bndrs `zip` args) = succeedWith in_scope floats $ - pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co + pushCoDataCon con (map (substExpr subst) dfun_args) co -- Look through unfoldings, but only arity-zero one; -- if arity > 0 we are effectively inlining a function call, @@ -1180,7 +1181,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr subst_co (Right s) co = GHC.Core.Subst.substCo s co subst_expr (Left {}) e = e - subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e + subst_expr (Right s) e = substExpr s e subst_bndr msubst bndr = (Right subst', bndr') @@ -1461,7 +1462,7 @@ pushCoercionIntoLambda in_scope x e co subst = extendIdSubst (mkEmptySubst in_scope') x (mkCast (Var x') co1) - in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) + in Just (x', substExpr subst e `mkCast` co2) | otherwise = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) Nothing diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 31e503158a..04ef9ef150 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -246,13 +246,13 @@ extendSubstList subst [] = subst extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' -lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr -lookupIdSubst doc (Subst in_scope ids _ _) v +lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr +lookupIdSubst (Subst in_scope ids _ _) v | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> doc <+> ppr v + | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v $$ ppr in_scope) Var v @@ -338,26 +338,25 @@ instance Outputable Subst where ************************************************************************ -} --- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only --- apply the substitution /once/: +substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr +-- Just like substExpr, but a no-op if the substitution is empty +substExprSC subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ + substExpr subst orig_expr + +-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember, +-- you may only apply the substitution /once/: -- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst] -substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExprSC doc subst orig_expr - | isEmptySubst subst = orig_expr - | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ - subst_expr doc subst orig_expr - -substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExpr doc subst orig_expr = subst_expr doc subst orig_expr - -subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr -subst_expr doc subst expr +substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr + -- HasDebugCallStack so we can track failures in lookupIdSubst +substExpr subst expr = go expr where - go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v + go (Var v) = lookupIdSubst subst v go (Type ty) = Type (substTy subst ty) go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit @@ -370,11 +369,11 @@ subst_expr doc subst expr -- lose a binder. We optimise the LHS of rules at -- construction time - go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) + go (Lam bndr body) = Lam bndr' (substExpr subst' body) where (subst', bndr') = substBndr subst bndr - go (Let bind body) = Let bind' (subst_expr doc subst' body) + go (Let bind body) = Let bind' (substExpr subst' body) where (subst', bind') = substBind subst bind @@ -382,13 +381,13 @@ subst_expr doc subst expr where (subst', bndr') = substBndr subst bndr - go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) + go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs) where (subst', bndrs') = substBndrs subst bndrs -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' -- that should be used by subsequent substitutions. -substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) +substBind, substBindSC :: HasDebugCallStack => Subst -> CoreBind -> (Subst, CoreBind) substBindSC subst bind -- Short-cut if the substitution is empty | not (isEmptySubst subst) @@ -405,10 +404,10 @@ substBindSC subst bind -- Short-cut if the substitution is empty rhss' | isEmptySubst subst' = rhss | otherwise - = map (subst_expr (text "substBindSC") subst') rhss + = map (substExpr subst') rhss substBind subst (NonRec bndr rhs) - = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) + = (subst', NonRec bndr' (substExpr subst rhs)) where (subst', bndr') = substBndr subst bndr @@ -417,7 +416,7 @@ substBind subst (Rec pairs) where (bndrs, rhss) = unzip pairs (subst', bndrs') = substRecBndrs subst bndrs - rhss' = map (subst_expr (text "substBind") subst') rhss + rhss' = map (substExpr subst') rhss -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply -- by running over the bindings with an empty substitution, because substitution @@ -638,7 +637,7 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) = df { df_bndrs = bndrs', df_args = args' } where (subst',bndrs') = substBndrs subst bndrs - args' = map (substExpr (text "subst-unf:dfun") subst') args + args' = map (substExpr subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -648,14 +647,14 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) = seqExpr new_tmpl `seq` unf { uf_tmpl = new_tmpl } where - new_tmpl = substExpr (text "subst-unf") subst tmpl + new_tmpl = substExpr subst tmpl substUnfolding _ unf = unf -- NoUnfolding, OtherCon ------------------ substIdOcc :: Subst -> Id -> Id -- These Ids should not be substituted to non-Ids -substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of +substIdOcc subst v = case lookupIdSubst subst v of Var v' -> v' other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) @@ -693,12 +692,11 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args , ru_fn = if is_local then subst_ru_fn fn_name else fn_name - , ru_args = map (substExpr doc subst') args - , ru_rhs = substExpr (text "foo") subst' rhs } + , ru_args = map (substExpr subst') args + , ru_rhs = substExpr subst' rhs } -- Do NOT optimise the RHS (previously we did simplOptExpr here) -- See Note [Substitute lazily] where - doc = text "subst-rule" <+> ppr fn_name (subst', bndrs') = substBndrs subst bndrs ------------------ @@ -707,7 +705,7 @@ substDVarSet subst fvs = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs where subst_fv subst fv acc - | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc + | isId fv = expr_fvs (lookupIdSubst subst fv) isLocalVar emptyVarSet $! acc | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc ------------------ @@ -715,7 +713,7 @@ substTickish :: Subst -> Tickish Id -> Tickish Id substTickish subst (Breakpoint n ids) = Breakpoint n (map do_one ids) where - do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst + do_one = getIdFromTrivialExpr . lookupIdSubst subst substTickish _subst other = other {- Note [Substitute lazily] |