Add xop_dump field and integrate into op_dump()

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)))
                                )
@@ -693,9 +692,9 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
 
     }
     else
-        PerlIO_printf(file, "     ");
+        PerlIO_puts(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))  ? "|   "
@@ -704,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<STDERR> according to the pattern and subsequent
+arguments, in the style of C<printf()> et.al. This should only be called by
+a function invoked by the C<xop_dump> field of a custom operator, where the
+C<ctx> opaque structure pointer should be passed in from the argument given
+to the C<xop_dump> 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]
@@ -1494,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;

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

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)

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;

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,20 +944,23 @@ 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 {
     XOPe_xop_ptr = 0, /* just get the XOP *, don't look inside it */
     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 { \

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

pod/perlguts.pod

@@ -3848,6 +3848,17 @@ will be called from C<Perl_rpeep> when ops of this type are encountered
 by the peephole optimizer.  I<o> is the OP that needs optimizing;
 I<oldop> is the previous OP optimized, whose C<op_next> points to I<o>.
 
+=item xop_dump
+
+This member is a pointer to a function of type
+C<void (pTHX_ OP *, struct OpDumpContext *)>. If set, this function is called
+by C<op_dump()> when dumping a custom operator of this type, after the op's
+basic fields have been printed. This function may make use of
+C<opdump_printf()> 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<opdump_printf()>.
+
 =for apidoc_section $optree_manipulation
 =for apidoc Ayh||Perl_cpeep_t