diff options
author | David Mitchell <davem@iabyn.com> | 2017-01-17 17:40:32 +0000 |
---|---|---|
committer | David Mitchell <davem@iabyn.com> | 2017-01-21 10:04:44 +0000 |
commit | cd6e48741f9105d4b8da0e141bfdf362f1dd0961 (patch) | |
tree | 5cd9b61e6eb5230eb13d9221b088417c534106a4 /dump.c | |
parent | 1e85b6586ab5aca2ff20296114f8e70b45956a92 (diff) | |
download | perl-cd6e48741f9105d4b8da0e141bfdf362f1dd0961.tar.gz |
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
Diffstat (limited to 'dump.c')
-rw-r--r-- | dump.c | 317 |
1 files changed, 230 insertions, 87 deletions
@@ -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,14 +1123,14 @@ 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", + S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n", generic_pv_escape(tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash))); } @@ -1011,47 +1140,49 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) U32 label_flags; const char *label = CopLABEL_len_flags(cCOPo, &label_len, &label_flags); - Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", + S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n", generic_pv_escape( tmpsv, label, label_len, (label_flags & SVf_UTF8))); } - Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n", + 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 +1191,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 |