From 36132debc5df547df8a562041fb1a838dbc4003b Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Sat, 7 Sep 2024 21:45:36 +0100 Subject: [PATCH 1/3] dump.c: Use C99-style variable declaration in for() loop in S_opdump_indent() --- dump.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/dump.c b/dump.c index 9d816c097569..0f8f3a46898e 100644 --- a/dump.c +++ b/dump.c @@ -665,7 +665,6 @@ 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); @@ -678,7 +677,7 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, /* output preceding blank line */ PerlIO_puts(file, " "); - for (i = level-1; i >= 0; i--) + for (I32 i = level-1; i >= 0; i--) PerlIO_puts(file, ( i == 0 || (i < UVSIZE*8 && (bar & ((UV)1 << i))) ) @@ -695,7 +694,7 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, else PerlIO_printf(file, " "); - for (i = level-1; i >= 0; i--) + for (I32 i = level-1; i >= 0; i--) PerlIO_puts(file, (i == 0 && newop) ? "+--" : (bar & (1 << i)) ? "| " From 25135be5779399ba5c982f08cbfb662c88e96640 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Mon, 9 Sep 2024 01:27:21 +0100 Subject: [PATCH 2/3] dump.c: Use PerlIO_puts() instead of PerlIO_printf() for format string with no conversions --- dump.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dump.c b/dump.c index 0f8f3a46898e..d54a7ea52660 100644 --- a/dump.c +++ b/dump.c @@ -692,7 +692,7 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, } else - PerlIO_printf(file, " "); + PerlIO_puts(file, " "); for (I32 i = level-1; i >= 0; i--) PerlIO_puts(file, From 883b227fa6e386b8ecd725af70da4d6744bb091b Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Fri, 6 Sep 2024 23:35:47 +0100 Subject: [PATCH 3/3] Add xop_dump field and integrate into op_dump() When working with nontrivially-shaped custom ops, such as ones based on UNOP_AUX with interesting op_aux arrays, it is often useful to be able to peek into the contents of these op structures with `op_dump()`. Perl's core dumper cannot know the contents of these aux arrays, but by defining a helper function in the module that provides the custom op, help can be achieved. A helper function, `opdump_printf` is also provided that acts as a printf()-alike function for outputting lines of content. The various internal arguments to it (level, bar, file) are bundled up into an opaque structure, so as to achieve a modicum of abstraction away from the specific internals on how dump.c happens to work. --- dump.c | 86 ++++++++++++++++++++++++++++++++++++++++++++++++ embed.fnc | 3 ++ embed.h | 1 + op.c | 8 ++++- op.h | 7 +++- perl.h | 2 ++ pod/perlguts.pod | 11 +++++++ proto.h | 6 ++++ 8 files changed, 122 insertions(+), 2 deletions(-) diff --git a/dump.c b/dump.c index d54a7ea52660..cdbbb0e2819d 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_puts(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");