Improve 'perl -Dx' debug output on threaded builds

A couple of commits ago I added a mechanism to display the values of the
SV for ops (such as OP_CONST and OP_GVSV) on threaded builds when
possible, where the SV has been moved into the pad. This commit extends
that mechanism to work when a sub's optree is being dumped via the '-Dx'
perl command-line switch.

That previous commit tried to find the CV (and thus pad) associated with
the op being dumped by rummaging around on the context and parse stacks.
But the -Dx mechanism is neither of those things. It dumps all the subs
it can find in packages after compilation, but before execution.

This commit adds an extra parameter to S_do_op_dump_bar() which
optionally indicates what CV is having its optree dumped. The -Dx
mechanism can use this parameter to pass a hint to the SV-in-pad finding
code. If the parameter is null, it falls back to the mechanisms added
in the previous commits.

Author: iabyn

dump.c

@@ -876,7 +876,8 @@ Perl_dump_sub(pTHX_ const GV *gv)
 
 /* forward decl */
 static void
-S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
+S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
+                    CV* rootcv);
 
 
 void
@@ -907,7 +908,7 @@ Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
             PTR2UV(CvXSUB(cv)),
             (int)CvXSUBANY(cv).any_i32);
     else if (CvROOT(cv))
-        S_do_op_dump_bar(aTHX_ 0, 0, Perl_debug_log, CvROOT(cv));
+        S_do_op_dump_bar(aTHX_ 0, 0, Perl_debug_log, CvROOT(cv), cv);
     else
         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 }
@@ -973,7 +974,8 @@ S_gv_display(pTHX_ GV *gv)
 
 
 static void
-S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
+S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm,
+                   CV* rootcv)
 {
     UV kidbar;
 
@@ -1013,7 +1015,7 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
             S_do_op_dump_bar(aTHX_ level + 2,
                 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
-                file, pm->op_pmreplrootu.op_pmreplroot);
+                file, pm->op_pmreplrootu.op_pmreplroot, rootcv);
         }
     }
 
@@ -1022,7 +1024,7 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
             S_do_op_dump_bar(aTHX_ level + 2,
                             (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
-                            file, pm->op_code_list);
+                            file, pm->op_code_list, rootcv);
         }
         else
             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
@@ -1035,7 +1037,7 @@ void
 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 {
     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
-    S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
+    S_do_pmop_dump_bar(aTHX_ level, 0, file, pm, NULL);
 }
 
 
@@ -1107,13 +1109,16 @@ S_pm_description(pTHX_ const PMOP *pm)
  *
  * Return NULL if it can't be found.
  *
+ * Sometimes the caller *does* know what CV is being dumped; if so, it
+ * is passed as rootcv.
+ *
  * Since this may be called during debugging and things may not be in a
  * sane state, be conservative, and if in doubt, return NULL.
  */
 
 #ifdef USE_ITHREADS
 static SV *
-S_get_sv_from_pad(pTHX_ const OP *o, PADOFFSET po)
+S_get_sv_from_pad(pTHX_ const OP *o, PADOFFSET po, CV *rootcv)
 {
     PADLIST *padlist; /* declare early to work round compiler quirks */
 
@@ -1122,6 +1127,11 @@ S_get_sv_from_pad(pTHX_ const OP *o, PADOFFSET po)
 
     CV *cv = NULL;
 
+    if (rootcv) {
+        cv = rootcv;
+        goto got_cv;
+    }
+
     /* Find the root of the optree this op is embedded in. For a compiled
      * sub, this root will typically be a leavesub or similar attached to
      * a CV. If compiling, this may be a small subtree on the parser
@@ -1296,10 +1306,14 @@ const char * const op_class_names[] = {
  * For heavily nested output, the level may exceed the number of bits
  * in bar; in this case the first few columns in the output will simply
  * not have a bar, which is harmless.
+ *
+ * rootcv is the CV (if any) whose CvROOT() is the root of the optree
+ * currently being dumped.
  */
 
 static void
-S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
+S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
+                 CV* rootcv)
 {
     const OPCODE optype = o->op_type;
 
@@ -1469,7 +1483,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
 #ifdef USE_ITHREADS
         S_opdump_indent(aTHX_ o, level, bar, file,
                         "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
-        gv = (GV*)S_get_sv_from_pad(aTHX_ o, cPADOPx(o)->op_padix);
+        gv = (GV*)S_get_sv_from_pad(aTHX_ o, cPADOPx(o)->op_padix, rootcv);
 #else
         gv = (GV*)cSVOPx(o)->op_sv;
 #endif
@@ -1518,7 +1532,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
                 S_opdump_indent(aTHX_ o, level, bar, file,
                             "OP_SV = 0x0\n");
 #ifdef USE_ITHREADS
-                sv = S_get_sv_from_pad(aTHX_ o, o->op_targ);
+                sv = S_get_sv_from_pad(aTHX_ o, o->op_targ, rootcv);
 #endif
             }
 
@@ -1545,7 +1559,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
                 S_opdump_indent(aTHX_ o, level, bar, file,
                             "OP_METH_SV = 0x0\n");
 #ifdef USE_ITHREADS
-                sv = S_get_sv_from_pad(aTHX_ o, o->op_targ);
+                sv = S_get_sv_from_pad(aTHX_ o, o->op_targ, rootcv);
 #endif
             }
 
@@ -1561,7 +1575,8 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
 #ifdef USE_ITHREADS
                 S_opdump_indent(aTHX_ o, level, bar, file,
                     "RCLASS_TARG = %" IVdf "\n", (IV)cMETHOPo->op_rclass_targ);
-                sv = S_get_sv_from_pad(aTHX_ o, cMETHOPo->op_rclass_targ);
+                sv = S_get_sv_from_pad(aTHX_ o, cMETHOPo->op_rclass_targ,
+                                        rootcv);
 #else
                 sv = cMETHOPo->op_rclass_sv;
 #endif
@@ -1651,7 +1666,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
     case OP_MATCH:
     case OP_QR:
     case OP_SUBST:
-        S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
+        S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo, rootcv);
         break;
     case OP_LEAVE:
     case OP_LEAVEEVAL:
@@ -1788,15 +1803,15 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
             S_do_op_dump_bar(aTHX_ level,
                             (bar | cBOOL(OpHAS_SIBLING(kid))),
-                            file, kid);
+                            file, kid, rootcv);
     }
 }
 
 
 void
 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 {
-    S_do_op_dump_bar(aTHX_ level, 0, file, o);
+    S_do_op_dump_bar(aTHX_ level, 0, file, o, NULL);
 }
 
 

ext/Devel-Peek/t/Peek.t

@@ -1607,10 +1607,11 @@ dumpindent is 4 at -e line 1.
                  |   
 7                +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN]
                      FLAGS = (SCALAR,SLABBED)
-                     GV_OR_PADIX
+                     OPT_PADIX
+                     GV = t::DumpProg (0xNNN)
 EODUMP
 
-    $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
+    $e =~ s/^(\s+)OPT_PADIX\n/$threads ? "${1}PADIX = 2\n" : ""/me;
     $e =~ s/SVOP/PADOP/g if $threads;
     my $out = t::runperl
                  switches => ['-Ilib'],