diff --git a/dump.c b/dump.c index 780a2df3f879..100b341b97d5 100644 --- a/dump.c +++ b/dump.c @@ -873,6 +873,13 @@ 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, + CV* rootcv); + + void Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) { @@ -901,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)) - op_dump(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"); } @@ -966,13 +973,9 @@ 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) +S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm, + CV* rootcv) { UV kidbar; @@ -1012,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); } } @@ -1021,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, @@ -1034,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); } @@ -1093,6 +1096,131 @@ 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. + * + * 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, CV *rootcv) +{ + PADLIST *padlist; /* declare early to work round compiler quirks */ + + if (!po) + return NULL; + + 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 + * 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 @@ -1178,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; @@ -1346,15 +1478,22 @@ 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 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, rootcv); #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: { @@ -1380,17 +1519,78 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_CONST: case OP_HINTSEVAL: - case OP_METHOD_NAMED: - case OP_METHOD_SUPER: - case OP_METHOD_REDIR: - case OP_METHOD_REDIR_SUPER: -#ifndef USE_ITHREADS - /* with ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so skip */ - S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", - SvPEEK(cMETHOPo_meth)); + 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 + * 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. + */ + { + SV *sv = cSVOPo->op_sv; + if (!sv) { + 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, rootcv); +#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 */ + 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 */ + { + /* 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, rootcv); +#endif + } + + 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, + rootcv); +#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: if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) break; @@ -1468,7 +1668,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: @@ -1605,7 +1805,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); } } @@ -1613,7 +1813,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); } @@ -3317,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: @@ -3344,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"); 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'],