Improve custom OP support.

Change the custom op registrations from two separate hashes to one hash
holding structure pointers, and add API functions to register ops and
look them up. This will make it easier to add new properties of custom
ops in the future. Copy entries across from the old hashes where
necessary, to preserve compatibility.

Add two new properties, in addition to the already-existing 'name' and
'description': 'class' and 'peep'. 'class' is one of the OA_*OP
constants, and allows B and other introspection mechanisms to work with
custom ops that aren't BASEOPs. 'peep' is a pointer to a function that
will be called for ops of this type from Perl_rpeep.

Adjust B.xs to take account of the new properties, and also to give
custom ops their registered name rather than simply 'custom'.

diff --git a/embed.fnc b/embed.fnc
index 7188db9..ad7e7a4 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1489,8 +1489,11 @@ Ap       |void   |sys_intern_clear
 Ap     |void   |sys_intern_init
 #endif
 
+AopP   |const XOP *    |custom_op_xop  |NN const OP *o
 ApR    |const char *   |custom_op_name |NN const OP *o
 ApR    |const char *   |custom_op_desc |NN const OP *o
+Aop    |void   |custom_op_register     |NN Perl_ppaddr_t ppaddr \
+                       |NN const XOP *xop
 
 Adp    |void   |sv_nosharing   |NULLOK SV *sv
 Adpbm  |void   |sv_nolocking   |NULLOK SV *sv

diff --git a/embedvar.h b/embedvar.h
index 290d402..65b38f0 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -106,6 +106,7 @@
 #define PL_curstname           (vTHX->Icurstname)
 #define PL_custom_op_descs     (vTHX->Icustom_op_descs)
 #define PL_custom_op_names     (vTHX->Icustom_op_names)
+#define PL_custom_ops          (vTHX->Icustom_ops)
 #define PL_cv_has_eval         (vTHX->Icv_has_eval)
 #define PL_dbargs              (vTHX->Idbargs)
 #define PL_debstash            (vTHX->Idebstash)
@@ -436,6 +437,7 @@
 #define PL_Icurstname          PL_curstname
 #define PL_Icustom_op_descs    PL_custom_op_descs
 #define PL_Icustom_op_names    PL_custom_op_names
+#define PL_Icustom_ops         PL_custom_ops
 #define PL_Icv_has_eval                PL_cv_has_eval
 #define PL_Idbargs             PL_dbargs
 #define PL_Idebstash           PL_debstash

diff --git a/ext/B/B.xs b/ext/B/B.xs
index ad9c0a6..2a950d3 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -113,6 +113,8 @@ START_MY_CXT
 static opclass
 cc_opclass(pTHX_ const OP *o)
 {
+    bool custom = 0;
+
     if (!o)
        return OPc_NULL;
 
@@ -139,7 +141,10 @@ cc_opclass(pTHX_ const OP *o)
        return OPc_PADOP;
 #endif
 
-    switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+    if (o->op_type == OP_CUSTOM)
+        custom = 1;
+
+    switch (OP_CLASS(o)) {
     case OA_BASEOP:
        return OPc_BASEOP;
 
@@ -173,7 +178,9 @@ cc_opclass(pTHX_ const OP *o)
          * and the SV is a reference to a swash
          * (i.e., an RV pointing to an HV).
          */
-       return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+       return (!custom &&
+                  (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+              )
 #if  defined(USE_ITHREADS) \
   && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
                ? OPc_PADOP : OPc_PVOP;
@@ -231,7 +238,7 @@ cc_opclass(pTHX_ const OP *o)
            return OPc_PVOP;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
-        PL_op_name[o->op_type]);
+        OP_NAME(o));
     return OPc_BASEOP;
 }
 
@@ -962,7 +969,7 @@ name(o)
     ALIAS:
        desc = 1
     CODE:
-       RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
+       RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
     OUTPUT:
        RETVAL
 

diff --git a/global.sym b/global.sym
index fbfa98b..23e7bb9 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -70,6 +70,8 @@ Perl_croak_sv
 Perl_croak_xs_usage
 Perl_custom_op_desc
 Perl_custom_op_name
+Perl_custom_op_register
+Perl_custom_op_xop
 Perl_cv_const_sv
 Perl_cv_get_call_checker
 Perl_cv_set_call_checker

diff --git a/intrpvar.h b/intrpvar.h
index 1ba3ab8..d10feec 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -770,6 +770,8 @@ PERLVAR(Iblockhooks, AV *)
 /* Everything that folds to a character, for case insensitivity regex matching */
 PERLVARI(Iutf8_foldclosures,   HV *, NULL)
 
+PERLVAR(Icustom_ops, HV *)      /* custom op registrations */
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 

diff --git a/mathoms.c b/mathoms.c
index 78516b3..ccefceb 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -1554,6 +1554,20 @@ Perl_sv_2bool(pTHX_ register SV *const sv)
     return sv_2bool_flags(sv, SV_GMAGIC);
 }
 
+
+const char*
+Perl_custom_op_name(pTHX_ const OP* o)
+{
+    PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name);
+}
+
+const char*
+Perl_custom_op_desc(pTHX_ const OP* o)
+{
+    PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
+    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc);
+}
 #endif /* NO_MATHOMS */
 
 /*

diff --git a/op.c b/op.c
index 7a6dbcd..199a9d0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10020,6 +10020,15 @@ Perl_rpeep(pTHX_ register OP *o)
                assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
            }
            break;
+
+       case OP_CUSTOM: {
+           Perl_cpeep_t cpeep = 
+               XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+           if (cpeep)
+               cpeep(aTHX_ o, oldop);
+           break;
+       }
+           
        }
        oldop = o;
     }
@@ -10032,48 +10041,73 @@ Perl_peep(pTHX_ register OP *o)
     CALL_RPEEP(o);
 }
 
-const char*
-Perl_custom_op_name(pTHX_ const OP* o)
+const XOP *
+Perl_custom_op_xop(pTHX_ const OP *o)
 {
-    dVAR;
-    const IV index = PTR2IV(o->op_ppaddr);
-    SV* keysv;
-    HE* he;
+    SV *keysv;
+    HE *he = NULL;
+    XOP *xop;
+
+    static const XOP xop_null = { 0, 0, 0, 0, 0 };
 
-    PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+    PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+    assert(o->op_type == OP_CUSTOM);
 
-    if (!PL_custom_op_names) /* This probably shouldn't happen */
-        return (char *)PL_op_name[OP_CUSTOM];
+    /* This is wrong. It assumes a function pointer can be cast to IV,
+     * which isn't guaranteed, but this is what the old custom OP code
+     * did. In principle it should be safer to Copy the bytes of the
+     * pointer into a PV: since the new interface is hidden behind
+     * functions, this can be changed later if necessary.  */
+    /* Change custom_op_xop if this ever happens */
+    keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
 
-    keysv = sv_2mortal(newSViv(index));
+    if (PL_custom_ops)
+       he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
+
+    /* assume noone will have just registered a desc */
+    if (!he && PL_custom_op_names &&
+       (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
+    ) {
+       const char *pv;
+       STRLEN l;
+
+       /* XXX does all this need to be shared mem? */
+       Newx(xop, 1, XOP);
+       pv = SvPV(HeVAL(he), l);
+       XopENTRY_set(xop, xop_name, savepvn(pv, l));
+       if (PL_custom_op_descs &&
+           (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
+       ) {
+           pv = SvPV(HeVAL(he), l);
+           XopENTRY_set(xop, xop_desc, savepvn(pv, l));
+       }
+       Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
+       return xop;
+    }
 
-    he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
-    if (!he)
-        return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+    if (!he) return &xop_null;
 
-    return SvPV_nolen(HeVAL(he));
+    xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+    return xop;
 }
 
-const char*
-Perl_custom_op_desc(pTHX_ const OP* o)
-{
-    dVAR;
-    const IV index = PTR2IV(o->op_ppaddr);
-    SV* keysv;
-    HE* he;
 
-    PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
 
-    if (!PL_custom_op_descs)
-        return (char *)PL_op_desc[OP_CUSTOM];
+void
+Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
+{
+    SV *keysv;
+
+    PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
 
-    keysv = sv_2mortal(newSViv(index));
+    /* see the comment in custom_op_xop */
+    keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
 
-    he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
-    if (!he)
-        return (char *)PL_op_desc[OP_CUSTOM];
+    if (!PL_custom_ops)
+       PL_custom_ops = newHV();
 
-    return SvPV_nolen(HeVAL(he));
+    if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
+       Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
 }
 
 #include "XSUB.h"

diff --git a/op.h b/op.h
index a10069b..a4921e1 100644 (file)
--- a/op.h
+++ b/op.h
@@ -760,6 +760,52 @@ preprocessing token; the type of I<arg> depends on I<which>.
 #define RV2CVOPCV_MARK_EARLY     0x00000001
 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002
 
+struct custom_op {
+    U32                    xop_flags;    
+    const char    *xop_name;
+    const char    *xop_desc;
+    U32                    xop_class;
+    void         (*xop_peep)(pTHX_ OP *o, OP *oldop);
+};
+
+#define XopFLAGS(xop) ((xop)->xop_flags)
+
+#define XOPf_xop_name  0x01
+#define XOPf_xop_desc  0x02
+#define XOPf_xop_class 0x04
+#define XOPf_xop_peep  0x08
+
+#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 XopENTRY_set(xop, which, to) \
+    STMT_START { \
+       (xop)->which = (to); \
+       (xop)->xop_flags |= XOPf_ ## which; \
+    } STMT_END
+
+#define XopENTRY(xop, which) \
+    ((XopFLAGS(xop) & XOPf_ ## which) ? (xop)->which : XOPd_ ## which)
+
+#define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which)
+#define XopENABLE(xop, which) \
+    STMT_START { \
+       (xop)->xop_flags |= XOPf_ ## which; \
+       assert(XopENTRY(xop, which)); \
+    } STMT_END
+
+#define OP_NAME(o) ((o)->op_type == OP_CUSTOM \
+                   ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name) \
+                   : PL_op_name[(o)->op_type])
+#define OP_DESC(o) ((o)->op_type == OP_CUSTOM \
+                   ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc) \
+                   : PL_op_desc[(o)->op_type])
+#define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \
+                    ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_class) \
+                    : (PL_opargs[(o)->op_type] & OA_CLASS_MASK))
+
 #ifdef PERL_MAD
 #  define MAD_NULL 1
 #  define MAD_PV 2

diff --git a/opcode.h b/opcode.h
index bb07bef..122c67f 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -24,11 +24,6 @@ PERL_PPDEF(Perl_unimplemented_op)
 
 START_EXTERN_C
 
-#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \
-                    PL_op_name[(o)->op_type])
-#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \
-                    PL_op_desc[(o)->op_type])
-
 #ifndef DOINIT
 EXTCONST char* const PL_op_name[];
 #else

diff --git a/perl.h b/perl.h
index 22bb6d8..522df72 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2410,6 +2410,7 @@ typedef struct pvop PVOP;
 typedef struct loop LOOP;
 
 typedef struct block_hooks BHK;
+typedef struct custom_op XOP;
 
 typedef struct interpreter PerlInterpreter;
 
@@ -4909,6 +4910,7 @@ typedef OP* (*Perl_ppaddr_t)(pTHX);
 typedef OP* (*Perl_check_t) (pTHX_ OP*);
 typedef void(*Perl_ophook_t)(pTHX_ OP*);
 typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**);
+typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *);
 
 #define KEYWORD_PLUGIN_DECLINE 0
 #define KEYWORD_PLUGIN_STMT    1

diff --git a/proto.h b/proto.h
index 3bae4fe..3a80ae2 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -588,6 +588,18 @@ PERL_CALLCONV const char * Perl_custom_op_name(pTHX_ const OP *o)
 #define PERL_ARGS_ASSERT_CUSTOM_OP_NAME        \
        assert(o)
 
+PERL_CALLCONV void     Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER    \
+       assert(ppaddr); assert(xop)
+
+PERL_CALLCONV const XOP *      Perl_custom_op_xop(pTHX_ const OP *o)
+                       __attribute__pure__
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_XOP \
+       assert(o)
+
 PERL_CALLCONV void     Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CV_CKPROTO_LEN        \

diff --git a/regen/opcode.pl b/regen/opcode.pl
index 90c1bc0..bd3d55a 100755 (executable)
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -181,11 +181,6 @@ print $on "#define OP_phoney_OUTPUT_ONLY -2\n\n";
 print <<END;
 START_EXTERN_C
 
-#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \\
-                    PL_op_name[(o)->op_type])
-#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \\
-                    PL_op_desc[(o)->op_type])
-
 #ifndef DOINIT
 EXTCONST char* const PL_op_name[];
 #else

diff --git a/sv.c b/sv.c
index 04e1df1..57db4f4 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -12901,6 +12901,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_modglobal       = hv_dup_inc(proto_perl->Imodglobal, param);
     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+    PL_custom_ops      = hv_dup_inc(proto_perl->Icustom_ops, param);
 
     PL_profiledata     = NULL;