diff --git a/dump.c b/dump.c index 0f8f3a46898e..c130f87e3f23 100644 --- a/dump.c +++ b/dump.c @@ -703,6 +703,76 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, va_end(args); } +struct Perl_OpDumpContext { + I32 level; + UV bar; + PerlIO *file; + bool indent_needed; +}; + +static void +S_opdump_print(pTHX_ struct Perl_OpDumpContext *ctx, SV *msg) +{ + STRLEN msglen; + const char *msgpv = SvPV(msg, msglen); + + while(msglen) { + if(ctx->indent_needed) { + PerlIO_printf(ctx->file, " "); + + for (I32 i = ctx->level-1; i >= 0; i--) + PerlIO_puts(ctx->file, + (ctx->bar & (1 << i)) ? "| " : " "); + } + + const char *eol_at = strchr(msgpv, '\n'); + if(eol_at) { + STRLEN partlen = eol_at - msgpv + 1; + PerlIO_write(ctx->file, msgpv, partlen); + + ctx->indent_needed = true; + msgpv += partlen; + msglen -= partlen; + } + else { + PerlIO_write(ctx->file, msgpv, msglen); + + ctx->indent_needed = false; + msglen = 0; + } + } +} + +/* +=for apidoc_section $debugging +=for apidoc opdump_printf + +Prints formatted output to C according to the pattern and subsequent +arguments, in the style of C et.al. This should only be called by +a function invoked by the C field of a custom operator, where the +C opaque structure pointer should be passed in from the argument given +to the C callback. + +This function handles indentation after linefeeds, so message strings passed +in should not account for it themselves. Multiple lines may be passed to this +function at once, or a single line may be split across multiple calls. + +=cut + */ + +void +Perl_opdump_printf(pTHX_ struct Perl_OpDumpContext *ctx, const char *pat, ...) +{ + va_list args; + + PERL_ARGS_ASSERT_OPDUMP_PRINTF; + + va_start(args, pat); + SV *msg_sv = sv_2mortal(vnewSVpvf(pat, &args)); + S_opdump_print(aTHX_ ctx, msg_sv); + va_end(args); +} + /* display a link field (e.g. op_next) in the format * ====> sequence_number [opname 0x123456] @@ -1493,6 +1563,22 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) break; } + case OP_CUSTOM: + { + void (*custom_dumper)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx) = + XopENTRYCUSTOM(o, xop_dump); + + if(custom_dumper) { + struct Perl_OpDumpContext ctx = { + .level = level, + .bar = bar, + .file = file, + .indent_needed = true, + }; + (*custom_dumper)(aTHX_ o, &ctx); + } + break; + } default: break; diff --git a/embed.fnc b/embed.fnc index 2fbed84a047e..3050312a5f65 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2376,6 +2376,9 @@ ARdp |OP * |op_convert_list|I32 optype \ |I32 flags \ |NULLOK OP *o Adp |void |op_dump |NN const OP *o +Adfp |void |opdump_printf |NN struct Perl_OpDumpContext *ctx \ + |NN const char *pat \ + |... ; Used in op.c and class.c Adp |OP * |op_force_list |NULLOK OP *o Adp |void |op_free |NULLOK OP *arg diff --git a/embed.h b/embed.h index e7b328757f26..4877ad370753 100644 --- a/embed.h +++ b/embed.h @@ -470,6 +470,7 @@ # define op_scope(a) Perl_op_scope(aTHX_ a) # define op_sibling_splice Perl_op_sibling_splice # define op_wrap_finally(a,b) Perl_op_wrap_finally(aTHX_ a,b) +# define opdump_printf(a,...) Perl_opdump_printf(aTHX_ a,__VA_ARGS__) # define packlist(a,b,c,d,e) Perl_packlist(aTHX_ a,b,c,d,e) # define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b) # define pad_add_name_pv(a,b,c,d) Perl_pad_add_name_pv(aTHX_ a,b,c,d) diff --git a/op.c b/op.c index 3126002e00b1..d7fb28f035e6 100644 --- a/op.c +++ b/op.c @@ -15402,7 +15402,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) HE *he = NULL; XOP *xop; - static const XOP xop_null = { 0, 0, 0, 0, 0 }; + static const XOP xop_null = { 0, 0, 0, 0, 0, 0 }; PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD; assert(o->op_type == OP_CUSTOM); @@ -15476,6 +15476,9 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) case XOPe_xop_peep: any.xop_peep = xop->xop_peep; break; + case XOPe_xop_dump: + any.xop_dump = xop->xop_dump; + break; default: field_panic: Perl_croak(aTHX_ @@ -15497,6 +15500,9 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) case XOPe_xop_peep: any.xop_peep = XOPd_xop_peep; break; + case XOPe_xop_dump: + any.xop_dump = XOPd_xop_dump; + break; default: goto field_panic; break; diff --git a/op.h b/op.h index b894e606ea5a..d64ef04db782 100644 --- a/op.h +++ b/op.h @@ -923,6 +923,7 @@ struct custom_op { const char *xop_desc; U32 xop_class; void (*xop_peep)(pTHX_ OP *o, OP *oldop); + void (*xop_dump)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx); }; /* return value of Perl_custom_op_get_field, similar to void * then casting but @@ -933,6 +934,7 @@ typedef union { const char *xop_desc; U32 xop_class; void (*xop_peep)(pTHX_ OP *o, OP *oldop); + void (*xop_dump)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx); XOP *xop_ptr; } XOPRETANY; @@ -942,6 +944,7 @@ typedef union { #define XOPf_xop_desc 0x02 #define XOPf_xop_class 0x04 #define XOPf_xop_peep 0x08 +#define XOPf_xop_dump 0x10 /* used by Perl_custom_op_get_field for option checking */ typedef enum { @@ -949,13 +952,15 @@ typedef enum { XOPe_xop_name = XOPf_xop_name, XOPe_xop_desc = XOPf_xop_desc, XOPe_xop_class = XOPf_xop_class, - XOPe_xop_peep = XOPf_xop_peep + XOPe_xop_peep = XOPf_xop_peep, + XOPe_xop_dump = XOPf_xop_dump, } xop_flags_enum; #define XOPd_xop_name PL_op_name[OP_CUSTOM] #define XOPd_xop_desc PL_op_desc[OP_CUSTOM] #define XOPd_xop_class OA_BASEOP #define XOPd_xop_peep ((Perl_cpeep_t)0) +#define XOPd_xop_dump NULL #define XopENTRY_set(xop, which, to) \ STMT_START { \ diff --git a/perl.h b/perl.h index 54f38f20dc6c..0c150622fed6 100644 --- a/perl.h +++ b/perl.h @@ -4505,6 +4505,8 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #include "perly.h" +/* opaque struct type used to communicate between xop_dump and opdump_printf */ +struct Perl_OpDumpContext; /* macros to define bit-fields in structs. */ #ifndef PERL_BITFIELD8 diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 0a94e811c70d..8713b2d23a9a 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -3848,6 +3848,17 @@ will be called from C when ops of this type are encountered by the peephole optimizer. I is the OP that needs optimizing; I is the previous OP optimized, whose C points to I. +=item xop_dump + +This member is a pointer to a function of type +C. If set, this function is called +by C when dumping a custom operator of this type, after the op's +basic fields have been printed. This function may make use of +C to emit additional output that may be useful for debugging. + +The opaque structure pointer passed in as its final argument should be passed +directly into C. + =for apidoc_section $optree_manipulation =for apidoc Ayh||Perl_cpeep_t diff --git a/proto.h b/proto.h index 655281381211..e23b66e5f0ef 100644 --- a/proto.h +++ b/proto.h @@ -3271,6 +3271,12 @@ Perl_op_wrap_finally(pTHX_ OP *block, OP *finally) #define PERL_ARGS_ASSERT_OP_WRAP_FINALLY \ assert(block); assert(finally) +PERL_CALLCONV void +Perl_opdump_printf(pTHX_ struct Perl_OpDumpContext *ctx, const char *pat, ...) + __attribute__format__(__printf__,pTHX_2,pTHX_3); +#define PERL_ARGS_ASSERT_OPDUMP_PRINTF \ + assert(ctx); assert(pat) + PERL_CALLCONV void Perl_package(pTHX_ OP *o) __attribute__visibility__("hidden");