In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3f1bc7ae553dca8fd596b8ce750fb3e637392369?hp=ba7f043cd8beaaa711b275c2a15eb10e1f9ab7f8>
- Log ----------------------------------------------------------------- commit 3f1bc7ae553dca8fd596b8ce750fb3e637392369 Merge: ba7f043 532ecd0 Author: David Mitchell <[email protected]> Date: Sun Apr 19 19:24:03 2015 +0100 [MERGE] update PERL_OP_PARENT implementation * op_sibling renamed op_sibparent on PERL_OP_PARENT builds * renamed op_lastsib to op_moresib * Perl_op_parent() now only available on PERL_OP_PARENT builds * OpSIBLING_set removed * OpMORESIB_set OpLASTSIB_set OpMAYBESIB_set added * op_sibling_splice() accepts a NULL parent arg See the thread starting http://nntp.perl.org/group/perl.perl5.porters/226862 commit 532ecd00c0b90a1490d2fe332aab770d0ae8d5fb Author: David Mitchell <[email protected]> Date: Sun Apr 19 19:21:48 2015 +0100 perldelta for PERL_OP_PARENT changes M pod/perldelta.pod commit 5e24af7dc1ab912b3a8f822d37f232e8ef19779d Author: David Mitchell <[email protected]> Date: Fri Apr 17 23:59:46 2015 +0100 add Op(MORE|LAST|MAYBE)SIB_set; rm OpSIBLING_set the OpSIBLING_set() macro just set the op_sibling/op_sibparent field, and didn't update op_moresib. Remove this macro, and replace it with the three macros OpMORESIB_set OpLASTSIB_set OpMAYBESIB_set which also set op_moresib appropriately. These were suggested by Zefram. Then in the remaining areas in op.c where low-level op_sibling/op_moresib tweaking is done, use the new macros instead (so if nothing else, they get used and tested.) M op.c M op.h commit 1fafe688be3ff13b81d5e18b2a8766dd719ee8eb Author: David Mitchell <[email protected]> Date: Fri Apr 17 20:38:49 2015 +0100 op_parent(): only exist under -DPERL_OP_PARENT Make the function Perl_op_parent() only be present in perls built with -DPERL_OP_PARENT. Previously the function was present in all builds, but always returned NULL on non PERL_OP_PARENT builds. M embed.fnc M embed.h M ext/B/B.xs M ext/B/t/b.t M makedef.pl M op.c M proto.h commit e7c18dde420590ee76509d2187610a43444ad069 Author: David Mitchell <[email protected]> Date: Fri Apr 17 20:12:54 2015 +0100 rpeep(): use op_sibling_splice() There is an optimisation in rpeep() to convert the optree produced by 'my $x; my $x' into the optree that would have been produced by 'my ($x, $y)', which allows a padrange optimisation to kick in a bit later. Currently the optree is morphed at this point by directly using OpSIBLING_set() etc. This commit makes it use op_sibling_splice() instead. We can do this following on from the previous commit, which allows op_sibling_splice() to be used when we don't know the parent, as long as we are only splicing in the middle of the children, not at either end. As well as being cleaner, it also serves as a test for the new feature of op_sibling_splice(). M op.c commit 3269ea419f8371979acd66adb243694f4bf710e1 Author: David Mitchell <[email protected]> Date: Fri Apr 17 17:50:36 2015 +0100 op_sibling_splice(): allow NULL parent arg If the splicing doesn't affect the first or last sibling of an op_sibling chain, then we don't need access to the parent op of the siblings (to access/update op_first, op_last, OPf_KIDS etc). So allow an NULL parent arg in that case. M embed.fnc M op.c M proto.h commit 87b5a8b9c803ae59e56e2a94a73f566e632038ad Author: David Mitchell <[email protected]> Date: Fri Apr 17 16:52:20 2015 +0100 rename op_lastsib to op_moresib, and invert logic Rather than having a flag which indicates that there are no more siblings, have a flag which indicates that there are more siblings. This flag was only introduced during the current blead cycle, so no production releases know about it. M dump.c M ext/B/B.pm M ext/B/B.xs M ext/B/t/b.t M ext/Devel-Peek/t/Peek.t M op.c M op.h M pod/perlguts.pod commit 86cd3a13b6713cc9d8406c9316fe126788e2497f Author: David Mitchell <[email protected]> Date: Fri Apr 17 15:15:57 2015 +0100 op_sibling => op_sibparent under PERL_OP_PARENT On perls built under -DPERL_OP_PARENT, rename the op_sibling OP field to op_sibparent, since it can now contain either a pointer to the next sibling if not the last sibling, or back to the parent if it is. Code written to work under PERL_OP_PARENT should be using macros like OpSIBLING() rather than accessing op_sibling directly, so this should be a transparent change. It will also make code naughtily accessing this field directly give a compile error. M ext/XS-APItest/APItest.xs M op.c M op.h M pod/perlguts.pod M pod/perlhacktips.pod commit 93059c1aaf5fd5adc05efe29bdcc6c719aef3108 Author: David Mitchell <[email protected]> Date: Wed Apr 15 16:05:05 2015 +0100 skip some asserts on non-PERL_OP_PARENT builds Some asserts I added for for the op_lastsib stuff, while correct on non-PERL_OP_PARENT builds, aren't necessary, and just increase the risk of breakage of some hypothetical CPAN module that is doing strange things. M op.c ----------------------------------------------------------------------- Summary of changes: dump.c | 2 +- embed.fnc | 4 +- embed.h | 4 +- ext/B/B.pm | 2 +- ext/B/B.xs | 12 ++-- ext/B/t/b.t | 6 +- ext/Devel-Peek/t/Peek.t | 16 ++--- ext/XS-APItest/APItest.xs | 2 +- makedef.pl | 7 ++ op.c | 176 ++++++++++++++++++++-------------------------- op.h | 52 +++++++++++--- pod/perldelta.pod | 54 ++++++++++++-- pod/perlguts.pod | 20 +++--- pod/perlhacktips.pod | 2 +- proto.h | 18 +++-- 15 files changed, 224 insertions(+), 153 deletions(-) diff --git a/dump.c b/dump.c index 52d897f..802dddf 100644 --- a/dump.c +++ b/dump.c @@ -844,7 +844,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 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"); + if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB"); Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); } diff --git a/embed.fnc b/embed.fnc index c0f28a4..fc9f3f3 100644 --- a/embed.fnc +++ b/embed.fnc @@ -781,9 +781,11 @@ Apd |void |op_null |NN OP* o EXp |void |op_clear |NN OP* o Ap |void |op_refcnt_lock Ap |void |op_refcnt_unlock -Apdn |OP* |op_sibling_splice|NN OP *parent|NULLOK OP *start \ +Apdn |OP* |op_sibling_splice|NULLOK OP *parent|NULLOK OP *start \ |int del_count|NULLOK OP* insert +#ifdef PERL_OP_PARENT Apdn |OP* |op_parent|NN OP *o +#endif #if defined(PERL_IN_OP_C) s |OP* |listkids |NULLOK OP* o #endif diff --git a/embed.h b/embed.h index 4d9ca18..687819c 100644 --- a/embed.h +++ b/embed.h @@ -433,7 +433,6 @@ #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 Perl_op_parent #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) @@ -825,6 +824,9 @@ #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) #define _get_regclass_nonbitmap_data(a,b,c,d,e,f) Perl__get_regclass_nonbitmap_data(aTHX_ a,b,c,d,e,f) #endif +#if defined(PERL_OP_PARENT) +#define op_parent Perl_op_parent +#endif #if defined(UNLINK_ALL_VERSIONS) #define unlnk(a) Perl_unlnk(aTHX_ a) #endif diff --git a/ext/B/B.pm b/ext/B/B.pm index e8c45ee..0a7727c 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.57'; + $B::VERSION = '1.58'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index b9885c3..016e030 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -760,7 +760,7 @@ const 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("moresib"), op_offset_special, 0, },/*51*/ { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/ # endif #endif @@ -1060,7 +1060,7 @@ next(o) B::OP::savefree = 48 B::OP::static = 49 B::OP::folded = 50 - B::OP::lastsib = 51 + B::OP::moresib = 51 B::OP::parent = 52 B::METHOP::first = 53 B::METHOP::meth_sv = 54 @@ -1146,7 +1146,7 @@ next(o) case 49: /* B::OP::static */ #if PERL_VERSION >= 19 case 50: /* B::OP::folded */ - case 51: /* B::OP::lastsib */ + case 51: /* B::OP::moresib */ #endif #endif /* These are all bitfields, so we can't take their addresses */ @@ -1157,7 +1157,7 @@ next(o) : ix == 48 ? o->op_savefree : ix == 49 ? o->op_static : ix == 50 ? o->op_folded - : ix == 51 ? o->op_lastsib + : ix == 51 ? o->op_moresib : o->op_spare))); break; case 33: /* B::LISTOP::children */ @@ -1260,7 +1260,11 @@ next(o) PTR2IV(CopHINTHASH_get(cCOPo))); break; case 52: /* B::OP::parent */ +#ifdef PERL_OP_PARENT ret = make_op_object(aTHX_ op_parent(o)); +#else + ret = make_op_object(aTHX_ NULL); +#endif break; case 53: /* B::METHOP::first */ /* METHOP struct has an op_first/op_meth_sv union diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 76b7089..1420f91 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -474,7 +474,7 @@ EOS # test op_parent SKIP: { - unless ($Config::Config{ccflags} =~ /PERL_OP_PARENT/) { + unless ($B::OP::does_parent) { skip "op_parent only present with -DPERL_OP_PARENT builds", 6; } my $lineseq = B::svref_2object(sub{my $x = 1})->ROOT->first; @@ -483,8 +483,8 @@ SKIP: { 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($first->moresib, 1 , 'op_parent: first sibling: moresib'); + is($second->moresib, 0, 'op_parent: second sibling: !moresib'); is($$lineseq, ${$first->parent}, 'op_parent: first sibling okay'); is($$lineseq, ${$second->parent}, 'op_parent: second sibling okay'); } diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index e35930b..56522af 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1489,40 +1489,40 @@ dumpindent is 4 at -e line 1. { 1 TYPE = leave ===> NULL TARG = 1 - FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB) + FLAGS = (VOID,KIDS,PARENS,SLABBED) PRIVATE = (REFC) REFCNT = 1 { 2 TYPE = enter ===> 3 - FLAGS = (UNKNOWN,SLABBED) + FLAGS = (UNKNOWN,SLABBED,MORESIB) } { 3 TYPE = nextstate ===> 4 - FLAGS = (VOID,SLABBED) + FLAGS = (VOID,SLABBED,MORESIB) LINE = 1 PACKAGE = "t" } { 5 TYPE = entersub ===> 1 TARG = 1 - FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB) + FLAGS = (VOID,KIDS,STACKED,SLABBED) PRIVATE = (TARG) { 6 TYPE = null ===> (5) (was list) - FLAGS = (UNKNOWN,KIDS,SLABBED,LASTSIB) + FLAGS = (UNKNOWN,KIDS,SLABBED) { 4 TYPE = pushmark ===> 7 - FLAGS = (SCALAR,SLABBED) + FLAGS = (SCALAR,SLABBED,MORESIB) } { 8 TYPE = null ===> (6) (was rv2cv) - FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB) + FLAGS = (SCALAR,KIDS,SLABBED) PRIVATE = (0x1) { 7 TYPE = gv ===> 5 - FLAGS = (SCALAR,SLABBED,LASTSIB) + FLAGS = (SCALAR,SLABBED) GV_OR_PADIX } } diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 6171e9b..c78dc7b 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3677,7 +3677,7 @@ CODE: CvROOT(PL_compcv) = (OP *)1; o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0); #ifdef PERL_OP_PARENT - if (cLOOPx(cUNOPo->op_first)->op_last->op_sibling + if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent != cUNOPo->op_first) { Perl_warn(aTHX_ "Op parent pointer is stale"); diff --git a/makedef.pl b/makedef.pl index b31d8a0..8a57083 100644 --- a/makedef.pl +++ b/makedef.pl @@ -421,6 +421,13 @@ unless ($define{'PERL_IMPLICIT_CONTEXT'}) { Perl_my_cxt_index ); } + +unless ($define{'PERL_OP_PARENT'}) { + ++$skip{$_} foreach qw( + Perl_op_parent + ); +} + if ($define{'NO_MATHOMS'}) { # win32 builds happen in the win32/ subdirectory, but vms builds happen # at the top level, so we need to look in two candidate locations for diff --git a/op.c b/op.c index c136a1a..4e8f5a4 100644 --- a/op.c +++ b/op.c @@ -297,9 +297,11 @@ Perl_Slab_Alloc(pTHX_ size_t sz) 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); +#ifdef PERL_OP_PARENT + /* moresib == 0, op_sibling == 0 implies a solitary unattached op */ + assert(!o->op_moresib); + assert(!o->op_sibparent); +#endif return (void *)o; } @@ -1214,13 +1216,14 @@ 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_sibling manipulation on the children. The last deleted node will be marked as as the last node by -updating the op_sibling or op_lastsib field as appropriate. +updating the op_sibling/op_sibparent or op_moresib field as appropriate. Note that op_next is not manipulated, and nodes are not freed; that is the responsibility of the caller. It also won't create a new list op for an empty list etc; use higher-level functions like op_append_elem() for that. -parent is the parent node of the sibling chain. +parent is the parent node of the sibling chain. It may passed as NULL if +the splicing doesn't affect the first or last op in the chain. start is the node preceding the first node to be spliced. Node(s) following it will be deleted, and ops will be inserted after it. If it is @@ -1258,18 +1261,27 @@ For example: splice(P, B, 0, X-Y) | | NULL A-B-C-D A-B-X-Y-C-D + +For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>, +see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>. + =cut */ OP * Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) { - OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first; + OP *first; OP *rest; OP *last_del = NULL; OP *last_ins = NULL; - PERL_ARGS_ASSERT_OP_SIBLING_SPLICE; + if (start) + first = OpSIBLING(start); + else if (!parent) + goto no_parent; + else + first = cLISTOPx(parent)->op_first; assert(del_count >= -1); @@ -1278,8 +1290,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) while (--del_count && OpHAS_SIBLING(last_del)) last_del = OpSIBLING(last_del); rest = OpSIBLING(last_del); - OpSIBLING_set(last_del, NULL); - last_del->op_lastsib = 1; + OpLASTSIB_set(last_del, NULL); } else rest = first; @@ -1288,17 +1299,17 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) last_ins = insert; while (OpHAS_SIBLING(last_ins)) last_ins = OpSIBLING(last_ins); - OpSIBLING_set(last_ins, rest); - last_ins->op_lastsib = rest ? 0 : 1; + OpMAYBESIB_set(last_ins, rest, NULL); } else insert = rest; if (start) { - OpSIBLING_set(start, insert); - start->op_lastsib = insert ? 0 : 1; + OpMAYBESIB_set(start, insert, NULL); } else { + if (!parent) + goto no_parent; cLISTOPx(parent)->op_first = insert; if (insert) parent->op_flags |= OPf_KIDS; @@ -1308,9 +1319,13 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) if (!rest) { /* update op_last etc */ - U32 type = parent->op_type; + U32 type; OP *lastop; + if (!parent) + goto no_parent; + + type = parent->op_type; if (type == OP_NULL) type = parent->op_targ; type = PL_opargs[type] & OA_CLASS_MASK; @@ -1323,22 +1338,23 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) ) cLISTOPx(parent)->op_last = lastop; - if (lastop) { - lastop->op_lastsib = 1; -#ifdef PERL_OP_PARENT - lastop->op_sibling = parent; -#endif - } + if (lastop) + OpLASTSIB_set(lastop, parent); } return last_del ? first : NULL; + + no_parent: + Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent"); } + +#ifdef PERL_OP_PARENT + /* =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. +Returns the parent OP of o, if it has a parent. Returns NULL otherwise. +This function is only available on perls built with C<-DPERL_OP_PARENT>. =cut */ @@ -1347,16 +1363,13 @@ OP * Perl_op_parent(OP *o) { PERL_ARGS_ASSERT_OP_PARENT; -#ifdef PERL_OP_PARENT while (OpHAS_SIBLING(o)) o = OpSIBLING(o); - return o->op_sibling; -#else - PERL_UNUSED_ARG(o); - return NULL; -#endif + return o->op_sibparent; } +#endif + /* replace the sibling following start with a new UNOP, which becomes * the parent of the original sibling; e.g. @@ -1408,12 +1421,8 @@ S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) logop->op_flags = OPf_KIDS; while (kid && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); - if (kid) { - kid->op_lastsib = 1; -#ifdef PERL_OP_PARENT - kid->op_sibling = (OP*)logop; -#endif - } + if (kid) + OpLASTSIB_set(kid, (OP*)logop); return logop; } @@ -2510,9 +2519,9 @@ S_finalize_op(pTHX_ OP* o) #ifdef DEBUGGING /* check that op_last points to the last sibling, and that - * the last op_sibling field points back to the parent, and - * that the only ops with KIDS are those which are entitled to - * them */ + * the last op_sibling/op_sibparent field points back to the + * parent, and that the only ops with KIDS are those which are + * entitled to them */ U32 type = o->op_type; U32 family; bool has_last; @@ -2551,17 +2560,11 @@ S_finalize_op(pTHX_ OP* o) if (!OpHAS_SIBLING(kid)) { if (has_last) assert(kid == cLISTOPo->op_last); - assert(kid->op_sibling == o); + assert(kid->op_sibparent == o); } # else - if (OpHAS_SIBLING(kid)) { - assert(!kid->op_lastsib); - } - else { - assert(kid->op_lastsib); - if (has_last) - assert(kid == cLISTOPo->op_last); - } + if (has_last && !OpHAS_SIBLING(kid)) + assert(kid == cLISTOPo->op_last); # endif } #endif @@ -4502,16 +4505,11 @@ 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; - OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); + OpMORESIB_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 + OpLASTSIB_set(((LISTOP*)first)->op_last, first); first->op_flags |= (last->op_flags & OPf_KIDS); - S_op_destroy(aTHX_ last); return first; @@ -4645,8 +4643,7 @@ S_force_list(pTHX_ OP *o, bool nullit) if (o) { /* manually detach any siblings then add them back later */ rest = OpSIBLING(o); - OpSIBLING_set(o, NULL); - o->op_lastsib = 1; + OpLASTSIB_set(o, NULL); } o = newLISTOP(OP_LIST, 0, o, NULL); if (rest) @@ -4697,26 +4694,19 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - OpSIBLING_set(first, last); + OpMORESIB_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); - pushop->op_lastsib = 0; - OpSIBLING_set(pushop, first); + OpMORESIB_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 - } + if (listop->op_last) + OpLASTSIB_set(listop->op_last, (OP*)listop); return CHECKOP(type, listop); } @@ -4806,10 +4796,8 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */ - first->op_sibling = (OP*)unop; -#endif + OpLASTSIB_set(first, (OP*)unop); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) @@ -4844,10 +4832,8 @@ Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8)); unop->op_aux = aux; -#ifdef PERL_OP_PARENT if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */ - first->op_sibling = (OP*)unop; -#endif + OpLASTSIB_set(first, (OP*)unop); unop = (UNOP_AUX*) CHECKOP(type, unop); @@ -4884,10 +4870,8 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth methop->op_u.op_first = dynamic_meth; methop->op_private = (U8)(1 | (flags >> 8)); -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(dynamic_meth)) - dynamic_meth->op_sibling = (OP*)methop; -#endif + OpLASTSIB_set(dynamic_meth, (OP*)methop); } else { assert(const_meth); @@ -4969,20 +4953,15 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - OpSIBLING_set(first, last); - first->op_lastsib = 0; + OpMORESIB_set(first, last); } -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */ - last->op_sibling = (OP*)binop; -#endif + OpLASTSIB_set(last, (OP*)binop); binop->op_last = OpSIBLING(binop->op_first); -#ifdef PERL_OP_PARENT if (binop->op_last) - binop->op_last->op_sibling = (OP*)binop; -#endif + OpLASTSIB_set(binop->op_last, (OP*)binop); binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) @@ -7520,8 +7499,8 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) 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 */ + assert(loop->op_last->op_sibparent == (OP*)loop); + OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */ #endif S_op_destroy(aTHX_ (OP*)loop); loop = tmp; @@ -7530,7 +7509,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) { loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); #ifdef PERL_OP_PARENT - loop->op_last->op_sibling = (OP *)loop; + OpLASTSIB_set(loop->op_last, (OP*)loop); #endif } loop->op_targ = padoff; @@ -13151,32 +13130,33 @@ Perl_rpeep(pTHX_ OP *o) assert(OpSIBLING(ns2) == pad2); assert(OpSIBLING(pad2) == ns3); + /* excise and delete ns2 */ + op_sibling_splice(NULL, pad1, 1, NULL); + op_free(ns2); + + /* excise pad1 and pad2 */ + op_sibling_splice(NULL, o, 2, NULL); + /* create new listop, with children consisting of: * a new pushmark, pad1, pad2. */ - OpSIBLING_set(pad2, NULL); newop = newLISTOP(OP_LIST, 0, pad1, pad2); newop->op_flags |= OPf_PARENS; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - newpm = cUNOPx(newop)->op_first; /* pushmark */ - /* Kill nextstate2 between padop1/padop2 */ - op_free(ns2); + /* insert newop between o and ns3 */ + op_sibling_splice(NULL, o, 0, newop); + /*fixup op_next chain */ + newpm = cUNOPx(newop)->op_first; /* pushmark */ o ->op_next = newpm; newpm->op_next = pad1; pad1 ->op_next = pad2; pad2 ->op_next = newop; /* listop */ newop->op_next = ns3; - OpSIBLING_set(o, newop); - OpSIBLING_set(newop, ns3); - newop->op_lastsib = 0; - - newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - /* Ensure pushmark has this flag if padops do */ if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { - o->op_next->op_flags |= OPf_MOD; + newpm->op_flags |= OPf_MOD; } break; diff --git a/op.h b/op.h index 9e6bb43..ed3e9a1 100644 --- a/op.h +++ b/op.h @@ -24,7 +24,7 @@ * !op_slabbed. * op_savefree on savestack via SAVEFREEOP * op_folded Result/remainder of a constant fold operation. - * op_lastsib this op is is the last sibling + * op_moresib this op is is not 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, @@ -38,12 +38,21 @@ typedef PERL_BITFIELD16 Optype; +/* this field now either points to the next sibling or to the parent, + * depending on op_moresib. So rename it from op_sibling to op_sibparent. + */ +#ifdef PERL_OP_PARENT +# define _OP_SIBPARENT_FIELDNAME op_sibparent +#else +# define _OP_SIBPARENT_FIELDNAME op_sibling +#endif + #ifdef BASEOP_DEFINITION #define BASEOP BASEOP_DEFINITION #else #define BASEOP \ OP* op_next; \ - OP* op_sibling; \ + OP* _OP_SIBPARENT_FIELDNAME;\ OP* (*op_ppaddr)(pTHX); \ PADOFFSET op_targ; \ PERL_BITFIELD16 op_type:9; \ @@ -52,7 +61,7 @@ typedef PERL_BITFIELD16 Optype; PERL_BITFIELD16 op_savefree:1; \ PERL_BITFIELD16 op_static:1; \ PERL_BITFIELD16 op_folded:1; \ - PERL_BITFIELD16 op_lastsib:1; \ + PERL_BITFIELD16 op_moresib:1; \ PERL_BITFIELD16 op_spare:1; \ U8 op_flags; \ U8 op_private; @@ -929,11 +938,23 @@ the NULL pointer check. =for apidoc Am|bool|OpHAS_SIBLING|OP *o Returns true if o has a sibling -=for apidoc Am|bool|OpSIBLING|OP *o +=for apidoc Am|OP*|OpSIBLING|OP *o Returns the sibling of o, or NULL if there is no sibling -=for apidoc Am|bool|OpSIBLING_set|OP *o|OP *sib -Sets the sibling of o to sib +=for apidoc Am|void|OpMORESIB_set|OP *o|OP *sib +Sets the sibling of o to the non-zero value sib. See also C<OpLASTSIB_set> +and C<OpMAYBESIB_set>. For a higher-level interface, see +C<op_sibling_splice>. + +=for apidoc Am|void|OpLASTSIB_set|OP *o|OP *parent +Marks o as having no further siblings. On C<PERL_OP_PARENT> builds, marks +o as having the specified parent. See also C<OpMORESIB_set> and +C<OpMAYBESIB_set>. For a higher-level interface, see +C<op_sibling_splice>. + +=for apidoc Am|void|OpMAYBESIB_set|OP *o|OP *sib|OP *parent +Conditionally does C<OpMORESIB_set> or C<OpLASTSIB_set> depending on whether +sib is non-null. For a higher-level interface, see C<op_sibling_splice>. =cut */ @@ -971,16 +992,27 @@ Sets the sibling of o to sib #define OP_TYPE_ISNT_AND_WASNT(o, type) \ ( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) ) + #ifdef PERL_OP_PARENT -# define OpHAS_SIBLING(o) (!cBOOL((o)->op_lastsib)) -# define OpSIBLING(o) (0 + (o)->op_lastsib ? NULL : (o)->op_sibling) -# define OpSIBLING_set(o, sib) ((o)->op_sibling = (sib)) +# define OpHAS_SIBLING(o) (cBOOL((o)->op_moresib)) +# define OpSIBLING(o) (0 + (o)->op_moresib ? (o)->op_sibparent : NULL) +# define OpMORESIB_set(o, sib) ((o)->op_moresib = 1, (o)->op_sibparent = (sib)) +# define OpLASTSIB_set(o, parent) \ + ((o)->op_moresib = 0, (o)->op_sibparent = (parent)) +# define OpMAYBESIB_set(o, sib, parent) \ + ((o)->op_sibparent = ((o)->op_moresib = cBOOL(sib)) ? (sib) : (parent)) #else # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) -# define OpSIBLING_set(o, sib) ((o)->op_sibling = (sib)) +# define OpMORESIB_set(o, sib) ((o)->op_moresib = 1, (o)->op_sibling = (sib)) +# define OpLASTSIB_set(o, parent) \ + ((o)->op_moresib = 0, (o)->op_sibling = NULL) +# define OpMAYBESIB_set(o, sib, parent) \ + ((o)->op_moresib = cBOOL(sib), (o)->op_sibling = (sib)) #endif + #if !defined(PERL_CORE) && !defined(PERL_EXT) +/* for backwards compatibility only */ # define OP_SIBLING(o) OpSIBLING(o) #endif diff --git a/pod/perldelta.pod b/pod/perldelta.pod index b700445..a391579 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -365,17 +365,61 @@ C<test-prep> again depends on C<test-prep-gcc> for GCC builds. [perl =head1 Internal Changes -XXX Changes which affect the interface available to C<XS> code go here. Other -significant internal changes for future core maintainers should be noted as -well. +=over 4 + +=item * -[ List each change as a =item entry ] +5.21.2 introduced a new build option, C<-DPERL_OP_PARENT>, which causes +the last C<op_sibling> pointer to refer back to the parent rather than +being C<NULL>, and where instead a new flag indicates the end of the +chain. In this release, the new implementation has been revised; in +particular: =over 4 =item * -XXX +On C<PERL_OP_PARENT> builds, the C<op_sibling> field has been renamed +C<op_sibparent> to reflect its new dual purpose. Since the intention is that +this field should primarily be accessed via macros, this change should be +transparent for code written to work under C<PERL_OP_PARENT>. + +=item * + +The newly-introduced C<op_lastsib> flag bit has been renamed C<op_moresib> +and its logic inverted; i.e. it is initialised to zero in a new op, and is +changed to 1 when an op gains a sibling. + +=item * + +The function C<Perl_op_parent> is now only available on C<PERL_OP_PARENT> +builds. Using it on a plain build will be a compile-timer error. + +=item * + +Three new macros, C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set> +have been added, which are intended to be be a low-level portable way to +set C<op_sibling> / C<op_sibparent> while also updating C<op_moresib>. +The first sets the sibling pointer to a new sibling, the second makes the +op the last sibling, and the third conditionally does the first or second +action. The C<op_sibling_splice()> function is retained as a higher-level +interface that can also maintain consistency in the parent at the same time +(e.g. by updating C<op_first> and C<op_last> where appropriate). + +=item * + +The macro C<OpSIBLING_set>, added in 5.21.2, has been removed. It didn't +manipulate C<op_moresib> and has been superseded by C<OpMORESIB_set> et +al. + +=item * + +The C<op_sibling_splice> function now accepts a null C<parent> argument +where the splicing doesn't affect the first or last ops in the sibling +chain, and thus where the parent doesn't need to be updated accordingly. + +=back + =back diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 5e38692..27f7540 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1980,7 +1980,7 @@ 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 (but +following the C<OpSIBLING> pointer from the first child to the last (but see below). There are also some other op types: a C<PMOP> holds a regular expression, @@ -1992,7 +1992,7 @@ 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 +follow C<op_first> and then the C<OpSIBLING> 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 @@ -2001,13 +2001,15 @@ 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<OpSIBLING(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. Thus for forward compatibility, you should always use -the C<OpSIBLING(o)> macro rather than accessing C<op_sibling> directly. +C<op_moresib>. When not set, this indicates that this is the last op in an +C<OpSIBLING> chain. This frees up the C<op_sibling> field on the last +sibling to point back to the parent op. Under this build, that field is +also renamed C<op_sibparent> to reflect its joint role. The macro +C<OpSIBLING(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. Thus for forward compatibility, you +should always use the C<OpSIBLING(o)> macro rather than accessing +C<op_sibling> directly. Another way to examine the tree is to use a compiler back-end module, such as L<B::Concise>. diff --git a/pod/perlhacktips.pod b/pod/perlhacktips.pod index 834c8c8..6d7a098 100644 --- a/pod/perlhacktips.pod +++ b/pod/perlhacktips.pod @@ -803,7 +803,7 @@ Prints the C definition of the argument given. (gdb) ptype PL_op type = struct op { OP *op_next; - OP *op_sibling; + OP *op_sibparent; OP *(*op_ppaddr)(void); PADOFFSET op_targ; unsigned int op_type : 9; diff --git a/proto.h b/proto.h index 53f6270..0cfb696 100644 --- a/proto.h +++ b/proto.h @@ -3270,20 +3270,11 @@ PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) #define PERL_ARGS_ASSERT_OP_NULL \ assert(o) -PERL_CALLCONV OP* Perl_op_parent(OP *o) - __attribute__nonnull__(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); PERL_CALLCONV OP* Perl_op_scope(pTHX_ OP* o); -PERL_CALLCONV OP* Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) - __attribute__nonnull__(1); -#define PERL_ARGS_ASSERT_OP_SIBLING_SPLICE \ - assert(parent) - +PERL_CALLCONV OP* Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert); PERL_CALLCONV OP* Perl_op_unscope(pTHX_ OP* o); PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) __attribute__nonnull__(pTHX_1) @@ -8037,6 +8028,13 @@ STATIC void S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesiz # endif #endif +#if defined(PERL_OP_PARENT) +PERL_CALLCONV OP* Perl_op_parent(OP *o) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_OP_PARENT \ + assert(o) + +#endif #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) STATIC void S_pidgone(pTHX_ Pid_t pid, int status); #endif -- Perl5 Master Repository
