add UNOP_AUX OP class
authorDavid Mitchell <davem@iabyn.com>
Mon, 27 Oct 2014 17:33:32 +0000 (17:33 +0000)
committerDavid Mitchell <davem@iabyn.com>
Sun, 7 Dec 2014 09:07:30 +0000 (09:07 +0000)
This is the same as a UNOP, but with the addition of an op_aux field,
which points to an array of UNOP_AUX_item unions.

It is intended as a general escape mechanism for adding per-op-type extra
fields (or arrays of items) to UNOPs.

Its class character (for regen/opcodes etc) is '+'.

Currently there are no ops of this type; but shortly, OP_MULTIDEREF will
be added, which is the original motivation for this new op type.

12 files changed:
embed.fnc
embed.h
ext/B/B.pm
ext/B/B.xs
ext/B/B/Concise.pm
op.c
op.h
perl.h
proto.h
regen/op_private
regen/opcode.pl
regen/opcodes

index 0af427e..26d893d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1032,6 +1032,8 @@ Apd       |SV*    |newSVrv        |NN SV *const rv|NULLOK const char *const classname
 Apda   |SV*    |newSVsv        |NULLOK SV *const old
 Apda   |SV*    |newSV_type     |const svtype type
 Apda   |OP*    |newUNOP        |I32 type|I32 flags|NULLOK OP* first
+Apda   |OP*    |newUNOP_AUX    |I32 type|I32 flags|NULLOK OP* first \
+                               |NULLOK UNOP_AUX_item *aux
 Apda   |OP*    |newWHENOP      |NULLOK OP* cond|NN OP* block
 Apda   |OP*    |newWHILEOP     |I32 flags|I32 debuggable|NULLOK LOOP* loop \
                                |NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
diff --git a/embed.h b/embed.h
index 91ef308..7108b3e 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define newSVsv(a)             Perl_newSVsv(aTHX_ a)
 #define newSVuv(a)             Perl_newSVuv(aTHX_ a)
 #define newUNOP(a,b,c)         Perl_newUNOP(aTHX_ a,b,c)
+#define newUNOP_AUX(a,b,c,d)   Perl_newUNOP_AUX(aTHX_ a,b,c,d)
 #define newWHENOP(a,b)         Perl_newWHENOP(aTHX_ a,b)
 #define newWHILEOP(a,b,c,d,e,f,g)      Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
 #define newXS(a,b,c)           Perl_newXS(aTHX_ a,b,c)
index 4dffea1..75054f4 100644 (file)
@@ -60,6 +60,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 
 @B::OP::ISA = 'B::OBJECT';
 @B::UNOP::ISA = 'B::OP';
+@B::UNOP_AUX::ISA = 'B::UNOP';
 @B::BINOP::ISA = 'B::UNOP';
 @B::LOGOP::ISA = 'B::UNOP';
 @B::LISTOP::ISA = 'B::BINOP';
@@ -73,7 +74,8 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 
 @B::SPECIAL::ISA = 'B::OBJECT';
 
-@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP METHOP);
+@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP
+                METHOP UNOP_AUX);
 # bytecode.pl contained the following comment:
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
@@ -1089,8 +1091,9 @@ information is no longer stored directly in the hash.
 
 =head2 OP-RELATED CLASSES
 
-C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
-C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>, C<B::METHOP>.
+C<B::OP>, C<B::UNOP>, C<B::UNOP_AUX>, C<B::BINOP>, C<B::LOGOP>,
+C<B::LISTOP>, C<B::PMOP>, C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>,
+C<B::COP>, C<B::METHOP>.
 
 These classes correspond in the obvious way to the underlying C
 structures of similar names.  The inheritance hierarchy mimics the
@@ -1101,15 +1104,17 @@ underlying C "inheritance":
                    +----------+---------+--------+-------+---------+
                    |          |         |        |       |         |
                 B::UNOP    B::SVOP  B::PADOP  B::COP  B::PVOP  B::METHOP
-                 ,'  `-.
-                /       `--.
-           B::BINOP     B::LOGOP
+                   |
+               +---+---+---------+
+               |       |         |
+           B::BINOP  B::LOGOP  B::UNOP_AUX
                |
                |
            B::LISTOP
-             ,' `.
-            /     \
-        B::LOOP B::PMOP
+               |
+           +---+---+
+           |       |
+        B::LOOP   B::PMOP
 
 Access methods correspond to the underlying C structure field names,
 with the leading "class indication" prefix (C<"op_">) removed.
@@ -1166,6 +1171,27 @@ This returns the op description from the global C PL_op_desc array
 
 =back
 
+=head2 B::UNOP_AUX METHODS (since 5.22)
+
+=over 4
+
+=item aux_list(cv)
+
+This returns a list of the elements of the op's aux data structure,
+or a null list if there is no aux. What will be returned depends on the
+object's type, but will typically be a collection of C<B::IV>, C<B::GV>,
+etc. objects. C<cv> is the C<B::CV> object representing the sub that the
+op is contained within.
+
+=item string(cv)
+
+This returns a textual representation of the object (likely to b useful
+for deparsing and debugging), or an empty string if the op type doesn't
+support this. C<cv> is the C<B::CV> object representing the sub that the
+op is contained within.
+
+=back
+
 =head2 B::BINOP METHOD
 
 =over 4
index da05cc1..937ef2c 100644 (file)
@@ -61,7 +61,8 @@ typedef enum {
     OPc_PVOP,  /* 9 */
     OPc_LOOP,  /* 10 */
     OPc_COP,   /* 11 */
-    OPc_METHOP /* 12 */
+    OPc_METHOP,        /* 12 */
+    OPc_UNOP_AUX /* 13 */
 } opclass;
 
 static const char* const opclassnames[] = {
@@ -77,7 +78,8 @@ static const char* const opclassnames[] = {
     "B::PVOP",
     "B::LOOP",
     "B::COP",
-    "B::METHOP"
+    "B::METHOP",
+    "B::UNOP_AUX"
 };
 
 static const size_t opsizes[] = {
@@ -93,7 +95,8 @@ static const size_t opsizes[] = {
     sizeof(PVOP),
     sizeof(LOOP),
     sizeof(COP),
-    sizeof(METHOP)
+    sizeof(METHOP),
+    sizeof(UNOP_AUX),
 };
 
 #define MY_CXT_KEY "B::_guts" XS_VERSION
@@ -240,6 +243,8 @@ cc_opclass(pTHX_ const OP *o)
            return OPc_PVOP;
     case OA_METHOP:
        return OPc_METHOP;
+    case OA_UNOP_AUX:
+       return OPc_UNOP_AUX;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
         OP_NAME(o));
@@ -1317,6 +1322,50 @@ oplist(o)
        SP = oplist(aTHX_ o, SP);
 
 
+
+MODULE = B     PACKAGE = B::UNOP_AUX
+
+# UNOP_AUX class ops are like UNOPs except that they have an extra
+# op_aux pointer that points to an array of UNOP_AUX_item unions.
+# Element -1 of the array contains the length
+
+
+# return a string representation of op_aux where possible The op's CV is
+# needed as an extra arg to allow GVs and SVs moved into the pad to be
+# accessed okay.
+
+void
+string(o, cv)
+       B::OP  o
+       B::CV  cv
+    PREINIT:
+       SV *ret;
+    PPCODE:
+        switch (o->op_type) {
+        default:
+            ret = sv_2mortal(newSVpvn("", 0));
+        }
+       ST(0) = ret;
+       XSRETURN(1);
+
+
+# Return the contents of the op_aux array as a list of IV/GV/etc objects.
+# How to interpret each array element is op-dependent. The op's CV is
+# needed as an extra arg to allow GVs and SVs which have been moved into
+# the pad to be accessed okay.
+
+void
+aux_list(o, cv)
+       B::OP  o
+       B::CV  cv
+    PPCODE:
+        switch (o->op_type) {
+        default:
+            XSRETURN(0); /* by default, an empty list */
+        } /* switch */
+
+
+
 MODULE = B     PACKAGE = B::SV
 
 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
index 5e068b7..381181e 100644 (file)
@@ -401,7 +401,7 @@ my $lastnext;       # remembers op-chain, used to insert gotos
 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
               'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
               'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
-              'METHOP' => '.');
+              'METHOP' => '.', UNOP_AUX => '+');
 
 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
 my @linenoise =
@@ -915,6 +915,10 @@ sub concise_op {
             }
         }
     }
+    elsif ($h{class} eq "UNOP_AUX") {
+        $h{arg} = "(" . $op->string . ")";
+    }
+
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
     $h{opt} = $op->opt;
@@ -1383,6 +1387,7 @@ B:: namespace that represents the ops in your Perl code.
 
     0      OP (aka BASEOP)  An OP with no children
     1      UNOP             An OP with one child
+    +      UNOP_AUX         A UNOP with auxillary fields
     2      BINOP            An OP with two children
     |      LOGOP            A control branch OP
     @      LISTOP           An OP that could have lots of children
diff --git a/op.c b/op.c
index a95c6f4..f34e932 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2424,6 +2424,7 @@ S_finalize_op(pTHX_ OP* o)
         assert(  has_last /* has op_first and op_last, or ...
               ... has (or may have) op_first: */
               || family == OA_UNOP
+              || family == OA_UNOP_AUX
               || family == OA_LOGOP
               || family == OA_BASEOP_OR_UNOP
               || family == OA_FILESTATOP
@@ -4703,6 +4704,43 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
     return fold_constants(op_integerize(op_std_init((OP *) unop)));
 }
 
+/*
+=for apidoc
+
+Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
+initialised to aux
+
+=cut
+*/
+
+OP *
+Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
+{
+    dVAR;
+    UNOP_AUX *unop;
+
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX);
+
+    NewOp(1101, unop, 1, UNOP_AUX);
+    unop->op_type = (OPCODE)type;
+    unop->op_ppaddr = PL_ppaddr[type];
+    unop->op_first = first;
+    unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
+    unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
+    unop->op_aux = aux;
+
+#ifdef PERL_OP_PARENT
+    if (first && !OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+        first->op_sibling = (OP*)unop;
+#endif
+
+    unop = (UNOP_AUX*) CHECKOP(type, unop);
+    if (unop->op_next)
+       return (OP*)unop;
+
+    return fold_constants(op_integerize(op_std_init((OP *) unop)));
+}
+
 /*
 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
 
diff --git a/op.h b/op.h
index befdc79..61a382f 100644 (file)
--- a/op.h
+++ b/op.h
@@ -169,6 +169,14 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
 
 
+/* things that can be elements of op_aux */
+typedef union  {
+    PADOFFSET pad_offset;
+    SV        *sv;
+    IV        iv;
+    UV        uv;
+} UNOP_AUX_item;
+
 
 struct op {
     BASEOP
@@ -179,6 +187,12 @@ struct unop {
     OP *       op_first;
 };
 
+struct unop_aux {
+    BASEOP
+    OP           *op_first;
+    UNOP_AUX_item *op_aux;
+};
+
 struct binop {
     BASEOP
     OP *       op_first;
@@ -394,6 +408,7 @@ struct loop {
 };
 
 #define cUNOPx(o)      ((UNOP*)o)
+#define cUNOP_AUXx(o)  ((UNOP_AUX*)o)
 #define cBINOPx(o)     ((BINOP*)o)
 #define cLISTOPx(o)    ((LISTOP*)o)
 #define cLOGOPx(o)     ((LOGOP*)o)
@@ -406,6 +421,7 @@ struct loop {
 #define cMETHOPx(o)    ((METHOP*)o)
 
 #define cUNOP          cUNOPx(PL_op)
+#define cUNOP_AUX      cUNOP_AUXx(PL_op)
 #define cBINOP         cBINOPx(PL_op)
 #define cLISTOP                cLISTOPx(PL_op)
 #define cLOGOP         cLOGOPx(PL_op)
@@ -417,6 +433,7 @@ struct loop {
 #define cLOOP          cLOOPx(PL_op)
 
 #define cUNOPo         cUNOPx(o)
+#define cUNOP_AUXo     cUNOP_AUXx(o)
 #define cBINOPo                cBINOPx(o)
 #define cLISTOPo       cLISTOPx(o)
 #define cLOGOPo                cLOGOPx(o)
@@ -428,6 +445,7 @@ struct loop {
 #define cLOOPo         cLOOPx(o)
 
 #define kUNOP          cUNOPx(kid)
+#define kUNOP_AUX      cUNOP_AUXx(kid)
 #define kBINOP         cBINOPx(kid)
 #define kLISTOP                cLISTOPx(kid)
 #define kLOGOP         cLOGOPx(kid)
@@ -505,6 +523,7 @@ struct loop {
 #define OA_FILESTATOP (12 << OCSHIFT)
 #define OA_LOOPEXOP (13 << OCSHIFT)
 #define OA_METHOP (14 << OCSHIFT)
+#define OA_UNOP_AUX (15 << OCSHIFT)
 
 /* Each remaining nybble of PL_opargs (i.e. bits 12..15, 16..19 etc)
  * encode the type for each arg */
diff --git a/perl.h b/perl.h
index 8466bc7..2a77522 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2594,6 +2594,7 @@ typedef MEM_SIZE STRLEN;
 typedef struct op OP;
 typedef struct cop COP;
 typedef struct unop UNOP;
+typedef struct unop_aux UNOP_AUX;
 typedef struct binop BINOP;
 typedef struct listop LISTOP;
 typedef struct logop LOGOP;
diff --git a/proto.h b/proto.h
index 8ac92dd..eb2ba5a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3134,6 +3134,10 @@ PERL_CALLCONV OP*        Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
 
+PERL_CALLCONV OP*      Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP* first, UNOP_AUX_item *aux)
+                       __attribute__malloc__
+                       __attribute__warn_unused_result__;
+
 PERL_CALLCONV OP*      Perl_newWHENOP(pTHX_ OP* cond, OP* block)
                        __attribute__malloc__
                        __attribute__warn_unused_result__
index d8cf6e6..731c4fb 100644 (file)
@@ -204,6 +204,7 @@ use strict;
                         qw(reverse), # ck_fun(), but most bits stolen
                         grep !$maxarg{$_} && !$args0{$_},
                             ops_with_flag('1'), # UNOP
+                            ops_with_flag('+'), # UNOP_AUX
                             ops_with_flag('%'), # BASEOP/UNOP
                             ops_with_flag('|'), # LOGOP
                             ops_with_flag('-'), # FILESTATOP
index fa9127c..327e45e 100755 (executable)
@@ -1114,6 +1114,7 @@ my %opclass = (
     '-',  12,          # filestatop
     '}',  13,          # loopexop
     '.',  14,          # methop
+    '+',  15,          # unop_aux
 );
 
 my %opflags = (
index 62c3b45..4731fa7 100644 (file)
@@ -14,6 +14,7 @@
 # padop/svop  - $            padop    - # (unused)   loop       - {
 # baseop/unop - %            loopexop - }            filestatop - -
 # pvop/svop   - "            cop      - ;            methop     - .
+# unop_aux    - +
 
 # Other options are:
 #   needs stack mark                    - m  (OA_MARK)