[Git][ghc/ghc][master] Improve debug tracing for substitution
Marge Bot
gitlab at gitlab.haskell.org
Wed Jul 1 19:42:56 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b316804d by Simon Peyton Jones at 2020-07-01T15:42:49-04:00
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
- - - - -
8 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Subst.hs
Changes:
=====================================
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
--------------
=====================================
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 }
=====================================
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
=====================================
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
=====================================
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)
=====================================
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',
=====================================
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
=====================================
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]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b316804dbafe1d0287fd33f656b7ce5711ec34f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b316804dbafe1d0287fd33f656b7ce5711ec34f7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200701/1ee93983/attachment-0001.html>
More information about the ghc-commits
mailing list