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 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]