From e92f843df4fffff9b210a84828d09e0af4499cd2 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Wed, 24 Aug 2011 23:15:17 -0700 Subject: [PATCH] =?utf8?q?Revert=20"Test=20CORE::break=E2=80=99s=20prototy?= =?utf8?q?pe"?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit This reverts commit e52d58aa5bea245b66786b4c9029e849a2be69d3. I don’t quite know how I managed it, but I really screw up this time! Two completely unrelated commits ended up getting merged into one, so, to avoid confusion down the road, I’m reverting it, only to reapply it shortly.... --- embed.fnc | 2 +- embed.h | 2 +- op.c | 180 ++++++++++++++++++++++++++++++++++++---------------------- proto.h | 10 ++-- t/op/cproto.t | 3 +- 5 files changed, 119 insertions(+), 78 deletions(-) diff --git a/embed.fnc b/embed.fnc index 636361b..2ed8f60 100644 --- a/embed.fnc +++ b/embed.fnc @@ -623,7 +623,7 @@ p |OP* |jmaybe |NN OP *o pP |I32 |keyword |NN const char *name|I32 len|bool all_keywords #if defined(PERL_IN_OP_C) s |OP* |opt_scalarhv |NN OP* rep_op -s |void |inplace_aassign |NN OP* o +s |OP* |is_inplace_av |NN OP* o|NULLOK OP* oright #endif Ap |void |leave_scope |I32 base : Public lexer API diff --git a/embed.h b/embed.h index c20e2b4..26d1bdb 100644 --- a/embed.h +++ b/embed.h @@ -1342,8 +1342,8 @@ #define force_list(a) S_force_list(aTHX_ a) #define gen_constant_list(a) S_gen_constant_list(aTHX_ a) #define gv_ename(a) S_gv_ename(aTHX_ a) -#define inplace_aassign(a) S_inplace_aassign(aTHX_ a) #define is_handle_constructor S_is_handle_constructor +#define is_inplace_av(a,b) S_is_inplace_av(aTHX_ a,b) #define is_list_assignment(a) S_is_list_assignment(aTHX_ a) #define listkids(a) S_listkids(aTHX_ a) #define looks_like_bool(a) S_looks_like_bool(aTHX_ a) diff --git a/op.c b/op.c index d68389f..395b46b 100644 --- a/op.c +++ b/op.c @@ -1260,11 +1260,6 @@ Perl_scalarvoid(pTHX_ OP *o) break; } - case OP_AASSIGN: { - inplace_aassign(o); - break; - } - case OP_OR: case OP_AND: kid = cLOGOPo->op_first; @@ -9604,57 +9599,59 @@ S_opt_scalarhv(pTHX_ OP *rep_op) { return (OP*)unop; } -/* Check for in place reverse and sort assignments like "@a = reverse @a" - and modify the optree to make them work inplace */ - -STATIC void -S_inplace_aassign(pTHX_ OP *o) { - - OP *modop, *modop_pushmark; - OP *oright; - OP *oleft, *oleft_pushmark; - - PERL_ARGS_ASSERT_INPLACE_AASSIGN; - - assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); - - assert(cUNOPo->op_first->op_type == OP_NULL); - modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; - assert(modop_pushmark->op_type == OP_PUSHMARK); - modop = modop_pushmark->op_sibling; - - if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) - return; - - /* no other operation except sort/reverse */ - if (modop->op_sibling) - return; +/* Checks if o acts as an in-place operator on an array. oright points to the + * beginning of the right-hand side. Returns the left-hand side of the + * assignment if o acts in-place, or NULL otherwise. */ - assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - oright = cUNOPx(modop)->op_first->op_sibling; +STATIC OP * +S_is_inplace_av(pTHX_ OP *o, OP *oright) { + OP *o2; + OP *oleft = NULL; - if (modop->op_flags & OPf_STACKED) { - /* skip sort subroutine/block */ - assert(oright->op_type == OP_NULL); - oright = oright->op_sibling; - } + PERL_ARGS_ASSERT_IS_INPLACE_AV; - assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); - oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; - assert(oleft_pushmark->op_type == OP_PUSHMARK); - oleft = oleft_pushmark->op_sibling; + if (!oright || + (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) + || oright->op_next != o + || (oright->op_private & OPpLVAL_INTRO) + ) + return NULL; - /* Check the lhs is an array */ - if (!oleft || - (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || oleft->op_sibling - || (oleft->op_private & OPpLVAL_INTRO) + /* o2 follows the chain of op_nexts through the LHS of the + * assign (if any) to the aassign op itself */ + o2 = o->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + o2 = o2->op_next; + if (o2 && o2->op_type == OP_GV) + o2 = o2->op_next; + if (!o2 + || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) + || (o2->op_private & OPpLVAL_INTRO) ) - return; + return NULL; + oleft = o2; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_AASSIGN + || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) + return NULL; - /* Only one thing on the rhs */ - if (oright->op_sibling) - return; + /* check that the sort is the first arg on RHS of assign */ + + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + if (o2->op_sibling != o) + return NULL; /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { @@ -9664,26 +9661,14 @@ S_inplace_aassign(pTHX_ OP *o) { || cGVOPx_gv(cUNOPx(oleft)->op_first) != cGVOPx_gv(cUNOPx(oright)->op_first) ) - return; + return NULL; } else if (oright->op_type != OP_PADAV || oright->op_targ != oleft->op_targ ) - return; - - /* This actually is an inplace assignment */ - - modop->op_private |= OPpSORT_INPLACE; - - /* transfer MODishness etc from LHS arg to RHS arg */ - oright->op_flags = oleft->op_flags; + return NULL; - /* remove the aassign op and the lhs */ - op_null(o); - op_null(oleft_pushmark); - if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) - op_null(cUNOPx(oleft)->op_first); - op_null(oleft); + return oleft; } #define MAX_DEFERRED 4 @@ -9988,14 +9973,15 @@ Perl_rpeep(pTHX_ register OP *o) break; case OP_SORT: { + /* will point to RV2AV or PADAV op on LHS/RHS of assign */ + OP *oleft; + OP *o2; + /* check that RHS of sort is a single plain array */ OP *oright = cUNOPo->op_first; if (!oright || oright->op_type != OP_PUSHMARK) break; - if (o->op_private & OPpSORT_INPLACE) - break; - /* reverse sort ... can be optimised. */ if (!cUNOPo->op_sibling) { /* Nothing follows us on the list. */ @@ -10015,16 +10001,72 @@ Perl_rpeep(pTHX_ register OP *o) } } + /* make @a = sort @a act in-place */ + + oright = cUNOPx(oright)->op_sibling; + if (!oright) + break; + if (oright->op_type == OP_NULL) { /* skip sort block/sub */ + oright = cUNOPx(oright)->op_sibling; + } + + oleft = is_inplace_av(o, oright); + if (!oleft) + break; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + o->op_private |= OPpSORT_INPLACE; + + /* excise push->gv->rv2av->null->aassign */ + o2 = o->op_next->op_next; + op_null(o2); /* PUSHMARK */ + o2 = o2->op_next; + if (o2->op_type == OP_GV) { + op_null(o2); /* GV */ + o2 = o2->op_next; + } + op_null(o2); /* RV2AV or PADAV */ + o2 = o2->op_next->op_next; + op_null(o2); /* AASSIGN */ + + o->op_next = o2->op_next; + break; } case OP_REVERSE: { OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; + OP *oleft, *oright; LISTOP *enter, *exlist; - if (o->op_private & OPpSORT_INPLACE) + /* @a = reverse @a */ + if ((oright = cLISTOPo->op_first) + && (oright->op_type == OP_PUSHMARK) + && (oright = oright->op_sibling) + && (oleft = is_inplace_av(o, oright))) { + OP *o2; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + o->op_private |= OPpREVERSE_INPLACE; + + /* excise push->gv->rv2av->null->aassign */ + o2 = o->op_next->op_next; + op_null(o2); /* PUSHMARK */ + o2 = o2->op_next; + if (o2->op_type == OP_GV) { + op_null(o2); /* GV */ + o2 = o2->op_next; + } + op_null(o2); /* RV2AV or PADAV */ + o2 = o2->op_next->op_next; + op_null(o2); /* AASSIGN */ + + o->op_next = o2->op_next; break; + } enter = (LISTOP *) o->op_next; if (!enter) diff --git a/proto.h b/proto.h index 73a322d..7784a7a 100644 --- a/proto.h +++ b/proto.h @@ -5513,17 +5513,17 @@ STATIC const char* S_gv_ename(pTHX_ GV *gv) #define PERL_ARGS_ASSERT_GV_ENAME \ assert(gv) -STATIC void S_inplace_aassign(pTHX_ OP* o) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_INPLACE_AASSIGN \ - assert(o) - STATIC bool S_is_handle_constructor(const OP *o, I32 numargs) __attribute__warn_unused_result__ __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \ assert(o) +STATIC OP* S_is_inplace_av(pTHX_ OP* o, OP* oright) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_IS_INPLACE_AV \ + assert(o) + STATIC I32 S_is_list_assignment(pTHX_ const OP *o) __attribute__warn_unused_result__; diff --git a/t/op/cproto.t b/t/op/cproto.t index c9cfe46..2c54c0c 100644 --- a/t/op/cproto.t +++ b/t/op/cproto.t @@ -7,7 +7,7 @@ BEGIN { } BEGIN { require './test.pl'; } -plan tests => 245; +plan tests => 244; while () { chomp; @@ -41,7 +41,6 @@ atan2 ($$) bind (*$) binmode (*;$) bless ($;$) -break () caller (;$) chdir (;$) chmod (@) -- 2.7.4