diff options
| -rw-r--r-- | dump.c | 1 | ||||
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 3 | ||||
| -rw-r--r-- | ext/B/B.pm | 5 | ||||
| -rw-r--r-- | ext/B/B.xs | 9 | ||||
| -rw-r--r-- | ext/B/t/b.t | 19 | ||||
| -rw-r--r-- | ext/Devel-Peek/Peek.xs | 3 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 10 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 18 | ||||
| -rw-r--r-- | op.c | 221 | ||||
| -rw-r--r-- | op.h | 18 | ||||
| -rw-r--r-- | pod/perlguts.pod | 23 | ||||
| -rw-r--r-- | pp_ctl.c | 11 | ||||
| -rw-r--r-- | proto.h | 7 |
14 files changed, 268 insertions, 83 deletions
@@ -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 : ""); \ } @@ -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 @@ -414,6 +414,7 @@ #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) @@ -1488,7 +1489,7 @@ #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) diff --git a/ext/B/B.pm b/ext/B/B.pm index 0f0b584b88..c908f511f4 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -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"). diff --git a/ext/B/B.xs b/ext/B/B.xs index 871d07a5ad..a130ad3cb4 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -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 { diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 1fee139303..27b41054aa 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -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(); diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs index b8a18d65a3..49dbea3216 100644 --- a/ext/Devel-Peek/Peek.xs +++ b/ext/Devel-Peek/Peek.xs @@ -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; } diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 425268a7f8..0cc6717d99 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -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 } } diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 6cd3156f39..54ee2dad42 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -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; } @@ -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; @@ -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)) diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 105e8171d2..4fe07983da 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -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>. @@ -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) @@ -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 \ |