In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/5219f5ec5c453357ab78722da5a91806251ffb67?hp=f5294d12c0aa55a61680444556e53554d881d9b0>
- Log ----------------------------------------------------------------- commit 5219f5ec5c453357ab78722da5a91806251ffb67 Author: David Mitchell <[email protected]> Date: Fri Jan 20 12:40:31 2017 +0000 S_do_op_dump_bar(): fix some weird indentation whitespace-only change M dump.c commit cd6e48741f9105d4b8da0e141bfdf362f1dd0961 Author: David Mitchell <[email protected]> Date: Tue Jan 17 17:40:32 2017 +0000 revamp the op_dump() output format This is mainly used for low-level debugging these days (higher level stuff like Concise having since been created), e.g. calling op_dump() from within a debugger or running with -Dx. Make it display more info, and use an ACSII-art tree to show the structure. The main changes are: * added 'ASCII-art' tree structure; * it now displays each op's class and address; * for op_next etc links, it now displays the type and address of the linked-to op in addition to its sequence number; * the following ops now have their op_other field displayed, like op_and etc already do: andassign argdefelem dor dorassign entergiven entertry enterwhen once orassign regcomp substcont * enteriter now has its op_redo etc fields displayed, like enterloop already does; Here is a sample before and after of perl -Dx -e'($x+$y) * $z' Before: { 1 TYPE = leave ===> NULL TARG = 1 FLAGS = (VOID,KIDS,PARENS,SLABBED) PRIVATE = (REFC) REFCNT = 1 { 2 TYPE = enter ===> 3 FLAGS = (UNKNOWN,SLABBED,MORESIB) } { 3 TYPE = nextstate ===> 4 FLAGS = (VOID,SLABBED,MORESIB) LINE = 1 PACKAGE = "main" SEQ = 4294967246 } { 5 TYPE = multiply ===> 1 TARG = 5 FLAGS = (VOID,KIDS,SLABBED) PRIVATE = (0x2) { 6 TYPE = add ===> 7 TARG = 3 FLAGS = (SCALAR,KIDS,PARENS,SLABBED,MORESIB) PRIVATE = (0x2) { 8 TYPE = null ===> (9) (was rv2sv) FLAGS = (SCALAR,KIDS,SLABBED,MORESIB) PRIVATE = (0x1) { 4 TYPE = gvsv ===> 9 FLAGS = (SCALAR,SLABBED) PADIX = 1 } } { 10 TYPE = null ===> (6) (was rv2sv) FLAGS = (SCALAR,KIDS,SLABBED) PRIVATE = (0x1) { 9 TYPE = gvsv ===> 6 FLAGS = (SCALAR,SLABBED) PADIX = 2 } } } { 11 TYPE = null ===> (5) (was rv2sv) FLAGS = (SCALAR,KIDS,SLABBED) PRIVATE = (0x1) { 7 TYPE = gvsv ===> 5 FLAGS = (SCALAR,SLABBED) PADIX = 4 } } } } After: 1 leave LISTOP(0xdecb38) ===> [0x0] TARG = 1 FLAGS = (VOID,KIDS,PARENS,SLABBED) PRIVATE = (REFC) REFCNT = 1 | 2 +--enter OP(0xdecb00) ===> 3 [nextstate 0xdecb80] | FLAGS = (UNKNOWN,SLABBED,MORESIB) | 3 +--nextstate COP(0xdecb80) ===> 4 [gvsv 0xdeb3b8] | FLAGS = (VOID,SLABBED,MORESIB) | LINE = 1 | PACKAGE = "main" | SEQ = 4294967246 | 5 +--multiply BINOP(0xdecbe0) ===> 1 [leave 0xdecb38] TARG = 5 FLAGS = (VOID,KIDS,SLABBED) PRIVATE = (0x2) | 6 +--add BINOP(0xdeb2b0) ===> 7 [gvsv 0xdeb270] | TARG = 3 | FLAGS = (SCALAR,KIDS,PARENS,SLABBED,MORESIB) | PRIVATE = (0x2) | | 8 | +--null (ex-rv2sv) UNOP(0xdeb378) ===> 9 [gvsv 0xdeb338] | | FLAGS = (SCALAR,KIDS,SLABBED,MORESIB) | | PRIVATE = (0x1) | | | 4 | | +--gvsv PADOP(0xdeb3b8) ===> 9 [gvsv 0xdeb338] | | FLAGS = (SCALAR,SLABBED) | | PADIX = 1 | | 10 | +--null (ex-rv2sv) UNOP(0xdeb2f8) ===> 6 [add 0xdeb2b0] | FLAGS = (SCALAR,KIDS,SLABBED) | PRIVATE = (0x1) | | 9 | +--gvsv PADOP(0xdeb338) ===> 6 [add 0xdeb2b0] | FLAGS = (SCALAR,SLABBED) | PADIX = 2 | 11 +--null (ex-rv2sv) UNOP(0xdeb220) ===> 5 [multiply 0xdecbe0] FLAGS = (SCALAR,KIDS,SLABBED) PRIVATE = (0x1) | 7 +--gvsv PADOP(0xdeb270) ===> 5 [multiply 0xdecbe0] FLAGS = (SCALAR,SLABBED) PADIX = 4 M dump.c M ext/Devel-Peek/t/Peek.t commit 1e85b6586ab5aca2ff20296114f8e70b45956a92 Author: David Mitchell <[email protected]> Date: Wed Jan 18 12:35:50 2017 +0000 add Perl_op_class(o) API function Given an op, this function determines what type of struct it has been allocated as. Returns one of the OPclass enums, such as OPclass_LISTOP. Originally this was a static function in B.xs, but it has wider applicability; indeed several XS modules on CPAN have cut and pasted it. It adds the OPclass enum to op.h. In B.xs there was a similar enum, but with names like OPc_LISTOP. I've renamed them to OPclass_LISTOP etc. so as not to clash with the cut+paste code already on CPAN. M dump.c M embed.fnc M embed.h M ext/B/B.pm M ext/B/B.xs M op.h M pod/perldiag.pod M proto.h ----------------------------------------------------------------------- Summary of changes: dump.c | 502 ++++++++++++++++++++++++++++++++++++++---------- embed.fnc | 1 + embed.h | 1 + ext/B/B.pm | 2 +- ext/B/B.xs | 158 +-------------- ext/Devel-Peek/t/Peek.t | 80 ++++---- op.h | 18 ++ pod/perldiag.pod | 7 + proto.h | 1 + 9 files changed, 467 insertions(+), 303 deletions(-) diff --git a/dump.c b/dump.c index 3915af16a9..fb07b12c1a 100644 --- a/dump.c +++ b/dump.c @@ -523,6 +523,86 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) PerlIO_vprintf(file, pat, *args); } + +/* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar + * for each indent level as appropriate. + * + * bar contains bits indicating which indent columns should have a + * vertical bar displayed. Bit 0 is the RH-most column. If there are more + * levels than bits in bar, then the first few indents are displayed + * without a bar. + * + * The start of a new op is signalled by passing a value for level which + * has been negated and offset by 1 (so that level 0 is passed as -1 and + * can thus be distinguished from -0); in this case, emit a suitably + * indented blank line, then on the next line, display the op's sequence + * number, and make the final indent an '+----'. + * + * e.g. + * + * | FOO # level = 1, bar = 0b1 + * | | # level =-2-1, bar = 0b11 + * 1234 | +---BAR + * | BAZ # level = 2, bar = 0b10 + */ + +static void +S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, + const char* pat, ...) +{ + va_list args; + I32 i; + bool newop = (level < 0); + + va_start(args, pat); + + /* start displaying a new op? */ + if (newop) { + UV seq = sequence_num(o); + + level = -level - 1; + + /* output preceding blank line */ + PerlIO_puts(file, " "); + for (i = level-1; i >= 0; i--) + PerlIO_puts(file, i == 0 || (bar & (1 << i)) ? "| " : " "); + PerlIO_puts(file, "\n"); + + /* output sequence number */ + if (seq) + PerlIO_printf(file, "%-4" UVuf " ", seq); + else + PerlIO_puts(file, "???? "); + + } + else + PerlIO_printf(file, " "); + + for (i = level-1; i >= 0; i--) + PerlIO_puts(file, + (i == 0 && newop) ? "+--" + : (bar & (1 << i)) ? "| " + : " "); + PerlIO_vprintf(file, pat, args); + va_end(args); +} + + +/* display a link field (e.g. op_next) in the format + * ====> sequence_number [opname 0x123456] + */ + +static void +S_opdump_link(pTHX_ const OP *o, PerlIO *file) +{ + PerlIO_puts(file, " ===> "); + if (o) + PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n", + sequence_num(o), OP_NAME(o), PTR2UV(o)); + else + PerlIO_puts(file, "[0x0]\n"); +} + /* =for apidoc dump_all @@ -650,51 +730,76 @@ Perl_dump_eval(pTHX) op_dump(PL_eval_root); } -void -Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) + +/* 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) { char ch; - - PERL_ARGS_ASSERT_DO_PMOP_DUMP; + UV kidbar; if (!pm) return; + + kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1; + if (pm->op_pmflags & PMf_ONCE) ch = '?'; else ch = '/'; + if (PM_GETRE(pm)) - Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c\n", + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); else - Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); + + if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { + SV * const tmpsv = pm_description(pm); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", + SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); + SvREFCNT_dec_NN(tmpsv); + } if (pm->op_type == OP_SPLIT) - Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%" UVxf "\n", - PTR2UV(pm->op_pmreplrootu.op_pmtargetgv)); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, + "TARGOFF/GV = 0x%" UVxf "\n", + PTR2UV(pm->op_pmreplrootu.op_pmtargetgv)); else { if (pm->op_pmreplrootu.op_pmreplroot) { - Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); - op_dump(pm->op_pmreplrootu.op_pmreplroot); + 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); } } if (pm->op_code_list) { if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { - Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n"); - do_op_dump(level, file, pm->op_code_list); + 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); } else - Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%" UVxf "\n", - PTR2UV(pm->op_code_list)); - } - if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { - SV * const tmpsv = pm_description(pm); - Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); - SvREFCNT_dec_NN(tmpsv); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, + "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list)); } } + +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); +} + + const struct flag_to_name pmflags_flags_names[] = { {PMf_CONST, ",CONST"}, {PMf_KEEP, ",KEEP"}, @@ -791,41 +896,61 @@ const struct flag_to_name op_flags_names[] = { }; -void -Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) +/* indexed by enum OPclass */ +const char * op_class_names[] = { + "NULL", + "OP", + "UNOP", + "BINOP", + "LOGOP", + "LISTOP", + "PMOP", + "SVOP", + "PADOP", + "PVOP", + "LOOP", + "COP", + "METHOP", + "UNOP_AUX", +}; + + +/* dump an op and any children. level indicates the initial indent. + * The bits of bar indicate which indents should receive a vertical bar. + * For example if level == 5 and bar == 0b01101, then the indent prefix + * emitted will be (not including the <>'s): + * + * < | | | > + * 55554444333322221111 + * + * 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. + */ + +static void +S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) { - UV seq; const OPCODE optype = o->op_type; PERL_ARGS_ASSERT_DO_OP_DUMP; - Perl_dump_indent(aTHX_ level, file, "{\n"); - level++; - seq = sequence_num(o); - if (seq) - PerlIO_printf(file, "%-4" UVuf, seq); - else - PerlIO_printf(file, "????"); - PerlIO_printf(file, - "%*sTYPE = %s ===> ", - (int)(PL_dumpindent*level-4), "", OP_NAME(o)); - if (o->op_next) - PerlIO_printf(file, - o->op_type == OP_NULL ? "(%" UVuf ")\n" : "%" UVuf "\n", - sequence_num(o->op_next)); - else - PerlIO_printf(file, "NULL\n"); - if (o->op_targ) { - if (optype == OP_NULL) { - Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); - } - else - Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); - } -#ifdef DUMPADDR - Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" UVxf " => 0x%" UVxf "\n", - (UV)o, (UV)o->op_next); -#endif + /* print op header line */ + + S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o)); + + if (optype == OP_NULL && o->op_targ) + PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]); + + PerlIO_printf(file, " %s(0x%" UVxf ")", + op_class_names[op_class(o)], PTR2UV(o)); + S_opdump_link(aTHX_ o->op_next, file); + + /* print op common fields */ + + if (o->op_targ && optype != OP_NULL) + S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", + (long)o->op_targ); if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { SV * const tmpsv = newSVpvs(""); @@ -849,7 +974,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB"); - Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", + S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); } @@ -933,10 +1058,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) } } if (tmpsv && SvCUR(tmpsv)) { - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); + S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n", + SvPVX_const(tmpsv) + 1); } else - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%" UVxf ")\n", - (UV)oppriv); + S_opdump_indent(aTHX_ o, level, bar, file, + "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv); } switch (optype) { @@ -944,7 +1070,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) case OP_GVSV: case OP_GV: #ifdef USE_ITHREADS - Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); + S_opdump_indent(aTHX_ o, level, bar, file, + "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */ if (cSVOPo->op_sv) { @@ -954,11 +1081,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP); gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); name = SvPV_const(tmpsv, len); - Perl_dump_indent(aTHX_ level, file, "GV = %s\n", + S_opdump_indent(aTHX_ o, level, bar, file, "GV = %s\n", generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv))); } else - Perl_dump_indent(aTHX_ level, file, "GV = NULL\n"); + S_opdump_indent(aTHX_ o, level, bar, file, "GV = NULL\n"); } #endif break; @@ -968,9 +1095,10 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) UNOP_AUX_item *items = cUNOP_AUXo->op_aux; UV i, count = items[-1].uv; - Perl_dump_indent(aTHX_ level, file, "ARGS = \n"); + S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); for (i=0; i < count; i++) - Perl_dump_indent(aTHX_ level+1, file, "%" UVuf " => 0x%" UVxf "\n", + S_opdump_indent(aTHX_ o, level+1, (bar << 1), file, + "%" UVuf " => 0x%" UVxf "\n", i, items[i].uv); break; } @@ -984,7 +1112,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #ifndef USE_ITHREADS /* with ITHREADS, consts are stored in the pad, and the right pad * may not be active here, so skip */ - Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o))); + S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", + SvPEEK(cMETHOPx_meth(o))); #endif break; case OP_NULL: @@ -994,64 +1123,69 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) case OP_NEXTSTATE: case OP_DBSTATE: if (CopLINE(cCOPo)) - Perl_dump_indent(aTHX_ level, file, "LINE = %" UVuf "\n", + S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", (UV)CopLINE(cCOPo)); - if (CopSTASHPV(cCOPo)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - HV *stash = CopSTASH(cCOPo); - const char * const hvname = HvNAME_get(stash); - - Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", - generic_pv_escape(tmpsv, hvname, - HvNAMELEN(stash), HvNAMEUTF8(stash))); - } - if (CopLABEL(cCOPo)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - STRLEN label_len; - U32 label_flags; - const char *label = CopLABEL_len_flags(cCOPo, - &label_len, &label_flags); - Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", - generic_pv_escape( tmpsv, label, label_len, - (label_flags & SVf_UTF8))); - } - Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n", + + if (CopSTASHPV(cCOPo)) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + HV *stash = CopSTASH(cCOPo); + const char * const hvname = HvNAME_get(stash); + + S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n", + generic_pv_escape(tmpsv, hvname, + HvNAMELEN(stash), HvNAMEUTF8(stash))); + } + + if (CopLABEL(cCOPo)) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + STRLEN label_len; + U32 label_flags; + const char *label = CopLABEL_len_flags(cCOPo, + &label_len, &label_flags); + S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n", + generic_pv_escape( tmpsv, label, label_len, + (label_flags & SVf_UTF8))); + } + + S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n", (unsigned int)cCOPo->cop_seq); break; + + case OP_ENTERITER: case OP_ENTERLOOP: - Perl_dump_indent(aTHX_ level, file, "REDO ===> "); - if (cLOOPo->op_redoop) - PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_redoop)); - else - PerlIO_printf(file, "DONE\n"); - Perl_dump_indent(aTHX_ level, file, "NEXT ===> "); - if (cLOOPo->op_nextop) - PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_nextop)); - else - PerlIO_printf(file, "DONE\n"); - Perl_dump_indent(aTHX_ level, file, "LAST ===> "); - if (cLOOPo->op_lastop) - PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_lastop)); - else - PerlIO_printf(file, "DONE\n"); + S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); + S_opdump_link(aTHX_ cLOOPo->op_redoop, file); + S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); + S_opdump_link(aTHX_ cLOOPo->op_nextop, file); + S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); + S_opdump_link(aTHX_ cLOOPo->op_lastop, file); break; + + case OP_REGCOMP: + case OP_SUBSTCONT: case OP_COND_EXPR: case OP_RANGE: case OP_MAPWHILE: case OP_GREPWHILE: case OP_OR: + case OP_DOR: case OP_AND: - Perl_dump_indent(aTHX_ level, file, "OTHER ===> "); - if (cLOGOPo->op_other) - PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOGOPo->op_other)); - else - PerlIO_printf(file, "DONE\n"); + case OP_ORASSIGN: + case OP_DORASSIGN: + case OP_ANDASSIGN: + case OP_ARGDEFELEM: + case OP_ENTERGIVEN: + case OP_ENTERWHEN: + case OP_ENTERTRY: + case OP_ONCE: + S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); + S_opdump_link(aTHX_ cLOGOPo->op_other, file); break; case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: - do_pmop_dump(level, file, cPMOPo); + S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); break; case OP_LEAVE: case OP_LEAVEEVAL: @@ -1060,19 +1194,31 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) case OP_LEAVEWRITE: case OP_SCOPE: if (o->op_private & OPpREFCOUNTED) - Perl_dump_indent(aTHX_ level, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ); + S_opdump_indent(aTHX_ o, level, bar, file, + "REFCNT = %" UVuf "\n", (UV)o->op_targ); break; default: break; } if (o->op_flags & OPf_KIDS) { OP *kid; + level++; + bar <<= 1; for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) - do_op_dump(level, file, kid); + S_do_op_dump_bar(aTHX_ level, + (bar | cBOOL(OpHAS_SIBLING(kid))), + file, kid); } - Perl_dump_indent(aTHX_ level-1, file, "}\n"); } + +void +Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) +{ + S_do_op_dump_bar(aTHX_ level, 0, file, o); +} + + /* =for apidoc op_dump @@ -2563,6 +2709,154 @@ Perl_debop(pTHX_ const OP *o) return 0; } + +/* +=for apidoc op_class + +Given an op, determine what type of struct it has been allocated as. +Returns one of the OPclass enums, such as OPclass_LISTOP. + +=cut +*/ + + +OPclass +Perl_op_class(pTHX_ const OP *o) +{ + bool custom = 0; + + if (!o) + return OPclass_NULL; + + if (o->op_type == 0) { + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + return OPclass_COP; + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + } + + if (o->op_type == OP_SASSIGN) + return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); + + if (o->op_type == OP_AELEMFAST) { +#ifdef USE_ITHREADS + return OPclass_PADOP; +#else + return OPclass_SVOP; +#endif + } + +#ifdef USE_ITHREADS + if (o->op_type == OP_GV || o->op_type == OP_GVSV || + o->op_type == OP_RCATLINE) + return OPclass_PADOP; +#endif + + if (o->op_type == OP_CUSTOM) + custom = 1; + + switch (OP_CLASS(o)) { + case OA_BASEOP: + return OPclass_BASEOP; + + case OA_UNOP: + return OPclass_UNOP; + + case OA_BINOP: + return OPclass_BINOP; + + case OA_LOGOP: + return OPclass_LOGOP; + + case OA_LISTOP: + return OPclass_LISTOP; + + case OA_PMOP: + return OPclass_PMOP; + + case OA_SVOP: + return OPclass_SVOP; + + case OA_PADOP: + return OPclass_PADOP; + + case OA_PVOP_OR_SVOP: + /* + * Character translations (tr///) are usually a PVOP, keeping a + * pointer to a table of shorts used to look up translations. + * Under utf8, however, a simple table isn't practical; instead, + * the OP is an SVOP (or, under threads, a PADOP), + * and the SV is a reference to a swash + * (i.e., an RV pointing to an HV). + */ + return (!custom && + (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) + ) +#if defined(USE_ITHREADS) + ? OPclass_PADOP : OPclass_PVOP; +#else + ? OPclass_SVOP : OPclass_PVOP; +#endif + + case OA_LOOP: + return OPclass_LOOP; + + case OA_COP: + return OPclass_COP; + + case OA_BASEOP_OR_UNOP: + /* + * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on + * whether parens were seen. perly.y uses OPf_SPECIAL to + * signal whether a BASEOP had empty parens or none. + * Some other UNOPs are created later, though, so the best + * test is OPf_KIDS, which is set in newUNOP. + */ + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + + case OA_FILESTATOP: + /* + * The file stat OPs are created via UNI(OP_foo) in toke.c but use + * the OPf_REF flag to distinguish between OP types instead of the + * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we + * return OPclass_UNOP so that walkoptree can find our children. If + * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set + * (no argument to the operator) it's an OP; with OPf_REF set it's + * an SVOP (and op_sv is the GV for the filehandle argument). + */ + return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : +#ifdef USE_ITHREADS + (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); +#else + (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); +#endif + case OA_LOOPEXOP: + /* + * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a + * label was omitted (in which case it's a BASEOP) or else a term was + * seen. In this last case, all except goto are definitely PVOP but + * goto is either a PVOP (with an ordinary constant label), an UNOP + * with OPf_STACKED (with a non-constant non-sub) or an UNOP for + * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to + * get set. + */ + if (o->op_flags & OPf_STACKED) + return OPclass_UNOP; + else if (o->op_flags & OPf_SPECIAL) + return OPclass_BASEOP; + else + return OPclass_PVOP; + case OA_METHOP: + return OPclass_METHOP; + case OA_UNOP_AUX: + return OPclass_UNOP_AUX; + } + Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n", + OP_NAME(o)); + return OPclass_BASEOP; +} + + + STATIC CV* S_deb_curcv(pTHX_ I32 ix) { diff --git a/embed.fnc b/embed.fnc index 656afe569f..0ee3fc8144 100644 --- a/embed.fnc +++ b/embed.fnc @@ -506,6 +506,7 @@ p |void |dump_all_perl |bool justperl Ap |void |dump_eval Ap |void |dump_form |NN const GV* gv Ap |void |gv_dump |NULLOK GV* gv +Apd |OPclass|op_class |NULLOK const OP *o Ap |void |op_dump |NN const OP *o Ap |void |pmop_dump |NULLOK PMOP* pm Ap |void |dump_packsubs |NN const HV* stash diff --git a/embed.h b/embed.h index ba7b2ca953..2233a35e80 100644 --- a/embed.h +++ b/embed.h @@ -434,6 +434,7 @@ #define nothreadhook() Perl_nothreadhook(aTHX) #define op_append_elem(a,b,c) Perl_op_append_elem(aTHX_ a,b,c) #define op_append_list(a,b,c) Perl_op_append_list(aTHX_ a,b,c) +#define op_class(a) Perl_op_class(aTHX_ a) #define op_contextualize(a,b) Perl_op_contextualize(aTHX_ a,b) #define op_convert_list(a,b,c) Perl_op_convert_list(aTHX_ a,b,c) #define op_dump(a) Perl_op_dump(aTHX_ a) diff --git a/ext/B/B.pm b/ext/B/B.pm index e0f9e21f0d..9e58700ebe 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.65'; + $B::VERSION = '1.66'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 2279f36850..5143305bab 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -39,22 +39,6 @@ static const char* const svclassnames[] = { "B::IO", }; -typedef enum { - OPc_NULL, /* 0 */ - OPc_BASEOP, /* 1 */ - OPc_UNOP, /* 2 */ - OPc_BINOP, /* 3 */ - OPc_LOGOP, /* 4 */ - OPc_LISTOP, /* 5 */ - OPc_PMOP, /* 6 */ - OPc_SVOP, /* 7 */ - OPc_PADOP, /* 8 */ - OPc_PVOP, /* 9 */ - OPc_LOOP, /* 10 */ - OPc_COP, /* 11 */ - OPc_METHOP, /* 12 */ - OPc_UNOP_AUX /* 13 */ -} opclass; static const char* const opclassnames[] = { "B::NULL", @@ -113,146 +97,12 @@ static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { cxt->x_specialsv_list[6] = (SV *) pWARN_STD; } -static opclass -cc_opclass(pTHX_ const OP *o) -{ - bool custom = 0; - - if (!o) - return OPc_NULL; - - if (o->op_type == 0) { - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - return OPc_COP; - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - } - - if (o->op_type == OP_SASSIGN) - return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); - - if (o->op_type == OP_AELEMFAST) { -#ifdef USE_ITHREADS - return OPc_PADOP; -#else - return OPc_SVOP; -#endif - } - -#ifdef USE_ITHREADS - if (o->op_type == OP_GV || o->op_type == OP_GVSV || - o->op_type == OP_RCATLINE) - return OPc_PADOP; -#endif - - if (o->op_type == OP_CUSTOM) - custom = 1; - - switch (OP_CLASS(o)) { - case OA_BASEOP: - return OPc_BASEOP; - - case OA_UNOP: - return OPc_UNOP; - - case OA_BINOP: - return OPc_BINOP; - - case OA_LOGOP: - return OPc_LOGOP; - - case OA_LISTOP: - return OPc_LISTOP; - - case OA_PMOP: - return OPc_PMOP; - - case OA_SVOP: - return OPc_SVOP; - - case OA_PADOP: - return OPc_PADOP; - - case OA_PVOP_OR_SVOP: - /* - * Character translations (tr///) are usually a PVOP, keeping a - * pointer to a table of shorts used to look up translations. - * Under utf8, however, a simple table isn't practical; instead, - * the OP is an SVOP (or, under threads, a PADOP), - * and the SV is a reference to a swash - * (i.e., an RV pointing to an HV). - */ - return (!custom && - (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) - ) -#if defined(USE_ITHREADS) - ? OPc_PADOP : OPc_PVOP; -#else - ? OPc_SVOP : OPc_PVOP; -#endif - - case OA_LOOP: - return OPc_LOOP; - - case OA_COP: - return OPc_COP; - - case OA_BASEOP_OR_UNOP: - /* - * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on - * whether parens were seen. perly.y uses OPf_SPECIAL to - * signal whether a BASEOP had empty parens or none. - * Some other UNOPs are created later, though, so the best - * test is OPf_KIDS, which is set in newUNOP. - */ - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - - case OA_FILESTATOP: - /* - * The file stat OPs are created via UNI(OP_foo) in toke.c but use - * the OPf_REF flag to distinguish between OP types instead of the - * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we - * return OPc_UNOP so that walkoptree can find our children. If - * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set - * (no argument to the operator) it's an OP; with OPf_REF set it's - * an SVOP (and op_sv is the GV for the filehandle argument). - */ - return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : -#ifdef USE_ITHREADS - (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); -#else - (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); -#endif - case OA_LOOPEXOP: - /* - * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a - * label was omitted (in which case it's a BASEOP) or else a term was - * seen. In this last case, all except goto are definitely PVOP but - * goto is either a PVOP (with an ordinary constant label), an UNOP - * with OPf_STACKED (with a non-constant non-sub) or an UNOP for - * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to - * get set. - */ - if (o->op_flags & OPf_STACKED) - return OPc_UNOP; - else if (o->op_flags & OPf_SPECIAL) - return OPc_BASEOP; - else - return OPc_PVOP; - case OA_METHOP: - return OPc_METHOP; - case OA_UNOP_AUX: - return OPc_UNOP_AUX; - } - warn("can't determine class of operator %s, assuming BASEOP\n", - OP_NAME(o)); - return OPc_BASEOP; -} static SV * make_op_object(pTHX_ const OP *o) { SV *opsv = sv_newmortal(); - sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o)); + sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o)); return opsv; } @@ -509,7 +359,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) dSP; OP *kid; SV *object; - const char *const classname = opclassnames[cc_opclass(aTHX_ o)]; + const char *const classname = opclassnames[op_class(o)]; dMY_CXT; /* Check that no-one has changed our reference, or is holding a reference @@ -542,7 +392,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) ref = walkoptree(aTHX_ kid, method, ref); } } - if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_SPLIT + if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT && (kid = PMOP_pmreplroot(cPMOPo))) { ref = walkoptree(aTHX_ kid, method, ref); @@ -1083,7 +933,7 @@ next(o) : &PL_sv_undef); break; case 26: /* B::OP::size */ - ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); + ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)]))); break; case 27: /* B::OP::name */ case 28: /* B::OP::desc */ diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 4775c1c64f..fa25b48f51 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1455,58 +1455,50 @@ for my $test ( local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS'; my $e = <<'EODUMP'; dumpindent is 4 at -e line 1. -{ -1 TYPE = leave ===> NULL - TARG = 1 - FLAGS = (VOID,KIDS,PARENS,SLABBED) - PRIVATE = (REFC) - REFCNT = 1 - { -2 TYPE = enter ===> 3 - FLAGS = (UNKNOWN,SLABBED,MORESIB) - } - { -3 TYPE = nextstate ===> 4 - FLAGS = (VOID,SLABBED,MORESIB) - LINE = 1 - PACKAGE = "t" - } - { -5 TYPE = entersub ===> 1 - TARG = 1 - FLAGS = (VOID,KIDS,STACKED,SLABBED) - PRIVATE = (TARG) - { -6 TYPE = null ===> (5) - (was list) - FLAGS = (UNKNOWN,KIDS,SLABBED) - { -4 TYPE = pushmark ===> 7 - FLAGS = (SCALAR,SLABBED,MORESIB) - } - { -8 TYPE = null ===> (6) - (was rv2cv) - FLAGS = (SCALAR,KIDS,SLABBED) - PRIVATE = (0x1) - { -7 TYPE = gv ===> 5 - FLAGS = (SCALAR,SLABBED) - GV_OR_PADIX - } - } - } - } -} + +1 leave LISTOP(0xNNN) ===> [0x0] + TARG = 1 + FLAGS = (VOID,KIDS,PARENS,SLABBED) + PRIVATE = (REFC) + REFCNT = 1 + | +2 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN] + | FLAGS = (UNKNOWN,SLABBED,MORESIB) + | +3 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN] + | FLAGS = (VOID,SLABBED,MORESIB) + | LINE = 1 + | PACKAGE = "t" + | | +5 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN] + TARG = 1 + FLAGS = (VOID,KIDS,STACKED,SLABBED) + PRIVATE = (TARG) + | +6 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN] + FLAGS = (UNKNOWN,KIDS,SLABBED) + | +4 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN] + | FLAGS = (SCALAR,SLABBED,MORESIB) + | +8 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN] + FLAGS = (SCALAR,KIDS,SLABBED) + PRIVATE = (0x1) + | +7 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN] + FLAGS = (SCALAR,SLABBED) + GV_OR_PADIX EODUMP $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; - $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004; + $e =~ s/SVOP/PADOP/g if $threads; my $out = t::runperl switches => ['-Ilib'], prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();', stderr=>1; $out =~ s/ *SEQ = .*\n//; + $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g; + $out =~ s/0x[0-9a-f]{2,}\) ===/0xNNN) ===/g; is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning"; } done_testing(); diff --git a/op.h b/op.h index 90f63e3227..4e3012fc8a 100644 --- a/op.h +++ b/op.h @@ -475,6 +475,24 @@ struct loop { #define kLOOP cLOOPx(kid) +typedef enum { + OPclass_NULL, /* 0 */ + OPclass_BASEOP, /* 1 */ + OPclass_UNOP, /* 2 */ + OPclass_BINOP, /* 3 */ + OPclass_LOGOP, /* 4 */ + OPclass_LISTOP, /* 5 */ + OPclass_PMOP, /* 6 */ + OPclass_SVOP, /* 7 */ + OPclass_PADOP, /* 8 */ + OPclass_PVOP, /* 9 */ + OPclass_LOOP, /* 10 */ + OPclass_COP, /* 11 */ + OPclass_METHOP, /* 12 */ + OPclass_UNOP_AUX /* 13 */ +} OPclass; + + #ifdef USE_ITHREADS # define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix)) # ifndef PERL_CORE diff --git a/pod/perldiag.pod b/pod/perldiag.pod index afdcb7301e..9038b2bee2 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -839,6 +839,13 @@ C<foreach> loop nor a C<given> block. (Note that this error is issued on exit from the C<default> block, so you won't get the error if you use an explicit C<continue>.) +=item Can't determine class of operator %s, assuming BASEOP + +(S) This warning indicates something wrong in the internals of perl. +Perl was trying to find the class (e.g. LISTOP) of a particular OP, +and was unable to do so. This is likely to be due to a bug in the perl +internals, or due to a bug in XS code which manipulates perl optrees. + =item Can't do inplace edit: %s is not a regular file (S inplace) You tried to use the B<-i> switch on a special file, such as diff --git a/proto.h b/proto.h index 2fd8a51580..e3c04dc94c 100644 --- a/proto.h +++ b/proto.h @@ -2343,6 +2343,7 @@ PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o) PERL_CALLCONV OP* Perl_op_append_elem(pTHX_ I32 optype, OP* first, OP* last); PERL_CALLCONV OP* Perl_op_append_list(pTHX_ I32 optype, OP* first, OP* last); +PERL_CALLCONV OPclass Perl_op_class(pTHX_ const OP *o); PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o); #define PERL_ARGS_ASSERT_OP_CLEAR \ assert(o) -- Perl5 Master Repository
