This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add op_lastsib and -DPERL_OP_PARENT
authorDavid Mitchell <davem@iabyn.com>
Fri, 27 Jun 2014 10:52:44 +0000 (11:52 +0100)
committerDavid Mitchell <davem@iabyn.com>
Tue, 8 Jul 2014 15:40:03 +0000 (16:40 +0100)
Add the boolean field op_lastsib to OPs. Within the core, this is set
on the last op in an op_sibling chain (so it is synonymous with op_sibling
being null). By default, its value is set but not used.

In addition, add a new build define (not yet enabled by default),
-DPERL_OP_PARENT, that forces the core to use op_lastsib to detect the
last op in a sibling chain, rather than op_sibling being NULL. This frees
up the last op_sibling pointer in the chain, which rather than being set
to NULL, is now set to point back to the parent of the sibling chain (if
any).

This commit also adds a C-level op_parent() function and B parent()
method; under default builds they just return NULL, under PERL_OP_PARENT
they return the parent of the current op.

Collectively this provides a facility not previously available from B:: nor
C, of being able to follow an op tree up as well as down.

14 files changed:
dump.c
embed.fnc
embed.h
ext/B/B.pm
ext/B/B.xs
ext/B/t/b.t
ext/Devel-Peek/Peek.xs
ext/Devel-Peek/t/Peek.t
ext/XS-APItest/APItest.xs
op.c
op.h
pod/perlguts.pod
pp_ctl.c
proto.h

diff --git a/dump.c b/dump.c
index 0ea278f..d15aee6 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -901,6 +901,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");              \
         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");                \
         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");                \
+        if (o->op_lastsib)  sv_catpvs(tmpsv, ",LASTSIB");               \
         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",           \
                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");   \
     }
index 56b482a..604f7c4 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -466,7 +466,7 @@ pR  |OP *   |parse_subsignature
 p      |char*  |find_script    |NN const char *scriptname|bool dosearch \
                                |NULLOK const char *const *const search_ext|I32 flags
 #if defined(PERL_IN_OP_C)
-s      |OP*    |force_list     |NULLOK OP* arg
+s      |OP*    |force_list     |NULLOK OP* arg|bool nullit
 i      |OP*    |op_integerize  |NN OP *o
 i      |OP*    |op_std_init    |NN OP *o
 : FIXME
@@ -773,6 +773,7 @@ Ap  |void   |op_refcnt_lock
 Ap     |void   |op_refcnt_unlock
 Apd    |OP*    |op_sibling_splice|NN OP *parent|NULLOK OP *start \
                |int del_count|NULLOK OP* insert
+Apd    |OP*    |op_parent|NN OP *o
 #if defined(PERL_IN_OP_C)
 s      |OP*    |listkids       |NULLOK OP* o
 #endif
diff --git a/embed.h b/embed.h
index a36245d..f6b7bda 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define op_free(a)             Perl_op_free(aTHX_ a)
 #define op_linklist(a)         Perl_op_linklist(aTHX_ a)
 #define op_null(a)             Perl_op_null(aTHX_ a)
+#define op_parent(a)           Perl_op_parent(aTHX_ a)
 #define op_prepend_elem(a,b,c) Perl_op_prepend_elem(aTHX_ a,b,c)
 #define op_refcnt_lock()       Perl_op_refcnt_lock(aTHX)
 #define op_refcnt_unlock()     Perl_op_refcnt_unlock(aTHX)
 #define finalize_op(a)         S_finalize_op(aTHX_ a)
 #define find_and_forget_pmops(a)       S_find_and_forget_pmops(aTHX_ a)
 #define fold_constants(a)      S_fold_constants(aTHX_ a)
-#define force_list(a)          S_force_list(aTHX_ a)
+#define force_list(a,b)                S_force_list(aTHX_ a,b)
 #define forget_pmop(a)         S_forget_pmop(aTHX_ a)
 #define gen_constant_list(a)   S_gen_constant_list(aTHX_ a)
 #define gv_ename(a)            S_gv_ename(aTHX_ a)
index 0f0b584..c908f51 100644 (file)
@@ -1089,6 +1089,11 @@ data structure.  See top of C<op.h> for more info.
 
 =item sibling
 
+=item parent
+
+Returns the OP's parent. If it has no parent, or if your perl wasn't built
+with C<-DPERL_OP_PARENT>, returns NULL.
+
 =item name
 
 This returns the op name as a string (e.g. "add", "rv2av").
index 871d07a..a130ad3 100644 (file)
@@ -731,6 +731,8 @@ struct OP_methods {
   { STR_WITH_LEN("static"),  op_offset_special, 0,                     },/*49*/
 #  if PERL_VERSION >= 19
   { STR_WITH_LEN("folded"),  op_offset_special, 0,                     },/*50*/
+  { STR_WITH_LEN("lastsib"), op_offset_special, 0,                     },/*51*/
+  { STR_WITH_LEN("parent"),  op_offset_special, 0,                     },/*52*/
 #  endif
 #endif
 };
@@ -1008,6 +1010,8 @@ next(o)
        B::OP::savefree      = 48
        B::OP::static        = 49
        B::OP::folded        = 50
+       B::OP::lastsib       = 51
+       B::OP::parent        = 52
     PREINIT:
        SV *ret;
     PPCODE:
@@ -1088,6 +1092,7 @@ next(o)
            case 49: /* static   */
 #if PERL_VERSION >= 19
            case 50: /* folded   */
+           case 51: /* lastsib  */
 #endif
 #endif
            /* These are all bitfields, so we can't take their addresses */
@@ -1098,6 +1103,7 @@ next(o)
                                    : ix == 48 ? o->op_savefree
                                    : ix == 49 ? o->op_static
                                    : ix == 50 ? o->op_folded
+                                   : ix == 51 ? o->op_lastsib
                                    :            o->op_spare)));
                break;
            case 33: /* children */
@@ -1204,6 +1210,9 @@ next(o)
                sv_setiv(newSVrv(ret, "B::RHE"),
                        PTR2IV(CopHINTHASH_get(cCOPo)));
                break;
+           case 52: /* parent */
+               ret = make_op_object(aTHX_ op_parent(o));
+               break;
            default:
                croak("method %s not implemented", op_methods[ix].name);
        } else {
index 1fee139..27b4105 100644 (file)
@@ -422,4 +422,23 @@ EOS
     is($k, "\x{100}", "check utf8 preserved by B::HV::ARRAY");
 }
 
+# test op_parent
+
+SKIP: {
+    unless ($Config::Config{ccflags} =~ /PERL_OP_PARENT/) {
+        skip "op_parent only present with -DPERL_OP_PARENT builds", 6;
+    }
+    my $lineseq = B::svref_2object(sub{my $x = 1})->ROOT->first;
+    is ($lineseq->type,  B::opnumber('lineseq'),
+                                'op_parent: top op is lineseq');
+    my $first  = $lineseq->first;
+    my $second = $first->sibling;
+    is(ref $second->sibling, "B::NULL", 'op_parent: second sibling is null');
+    is($first->lastsib,  0 , 'op_parent: first  sibling: !lastsib');
+    is($second->lastsib, 1,  'op_parent: second sibling: lastsib');
+    is($$lineseq,  ${$first->parent},   'op_parent: first  sibling okay');
+    is($$lineseq,  ${$second->parent},  'op_parent: second sibling okay');
+}
+
+
 done_testing();
index b8a18d6..49dbea3 100644 (file)
@@ -398,10 +398,9 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
     NewOp(1234, newop, 1, BINOP);
     newop->op_type   = OP_CUSTOM;
     newop->op_ppaddr = S_pp_dump;
-    newop->op_first  = first;
-    newop->op_last   = second;
     newop->op_private= second ? 2 : 1;
     newop->op_flags  = OPf_KIDS|OPf_WANT_SCALAR;
+    op_sibling_splice((OP*)newop, NULL, 0, first);
 
     return (OP *)newop;
 }
index 425268a..0cc6717 100644 (file)
@@ -1527,7 +1527,7 @@ dumpindent is 4 at - line 1.
 {
 1   TYPE = leave  ===> NULL
     TARG = 1
-    FLAGS = (VOID,KIDS,PARENS,SLABBED)
+    FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB)
     PRIVATE = (REFCOUNTED)
     REFCNT = 1
     {
@@ -1543,12 +1543,12 @@ dumpindent is 4 at - line 1.
     {
 5       TYPE = entersub  ===> 1
         TARG = TARGS_REPLACE
-        FLAGS = (VOID,KIDS,STACKED,SLABBED)
+        FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB)
         PRIVATE = (HASTARG)
         {
 6           TYPE = null  ===> (5)
               (was list)
-            FLAGS = (UNKNOWN,KIDS,SLABBED)
+            FLAGS = (UNKNOWN,KIDS,SLABBED,LASTSIB)
             {
 4               TYPE = pushmark  ===> 7
                 FLAGS = (SCALAR,SLABBED)
@@ -1556,10 +1556,10 @@ dumpindent is 4 at - line 1.
             {
 8               TYPE = null  ===> (6)
                   (was rv2cv)
-                FLAGS = (SCALAR,KIDS,SLABBED)
+                FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB)
                 {
 7                   TYPE = gv  ===> 5
-                    FLAGS = (SCALAR,SLABBED)
+                    FLAGS = (SCALAR,SLABBED,LASTSIB)
                     GV_OR_PADIX
                 }
             }
index 6cd3156..54ee2da 100644 (file)
@@ -479,8 +479,7 @@ THX_mkUNOP(pTHX_ U32 type, OP *first)
     UNOP *unop;
     NewOp(1103, unop, 1, UNOP);
     unop->op_type   = (OPCODE)type;
-    unop->op_first  = first;
-    unop->op_flags  = OPf_KIDS;
+    op_sibling_splice((OP*)unop, NULL, 0, first);
     return (OP *)unop;
 }
 
@@ -491,11 +490,8 @@ THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
     BINOP *binop;
     NewOp(1103, binop, 1, BINOP);
     binop->op_type      = (OPCODE)type;
-    binop->op_first     = first;
-    binop->op_flags     = OPf_KIDS;
-    binop->op_last      = last;
-    if (last)
-        OP_SIBLING_set(first, last);
+    op_sibling_splice((OP*)binop, NULL, 0, last);
+    op_sibling_splice((OP*)binop, NULL, 0, first);
     return (OP *)binop;
 }
 
@@ -506,11 +502,9 @@ THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
     LISTOP *listop;
     NewOp(1103, listop, 1, LISTOP);
     listop->op_type     = (OPCODE)type;
-    listop->op_flags    = OPf_KIDS;
-    listop->op_first    = first;
-    OP_SIBLING_set(first, sib);
-    OP_SIBLING_set(sib, last);
-    listop->op_last     = last;
+    op_sibling_splice((OP*)listop, NULL, 0, last);
+    op_sibling_splice((OP*)listop, NULL, 0, sib);
+    op_sibling_splice((OP*)listop, NULL, 0, first);
     return (OP *)listop;
 }
 
diff --git a/op.c b/op.c
index 57c1537..89b660d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -194,7 +194,10 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
        don't use a slab, but allocate the OP directly from the heap.  */
     if (!PL_compcv || CvROOT(PL_compcv)
      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
-       return PerlMemShared_calloc(1, sz);
+    {
+       o = (OP*)PerlMemShared_calloc(1, sz);
+        goto gotit;
+    }
 
     /* While the subroutine is under construction, the slabs are accessed via
        CvSTART(), to avoid needing to expand PVCV by one pointer for something
@@ -229,7 +232,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
            *too = o->op_next;
            Zero(o, opsz, I32 *);
            o->op_slabbed = 1;
-           return (void *)o;
+           goto gotit;
        }
     }
 
@@ -275,6 +278,12 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
        slot = &slab2->opslab_slots;
     INIT_OPSLOT;
     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
+
+  gotit:
+    /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
+    o->op_lastsib = 1;
+    assert(!o->op_sibling);
+
     return (void *)o;
 }
 
@@ -1057,8 +1066,8 @@ A general function for editing the structure of an existing chain of
 op_sibling nodes. By analogy with the perl-level splice() function, allows
 you to delete zero or more sequential nodes, replacing them with zero or
 more different nodes.  Performs the necessary op_first/op_last
-housekeeping on the parent node and op_silbing manipulation on the
-children. The op_silbing field of the last deleted node will be set to
+housekeeping on the parent node and op_sibling manipulation on the
+children. The op_sibling field of the last deleted node will be set to
 NULL.
 
 Note that op_next is not manipulated, and nodes are not freed; that is the
@@ -1125,6 +1134,7 @@ Perl_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP* insert)
             last_del = OP_SIBLING(last_del);
         rest = OP_SIBLING(last_del);
         OP_SIBLING_set(last_del, NULL);
+        last_del->op_lastsib = 1;
     }
     else
         rest = first;
@@ -1134,34 +1144,69 @@ Perl_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP* insert)
         while (OP_HAS_SIBLING(last_ins))
             last_ins = OP_SIBLING(last_ins);
         OP_SIBLING_set(last_ins, rest);
+        last_ins->op_lastsib = rest ? 0 : 1;
     }
     else
         insert = rest;
 
-    if (start)
+    if (start) {
         OP_SIBLING_set(start, insert);
+        start->op_lastsib = insert ? 0 : 1;
+    }
     else
         cLISTOPx(parent)->op_first = insert;
 
     if (!rest) {
-        /* update op_last */
+        /* update op_last etc */
         U32 type = parent->op_type;
+        OP *lastop;
 
         if (type == OP_NULL)
             type = parent->op_targ;
         type = PL_opargs[type] & OA_CLASS_MASK;
 
+        lastop = last_ins ? last_ins : start ? start : NULL;
         if (   type == OA_BINOP
             || type == OA_LISTOP
             || type == OA_PMOP
             || type == OA_LOOP
         )
-            cLISTOPx(parent)->op_last =
-                (last_ins ? last_ins : start ? start : NULL);
+            cLISTOPx(parent)->op_last = lastop;
+
+        if (lastop) {
+            lastop->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+            lastop->op_sibling = parent;
+#endif
+        }
     }
     return last_del ? first : NULL;
 }
 
+/*
+=for apidoc op_parent
+
+returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
+work.
+
+=cut
+*/
+
+OP *
+Perl_op_parent(pTHX_ OP *o)
+{
+    PERL_ARGS_ASSERT_OP_PARENT;
+#ifdef PERL_OP_PARENT
+    while (OP_HAS_SIBLING(o))
+        o = OP_SIBLING(o);
+    return o->op_sibling;
+#else
+    PERL_UNUSED_ARG(o);
+    return NULL;
+#endif
+}
+
 
 /* replace the sibling following start with a new UNOP, which becomes
  * the parent of the original sibling; e.g.
@@ -1204,11 +1249,20 @@ LOGOP *
 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
 {
     LOGOP *logop;
+    OP *kid = first;
     NewOp(1101, logop, 1, LOGOP);
     logop->op_type = type;
     logop->op_first = first;
     logop->op_other = other;
     logop->op_flags = OPf_KIDS;
+    while (kid && OP_HAS_SIBLING(kid))
+        kid = OP_SIBLING(kid);
+    if (kid) {
+        kid->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+        kid->op_sibling = (OP*)logop;
+#endif
+    }
     return logop;
 }
 
@@ -1266,9 +1320,10 @@ Perl_op_linklist(pTHX_ OP *o)
        o->op_next = LINKLIST(first);
        kid = first;
        for (;;) {
-           if (OP_HAS_SIBLING(kid)) {
-               kid->op_next = LINKLIST(OP_SIBLING(kid));
-               kid = OP_SIBLING(kid);
+            OP *sibl = OP_SIBLING(kid);
+            if (sibl) {
+                kid->op_next = LINKLIST(sibl);
+                kid = sibl;
            } else {
                kid->op_next = o;
                break;
@@ -2211,12 +2266,20 @@ S_finalize_op(pTHX_ OP* o)
         {
             OP *kid;
             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+#  ifdef PERL_OP_PARENT
                 if (!OP_HAS_SIBLING(kid)) {
-                    if (kid != cLISTOPo->op_last)
-                    {
-                        assert(kid == cLISTOPo->op_last);
-                    }
+                    assert(kid == cLISTOPo->op_last);
+                    assert(kid->op_sibling == o);
+                }
+#  else
+                if (OP_HAS_SIBLING(kid)) {
+                    assert(!kid->op_lastsib);
                 }
+                else {
+                    assert(kid->op_lastsib);
+                    assert(kid == cLISTOPo->op_last);
+                }
+#  endif
             }
         }
 #endif
@@ -3853,20 +3916,17 @@ S_gen_constant_list(pTHX_ OP *o)
     return list(o);
 }
 
+/* convert o (and any siblings) into a list if not already, then
+ * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
+ */
+
 OP *
 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
 {
     dVAR;
     if (type < 0) type = -type, flags |= OPf_SPECIAL;
-    if (!o || o->op_type != OP_LIST) {
-        OP* last = o;
-       o = newLISTOP(OP_LIST, 0, o, NULL);
-        if (last) {
-            while (OP_HAS_SIBLING(last))
-                last = OP_SIBLING(last);
-            cLISTOPo->op_last = last;
-        }
-    }
+    if (!o || o->op_type != OP_LIST)
+        o = force_list(o, 0);
     else
        o->op_flags &= ~OPf_WANT;
 
@@ -3958,8 +4018,13 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
     if (last->op_type != (unsigned)type)
        return op_append_elem(type, first, last);
 
+    ((LISTOP*)first)->op_last->op_lastsib = 0;
     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
+    ((LISTOP*)first)->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+    ((LISTOP*)first)->op_last->op_sibling = first;
+#endif
     first->op_flags |= (last->op_flags & OPf_KIDS);
 
 
@@ -4026,19 +4091,36 @@ Perl_newNULLLIST(pTHX)
     return newOP(OP_STUB, 0);
 }
 
+/* promote o and any siblings to be a list if its not already; i.e.
+ *
+ *  o - A - B
+ *
+ * becomes
+ *
+ *  list
+ *    |
+ *  pushmark - o - A - B
+ *
+ * If nullit it true, the list op is nulled.
+ */
+
 static OP *
-S_force_list(pTHX_ OP *o)
+S_force_list(pTHX_ OP *o, bool nullit)
 {
     if (!o || o->op_type != OP_LIST) {
-        OP* last = o;
-       o = newLISTOP(OP_LIST, 0, o, NULL);
-        if (last) {
-            while (OP_HAS_SIBLING(last))
-                last = OP_SIBLING(last);
-            cLISTOPo->op_last = last;
+        OP *rest = NULL;
+        if (o) {
+            /* manually detach any siblings then add them back later */
+            rest = OP_SIBLING(o);
+            OP_SIBLING_set(o, NULL);
+            o->op_lastsib = 1;
         }
+       o = newLISTOP(OP_LIST, 0, o, NULL);
+        if (rest)
+            op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
     }
-    op_null(o);
+    if (nullit)
+        op_null(o);
     return o;
 }
 
@@ -4080,12 +4162,21 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
     listop->op_last = last;
     if (type == OP_LIST) {
        OP* const pushop = newOP(OP_PUSHMARK, 0);
+        pushop->op_lastsib = 0;
        OP_SIBLING_set(pushop, first);
        listop->op_first = pushop;
        listop->op_flags |= OPf_KIDS;
        if (!last)
            listop->op_last = pushop;
     }
+    if (first)
+        first->op_lastsib = 0;
+    if (listop->op_last) {
+        listop->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+        listop->op_last->op_sibling = (OP*)listop;
+#endif
+    }
 
     return CHECKOP(type, listop);
 }
@@ -4124,7 +4215,6 @@ Perl_newOP(pTHX_ I32 type, I32 flags)
 
     o->op_next = o;
     o->op_private = (U8)(0 | (flags >> 8));
-
     if (PL_opargs[type] & OA_RETSCALAR)
        scalar(o);
     if (PL_opargs[type] & OA_TARGET)
@@ -4168,7 +4258,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
     if (!first)
        first = newOP(OP_STUB, 0);
     if (PL_opargs[type] & OA_MARK)
-       first = force_list(first);
+       first = force_list(first, 1);
 
     NewOp(1101, unop, 1, UNOP);
     unop->op_type = (OPCODE)type;
@@ -4176,6 +4266,12 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
     unop->op_first = first;
     unop->op_flags = (U8)(flags | OPf_KIDS);
     unop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+    if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+        first->op_sibling = (OP*)unop;
+#endif
+
     unop = (UNOP*) CHECKOP(type, unop);
     if (unop->op_next)
        return (OP*)unop;
@@ -4222,13 +4318,23 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
     else {
        binop->op_private = (U8)(2 | (flags >> 8));
        OP_SIBLING_set(first, last);
+        first->op_lastsib = 0;
     }
 
+#ifdef PERL_OP_PARENT
+    if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
+        last->op_sibling = (OP*)binop;
+#endif
+
     binop = (BINOP*)CHECKOP(type, binop);
     if (binop->op_next || binop->op_type != (OPCODE)type)
        return (OP*)binop;
 
     binop->op_last = OP_SIBLING(binop->op_first);
+#ifdef PERL_OP_PARENT
+    if (binop->op_last)
+        binop->op_last->op_sibling = (OP*)binop;
+#endif
 
     return fold_constants(op_integerize(op_std_init((OP *)binop)));
 }
@@ -4928,7 +5034,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
            cv_targ = expr->op_targ;
            expr = newUNOP(OP_REFGEN, 0, expr);
 
-           expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
+           expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
        }
 
         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
@@ -5461,8 +5567,8 @@ OP *
 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
 {
     return newBINOP(OP_LSLICE, flags,
-           list(force_list(subscript)),
-           list(force_list(listval)) );
+           list(force_list(subscript, 1)),
+           list(force_list(listval,   1)) );
 }
 
 STATIC I32
@@ -5628,8 +5734,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 
        PL_modcount = 0;
        left = op_lvalue(left, OP_AASSIGN);
-       curop = list(force_list(left));
-       o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
+       curop = list(force_list(left, 1));
+       o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
        o->op_private = (U8)(0 | (flags >> 8));
 
        if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
@@ -6207,7 +6313,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
     start = LINKLIST(first);
     first->op_next = (OP*)logop;
 
-    /* make first, trueop, falseop silbings */
+    /* make first, trueop, falseop siblings */
     op_sibling_splice((OP*)logop, first,  0, trueop);
     op_sibling_splice((OP*)logop, trueop, 0, falseop);
 
@@ -6590,7 +6696,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
     }
 
     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
-       expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
+       expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
        iterflags |= OPf_STACKED;
     }
     else if (expr->op_type == OP_NULL &&
@@ -6623,7 +6729,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
        iterflags |= OPf_STACKED;
     }
     else {
-        expr = op_lvalue(force_list(expr), OP_GREPSTART);
+        expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
     }
 
     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
@@ -6639,6 +6745,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
        LOOP *tmp;
        NewOp(1234,tmp,1,LOOP);
        Copy(loop,tmp,1,LISTOP);
+#ifdef PERL_OP_PARENT
+        assert(loop->op_last->op_sibling == (OP*)loop);
+        loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
+#endif
        S_op_destroy(aTHX_ (OP*)loop);
        loop = tmp;
     }
@@ -6811,9 +6921,13 @@ S_looks_like_bool(pTHX_ const OP *o)
            return looks_like_bool(cLOGOPo->op_first);
 
        case OP_AND:
+        {
+            OP* sibl = OP_SIBLING(cLOGOPo->op_first);
+            ASSUME(sibl);
            return (
                looks_like_bool(cLOGOPo->op_first)
-            && looks_like_bool(OP_SIBLING(cLOGOPo->op_first)));
+            && looks_like_bool(sibl));
+        }
 
        case OP_NULL:
        case OP_SCALAR:
@@ -8379,7 +8493,7 @@ Perl_ck_backtick(pTHX_ OP *o)
     if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
      && (gv = gv_override("readpipe",8)))
     {
-        /* detach rest of silbings from o and its first child */
+        /* detach rest of siblings from o and its first child */
         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
        newop = S_new_entersubop(aTHX_ gv, sibl);
     }
@@ -9278,7 +9392,7 @@ Perl_ck_listiob(pTHX_ OP *o)
 
     kid = cLISTOPo->op_first;
     if (!kid) {
-       o = force_list(o);
+       o = force_list(o, 1);
        kid = cLISTOPo->op_first;
     }
     if (kid->op_type == OP_PUSHMARK)
@@ -9404,7 +9518,11 @@ Perl_ck_sassign(pTHX_ OP *o)
               assignment binop->op_last = OP_SIBLING(binop->op_first); at the
               end of Perl_newBINOP(). So need to do it here. */
            cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
-
+            cBINOPo->op_first->op_lastsib = 0;
+            cBINOPo->op_last ->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+            cBINOPo->op_last->op_sibling = o;
+#endif
            return nullop;
        }
     }
@@ -9497,9 +9615,11 @@ Perl_ck_repeat(pTHX_ OP *o)
     PERL_ARGS_ASSERT_CK_REPEAT;
 
     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
+        OP* kids;
        o->op_private |= OPpREPEAT_DOLIST;
-        /* promote the siblings to a list if they're not already */
-        op_sibling_splice(o, NULL, -1, force_list(cBINOPo->op_first));
+        kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
+        kids = force_list(kids, 1); /* promote them to a list */
+        op_sibling_splice(o, NULL, 0, kids); /* and add back */
     }
     else
        scalar(o);
@@ -10367,7 +10487,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
        op_free(cvop);
        if (aop == cvop) aop = NULL;
 
-        /* detach remaining silbings from the first silbing, then
+        /* detach remaining siblings from the first sibling, then
          * dispose of original optree */
 
         if (aop)
@@ -11013,7 +11133,7 @@ Perl_rpeep(pTHX_ OP *o)
                ns3  = pad2->op_next;
 
                 /* we assume here that the op_next chain is the same as
-                 * the op_silbing chain */
+                 * the op_sibling chain */
                 assert(OP_SIBLING(o)    == pad1);
                 assert(OP_SIBLING(pad1) == ns2);
                 assert(OP_SIBLING(ns2)  == pad2);
@@ -11038,6 +11158,7 @@ Perl_rpeep(pTHX_ OP *o)
 
                OP_SIBLING_set(o, newop);
                OP_SIBLING_set(newop, ns3);
+                newop->op_lastsib = 0;
 
                newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 
diff --git a/op.h b/op.h
index 598e201..3b8eb17 100644 (file)
--- a/op.h
+++ b/op.h
@@ -24,7 +24,8 @@
  *                      !op_slabbed.
  *     op_savefree     on savestack via SAVEFREEOP
  *     op_folded       Result/remainder of a constant fold operation.
- *     op_spare        Two spare bits
+ *     op_lastsib      this op is is the last sibling
+ *     op_spare        One spare bit
  *     op_flags        Flags common to all operations.  See OPf_* below.
  *     op_private      Flags peculiar to a particular operation (BUT,
  *                     by default, set to the number of children until
@@ -51,7 +52,8 @@ typedef PERL_BITFIELD16 Optype;
     PERL_BITFIELD16 op_savefree:1;     \
     PERL_BITFIELD16 op_static:1;       \
     PERL_BITFIELD16 op_folded:1;       \
-    PERL_BITFIELD16 op_spare:2;                \
+    PERL_BITFIELD16 op_lastsib;                \
+    PERL_BITFIELD16 op_spare:1;                \
     U8         op_flags;               \
     U8         op_private;
 #endif
@@ -1061,9 +1063,15 @@ Sets the sibling of o to sib
 #define OP_TYPE_ISNT_AND_WASNT(o, type) \
     ( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) )
 
-#define OP_HAS_SIBLING(o)      (cBOOL((o)->op_sibling))
-#define OP_SIBLING(o)          (0 + (o)->op_sibling)
-#define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib))
+#ifdef PERL_OP_PARENT
+#  define OP_HAS_SIBLING(o)      (!cBOOL((o)->op_lastsib))
+#  define OP_SIBLING(o)          (0 + (o)->op_lastsib ? NULL : (o)->op_sibling)
+#  define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib))
+#else
+#  define OP_HAS_SIBLING(o)      (cBOOL((o)->op_sibling))
+#  define OP_SIBLING(o)          (0 + (o)->op_sibling)
+#  define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib))
+#endif
 
 #define newATTRSUB(f, o, p, a, b) Perl_newATTRSUB_x(aTHX_  f, o, p, a, b, FALSE)
 #define newSUB(f, o, p, b)     newATTRSUB((f), (o), (p), NULL, (b))
index 105e817..4fe0798 100644 (file)
@@ -1957,15 +1957,34 @@ C<op_first> field but also an C<op_last> field.  The most complex type of
 op is a C<LISTOP>, which has any number of children.  In this case, the
 first child is pointed to by C<op_first> and the last child by
 C<op_last>.  The children in between can be found by iteratively
-following the C<op_sibling> pointer from the first child to the last.
+following the C<op_sibling> pointer from the first child to the last 9but
+see below).
 
-There are also two other op types: a C<PMOP> holds a regular expression,
+There are also some other op types: a C<PMOP> holds a regular expression,
 and has no children, and a C<LOOP> may or may not have children.  If the
 C<op_children> field is non-zero, it behaves like a C<LISTOP>.  To
 complicate matters, if a C<UNOP> is actually a C<null> op after
 optimization (see L</Compile pass 2: context propagation>) it will still
 have children in accordance with its former type.
 
+Finally, there is a C<LOGOP>, or logic op. Like a C<LISTOP>, this has one
+or more children, but it doesn't have an C<op_last> field: so you have to
+follow C<op_first> and then the C<op_sibling> chain itself to find the
+last child. Instead it has an C<op_other> field, which is comparable to
+the C<op_next> field described below, and represents an alternate
+execution path. Operators like C<and>, C<or> and C<?> are C<LOGOP>s. Note
+that in general, C<op_other> may not point to any of the direct children
+of the C<LOGOP>.
+
+Starting in version 5.21.2, perls built with the experimental
+define C<-DPERL_OP_PARENT> add an extra boolean flag for each op,
+C<op_lastsib>.  When set, this indicates that this is the last op in an
+C<op_sibling> chain. This frees up the C<op_sibling> field on the last
+sibling to point back to the parent op. The macro C<OP_SIBLING(o)> wraps
+this special behaviour, and always returns NULL on the last sibling.
+With this build the C<op_parent(o)> function can be used to find the
+parent of any op.
+
 Another way to examine the tree is to use a compiler back-end module, such
 as L<B::Concise>.
 
index b25905d..7d098b7 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3035,14 +3035,17 @@ PP(pp_goto) /* also pp_dump */
                break;
            }
            if (gotoprobe) {
+                OP *sibl1, *sibl2;
+
                retop = dofindlabel(gotoprobe, label, label_len, label_flags,
                                    enterops, enterops + GOTO_DEPTH);
                if (retop)
                    break;
-               if (OP_HAS_SIBLING(gotoprobe) &&
-                       OP_SIBLING(gotoprobe)->op_type == OP_UNSTACK &&
-                       OP_HAS_SIBLING(OP_SIBLING(gotoprobe))) {
-                   retop = dofindlabel(OP_SIBLING(OP_SIBLING(gotoprobe)),
+               if ( (sibl1 = OP_SIBLING(gotoprobe)) &&
+                    sibl1->op_type == OP_UNSTACK &&
+                    (sibl2 = OP_SIBLING(sibl1)))
+                {
+                   retop = dofindlabel(sibl2,
                                        label, label_len, label_flags, enterops,
                                        enterops + GOTO_DEPTH);
                    if (retop)
diff --git a/proto.h b/proto.h
index de11c62..6e343c3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3121,6 +3121,11 @@ PERL_CALLCONV void       Perl_op_null(pTHX_ OP* o)
 #define PERL_ARGS_ASSERT_OP_NULL       \
        assert(o)
 
+PERL_CALLCONV OP*      Perl_op_parent(pTHX_ OP *o)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_PARENT     \
+       assert(o)
+
 PERL_CALLCONV OP*      Perl_op_prepend_elem(pTHX_ I32 optype, OP* first, OP* last);
 PERL_CALLCONV void     Perl_op_refcnt_lock(pTHX);
 PERL_CALLCONV void     Perl_op_refcnt_unlock(pTHX);
@@ -6128,7 +6133,7 @@ STATIC OP*        S_fold_constants(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_FOLD_CONSTANTS        \
        assert(o)
 
-STATIC OP*     S_force_list(pTHX_ OP* arg);
+STATIC OP*     S_force_list(pTHX_ OP* arg, bool nullit);
 STATIC void    S_forget_pmop(pTHX_ PMOP *const o)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_FORGET_PMOP   \