From e3396ef671c1e84182a766d21606900e72d86f45 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Mon, 19 May 2025 18:27:42 +0100 Subject: [PATCH 1/7] op_dump(): handle SVOPs and METHOPs separately Currently SVOPs and METHOPs are dumped using the same case branch within op_dump(). This works at the moment because the op_sv field and the op_meth_sv field happen to occupy the same offset within their respective structs. This commit separates out the handling of those two OP classes, which will also allow another commit shortly to handle METHOD ops more specifically. OP_COREARGS is also added as another dumpable SVOP type (i.e. an op which may have an SV hanging off op_sv). This commit also makes it so that it now always displays the value of the op_sv field of SVOPs, which on threaded builds starts off holding an SV, but later gets set to 0 to indicate that the SV has been moved to the pad. --- dump.c | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/dump.c b/dump.c index 780a2df3f879..4d2a0e8cbe60 100644 --- a/dump.c +++ b/dump.c @@ -1380,6 +1380,25 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_CONST: case OP_HINTSEVAL: + case OP_COREARGS: + /* an SVOP. On non-threaded builds, these OPs use op_sv to hold + * the SV associated with the const / hints hash / op num. + * On threaded builds, op_sv initially holds the SV, then at the + * end of compiling the sub, the SV is moved into the pad by + * op_relocate_sv() and indexed by op_targ. + * XXX Currently the SV isn't relocated for OP_COREARGS. + */ + S_opdump_indent(aTHX_ o, level, bar, file, + "OP_SV = 0x%" UVxf "\n", cSVOPo->op_sv); +#ifdef USE_ITHREADS + /* SV is stored in the pad, and the right pad may not be active + * here, so skip dumping the SV */ +#else + S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", + SvPEEK(cSVOP_sv)); +#endif + break; + case OP_METHOD_NAMED: case OP_METHOD_SUPER: case OP_METHOD_REDIR: @@ -1391,6 +1410,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) SvPEEK(cMETHOPo_meth)); #endif break; + case OP_NULL: if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) break; From c5a974dbea1928f261c9b30e3a1027bdd9330504 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Wed, 21 May 2025 13:03:52 +0100 Subject: [PATCH 2/7] op_dump:(): display RCLASS on METHOD ops Some types of method call have a redirect class in addition to the method name, e.g. $obj->BAR::foo(). This value 'BAR' wasn't being displayed by op_dump(). So this commit makes it do so. I also took the opportunity to add comments to the various OP_METHOD_FOO cases to identify what sort of method calls it handled, and added a stub OP_METHOD case rather than it just being handled by the default branch. This is to make it clearer that OP_METHOD *does* exist, but it doesn't have any values (like 'foo' or 'BAR') which need dumping. --- dump.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/dump.c b/dump.c index 4d2a0e8cbe60..19d8f0410269 100644 --- a/dump.c +++ b/dump.c @@ -1399,15 +1399,25 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) #endif break; - case OP_METHOD_NAMED: - case OP_METHOD_SUPER: - case OP_METHOD_REDIR: - case OP_METHOD_REDIR_SUPER: + case OP_METHOD: /* $obj->$foo */ + break; + + case OP_METHOD_NAMED: /* $obj->foo */ + case OP_METHOD_SUPER: /* $obj->SUPER::foo */ + case OP_METHOD_REDIR: /* $obj->BAR::foo */ + case OP_METHOD_REDIR_SUPER: /* $obj->BAR::SUPER::foo */ #ifndef USE_ITHREADS /* with ITHREADS, consts are stored in the pad, and the right pad * may not be active here, so skip */ + /* display method name (e.g. 'foo') */ S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", SvPEEK(cMETHOPo_meth)); + + /* display redirect class (e.g. 'BAR') */ + if (optype == OP_METHOD_REDIR || optype == OP_METHOD_REDIR_SUPER) { + S_opdump_indent(aTHX_ o, level, bar, file, "RCLASS = %s\n", + SvPEEK(cMETHOPo_rclass)); + } #endif break; From fbfc5f692fec5559f374fd2ea2ed5715b69d7473 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Tue, 20 May 2025 09:10:03 +0100 Subject: [PATCH 3/7] op_dump(): display SVs on threaded builds Some OPs, such as OP_CONST, OP_GVSV and OP_METHOD_NAMED, point to an SV or GV. In threaded builds, these SVs are moved to the pad and an index is stored in the OP instead (typically op_targ or op_padix). When op_dump() is called upon to display an OP (typically during debugging or via perl -Dx), then currently, information about the linked SV (e.g. the glob's name) is displayed only on non-threaded builds, since op_dump() can't assume that PL_curpad[] is associated with this particular op. Thus you get things like an OP_CONST being dumped that doesn't display the const's value. This is annoying during debugging. This commit makes it so that when dumping common OPs which have an SV in the pad, it tries to find the CV, if any, associated with that op, and if so, uses that CV's pad to lookup the value. If unsuccessful, it falls back to not displaying the SV. This commit uses two main techniques to find the CV. Both rely on first following the op_parent chain from the current op to find the root op of the optree which this op is embedded in. Then, if compiling, it compares this with the roots of the optrees currently on the parse stack, and so, uses the associated CV which is is pointed to from that slot on the parse stack. Or, if runtime, looks for a SUB or EVAL context on the context stack and sees if that sub or eval's CvROOT() / PL_eval_root matches the root of the op's tree. The next two commits will extend this to handle 'perl -Dx' too. This commit also tries to show the state of the fields on CONST and METHOD_FOO ops which can hold an SV or index, in addition to showing the SV that is retrieved from them. Here are examples of some op dumps on threaded builds before and after this commit: -------------------------------------------------------------- const SVOP(0x2a051578) ===> 6 [gvsv 0x2a0515e8] TARG = 2 FLAGS = (SCALAR,SLABBED,MORESIB) gvsv PADOP(0x2a0515e8) ===> 5 [sassign 0x2a051538] FLAGS = (SCALAR,SLABBED) PADIX = 1 method_redir METHOP(0x13dd4318) ===> 5 [entersub 0x13dd4358] TARG = 4 FLAGS = (UNKNOWN,SLABBED) -------------------------------------------------------------- const SVOP(0x22f655b8) ===> 6 [gvsv 0x22f65628] TARG = 2 FLAGS = (SCALAR,SLABBED,MORESIB) OP_SV = 0x0 SV = PV("abc"\0) (0x22f65768) gvsv PADOP(0x22f65628) ===> 5 [sassign 0x22f65578] FLAGS = (SCALAR,SLABBED) PADIX = 1 GV = main::x (0x22f58f20) method_redir METHOP(0x1d83f318) ===> 5 [entersub 0x1d83f358] TARG = 4 FLAGS = (UNKNOWN,SLABBED) OP_METH_SV = 0x0 METH = PV("foo") (0x1d833010) RCLASS_TARG = 2 RCLASS = PV("BAR") (0x1d83f638) -------------------------------------------------------------- --- dump.c | 194 ++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 173 insertions(+), 21 deletions(-) diff --git a/dump.c b/dump.c index 19d8f0410269..bf94d26e9ace 100644 --- a/dump.c +++ b/dump.c @@ -1093,6 +1093,123 @@ S_pm_description(pTHX_ const PMOP *pm) return desc; } + +/* S_get_sv_from_pad(): a helper function for op_dump(). + * + * On threaded builds, try to find the SV indexed by the OP o (e.g. via + * op_targ or op_padix) at pad offset po. + * Since an op can be dumped at any time, there is no guarantee that the + * OP is associated with the current PL_curpad. So try to find the currently + * running CV or eval, and see if it contains the OP. Or if it's + * compile-time, see if the op is contained within one of the op subtrees + * on the parser stack. + * + * Return NULL if it can't be found. + * + * 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) +{ + PADLIST *padlist; /* declare early to work round compiler quirks */ + + if (!po) + return NULL; + + CV *cv = NULL; + + /* 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 + * stack. Limit the number of hops, in case there is some sort of + * loop or other weirdness. + */ + int n = 100; + OP *oproot = (OP*)o; + while (1) { + if (--n <= 0) + return NULL; + OP *p = op_parent(oproot); + if (!p) + break; + oproot = p; + } + + /* We may be compiling; so first look for the op within the subtrees + * on the parse stack, if any */ + if (PL_parser && PL_parser->stack) { + yy_stack_frame *ps; + + for (ps = PL_parser->ps; ps > PL_parser->stack; ps--) { + if (ps->val.opval == oproot) { + cv = ps->compcv; + if (!cv) + return NULL; /* this shouldn't actually happen */ + goto got_cv; + } + } + } + + /* Find the currently running CV or eval, if any, and see if our op + * is part of that CV's optree. If no contexts are found, we're + * probably running the main program. + */ + I32 i; + for (i = cxstack_ix; i >= 0; i--) { + const PERL_CONTEXT * const cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + if (CxTRY(cx)) /* eval { } doesn't have a separate optree */ + continue; + cv = cxstack[i].blk_eval.cv; + /* XXX note that an EVAL's CV doesn't actually hold a pointer + * to the optree's root; we have to hope that PL_eval_root + * does instead */ + if (!cv || !CvEVAL(cv) || oproot != PL_eval_root) + continue; + goto got_cv; + case CXt_SUB: + if (cx->cx_type & CXp_SUB_RE_FAKE) + continue; + /* FALLTHROUGH */ + case CXt_FORMAT: + cv = cxstack[i].blk_sub.cv; + if (!cv || CvISXSUB(cv) || oproot != CvROOT(cv)) + continue; + goto got_cv; + } + } + + if (PL_main_cv && PL_main_root == oproot) { + cv = PL_main_cv; + goto got_cv; + } + return NULL; + + /* Lookup the entry in the pad associated with this CV. + * Note that for SVs moved into the pad, they are shared at all pad + * depths, so we only have to look at depth 1 and not worry about + * CvDEPTH(). */ + got_cv: + padlist = CvPADLIST(cv); + if (!padlist) + return NULL; + PAD *comppad = PadlistARRAY(padlist)[1]; + if (!comppad) + return NULL; + SV **curpad = AvARRAY(comppad); + if (!curpad) + return NULL; + return curpad[po]; +} +#endif + + /* =for apidoc pmop_dump @@ -1346,15 +1463,21 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_AELEMFAST: case OP_GVSV: case OP_GV: + { + GV *gv; #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); #else - S_opdump_indent(aTHX_ o, level, bar, file, - "GV = %" SVf " (0x%" UVxf ")\n", - SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); + gv = (GV*)cSVOPx(o)->op_sv; #endif + if (gv) + S_opdump_indent(aTHX_ o, level, bar, file, + "GV = %" SVf " (0x%" UVxf ")\n", + SVfARG(S_gv_display(aTHX_ gv)), PTR2UV(gv)); break; + } case OP_MULTIDEREF: { @@ -1388,15 +1511,23 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) * op_relocate_sv() and indexed by op_targ. * XXX Currently the SV isn't relocated for OP_COREARGS. */ - S_opdump_indent(aTHX_ o, level, bar, file, - "OP_SV = 0x%" UVxf "\n", cSVOPo->op_sv); + { + SV *sv = cSVOPo->op_sv; + if (!sv) { + S_opdump_indent(aTHX_ o, level, bar, file, + "OP_SV = 0x0\n"); #ifdef USE_ITHREADS - /* SV is stored in the pad, and the right pad may not be active - * here, so skip dumping the SV */ -#else - S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", - SvPEEK(cSVOP_sv)); + sv = S_get_sv_from_pad(aTHX_ o, o->op_targ); #endif + } + + if (sv) + S_opdump_indent(aTHX_ o, level, bar, file, + "%s = %s (0x%" UVxf ")\n", + cSVOPo->op_sv ? "OP_SV" : "SV", + SvPEEK(sv), + PTR2UV(sv)); + } break; case OP_METHOD: /* $obj->$foo */ @@ -1406,19 +1537,40 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_METHOD_SUPER: /* $obj->SUPER::foo */ case OP_METHOD_REDIR: /* $obj->BAR::foo */ case OP_METHOD_REDIR_SUPER: /* $obj->BAR::SUPER::foo */ -#ifndef USE_ITHREADS - /* with ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so skip */ - /* display method name (e.g. 'foo') */ - S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", - SvPEEK(cMETHOPo_meth)); + { + /* display method name (e.g. 'foo') */ + SV *sv = cMETHOPo->op_u.op_meth_sv; + if (!sv) { + 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); +#endif + } - /* display redirect class (e.g. 'BAR') */ - if (optype == OP_METHOD_REDIR || optype == OP_METHOD_REDIR_SUPER) { - S_opdump_indent(aTHX_ o, level, bar, file, "RCLASS = %s\n", - SvPEEK(cMETHOPo_rclass)); - } + if (sv) + S_opdump_indent(aTHX_ o, level, bar, file, + "%s = %s (0x%" UVxf ")\n", + cMETHOPo->op_u.op_meth_sv ? "OP_METH_SV" : "METH", + SvPEEK(sv), + PTR2UV(sv)); + + if (optype == OP_METHOD_REDIR || optype == OP_METHOD_REDIR_SUPER) { + /* display redirect class (e.g. 'BAR') */ +#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); +#else + sv = cMETHOPo->op_rclass_sv; #endif + if (sv) + S_opdump_indent(aTHX_ o, level, bar, file, + "RCLASS = %s (0x%" UVxf ")\n", + SvPEEK(sv), + PTR2UV(sv)); + } + } break; case OP_NULL: From cec11302fb6b5ac5c6dbca51a65757bfab6ecc48 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 24 May 2025 10:38:40 +0100 Subject: [PATCH 4/7] Perl_dump_sub_perl: call S_do_op_dump_bar directly A minor refactor in preparation for the next commit: make Perl_dump_sub_perl() invoke S_do_op_dump_bar() directly, rather than going via op_dump() which indirectly calls the former. Should make no functional difference. --- dump.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/dump.c b/dump.c index bf94d26e9ace..fd7d736f3547 100644 --- a/dump.c +++ b/dump.c @@ -873,6 +873,12 @@ Perl_dump_sub(pTHX_ const GV *gv) dump_sub_perl(gv, FALSE); } + +/* forward decl */ +static void +S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); + + void Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) { @@ -901,7 +907,7 @@ Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) PTR2UV(CvXSUB(cv)), (int)CvXSUBANY(cv).any_i32); else if (CvROOT(cv)) - op_dump(CvROOT(cv)); + S_do_op_dump_bar(aTHX_ 0, 0, Perl_debug_log, CvROOT(cv)); else Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); } @@ -966,11 +972,6 @@ S_gv_display(pTHX_ GV *gv) -/* forward decl */ -static void -S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); - - static void S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) { From 0e4fa29b1eadb1e191d15285542686fc9912ab65 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 24 May 2025 10:53:30 +0100 Subject: [PATCH 5/7] 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. --- dump.c | 45 +++++++++++++++++++++++++++-------------- ext/Devel-Peek/t/Peek.t | 5 +++-- 2 files changed, 33 insertions(+), 17 deletions(-) diff --git a/dump.c b/dump.c index fd7d736f3547..3c3bb4178e30 100644 --- a/dump.c +++ b/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, "\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,7 +1803,7 @@ 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); } } @@ -1796,7 +1811,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) 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); } diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 5df93c02e494..3343bb842fc8 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/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'], From 7738c44817fd7b016df23ca09d781598537d1ed7 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 24 May 2025 12:30:53 +0100 Subject: [PATCH 6/7] op_dump(): add RCATLINE, ANONCODE as SV-holding The OP_RCATLINE op has a GV attached. So When dumping OPs, display its value, similarly to what is already done for other GV-holding ops like OP_GVSV. Similarly, OP_ANONCODE has a CV attached. --- dump.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dump.c b/dump.c index 3c3bb4178e30..8fce61b58291 100644 --- a/dump.c +++ b/dump.c @@ -1478,6 +1478,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o, case OP_AELEMFAST: case OP_GVSV: case OP_GV: + case OP_RCATLINE: { GV *gv; #ifdef USE_ITHREADS @@ -1519,6 +1520,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o, case OP_CONST: case OP_HINTSEVAL: case OP_COREARGS: + case OP_ANONCODE: /* an SVOP. On non-threaded builds, these OPs use op_sv to hold * the SV associated with the const / hints hash / op num. * On threaded builds, op_sv initially holds the SV, then at the From d8426837f51adf83a57de4659944f3dab686333a Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 24 May 2025 13:32:37 +0100 Subject: [PATCH 7/7] Perl_debop() / -Dt: display some OP args better Perl_debop() displays an op in a compact one-line form, typically used by 'perl -Dt' to show the next op to be executed. This commit improves the display of some ops slightly: in particular, where the name of a GV argument to the op, or the name of the associated lexical var is displayed, sometimes this wasn't being done, for example for the new op OP_PADSV_STORE, which probably just got missed when being added. It also now displays: * the name of the lexical var for ops which have the OPpTARGET_MY optimisation; * the name of the method and redirect class for method ops; * the index of the aelemfast and aelemfast_lex op For example, with the following code: my ($sum); sub Bar::foo {} my $obj = bless {}, 'Foo'; my @lexary; $^D='t'; $sum = 1; $sum = $ary[-2] + $lexary[3]; $obj->Bar::foo(); $x .= <>; then before, the -Dt output for certain lines was: padsv_store aelemfast aelemfast_lex add method_redir rcatline and is now: padsv_store($sum) aelemfast(main::ary)[-2] aelemfast_lex(@lexary)[3] add($sum) method_redir(PV("foo"))(PV("Bar")) rcatline(main::ARGV) --- dump.c | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/dump.c b/dump.c index 8fce61b58291..100b341b97d5 100644 --- a/dump.c +++ b/dump.c @@ -3517,15 +3517,40 @@ Perl_debop(pTHX_ const OP *o) break; case OP_GVSV: case OP_GV: + case OP_AELEMFAST: + case OP_RCATLINE: PerlIO_printf(Perl_debug_log, "(%" SVf ")", SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); + if (o->op_type == OP_AELEMFAST) + do_fast_ix: + PerlIO_printf(Perl_debug_log, "[%" IVdf "]", + (IV)(I8)o->op_private); + break; + + case OP_METHOD_NAMED: /* $obj->foo */ + case OP_METHOD_SUPER: /* $obj->SUPER::foo */ + case OP_METHOD_REDIR: /* $obj->BAR::foo */ + case OP_METHOD_REDIR_SUPER: /* $obj->BAR::SUPER::foo */ + PerlIO_printf(Perl_debug_log, "(%s)", + SvPEEK(cMETHOPo_meth)); + if ( o->op_type == OP_METHOD_REDIR + || o->op_type == OP_METHOD_REDIR_SUPER) + { + PerlIO_printf(Perl_debug_log, "(%s)", + SvPEEK(cMETHOPo_rclass)); + } break; case OP_PADSV: case OP_PADAV: case OP_PADHV: case OP_ARGELEM: + case OP_PADSV_STORE: + case OP_AELEMFAST_LEX: + do_lex: S_deb_padvar(aTHX_ o->op_targ, 1, 1); + if (o->op_type == OP_AELEMFAST_LEX) + goto do_fast_ix; break; case OP_PADRANGE: @@ -3544,6 +3569,10 @@ Perl_debop(pTHX_ const OP *o) break; default: + if ( (PL_opargs[o->op_type] & OA_TARGLEX) + && (o->op_private & OPpTARGET_MY)) + goto do_lex; + break; } PerlIO_printf(Perl_debug_log, "\n");