From e52d58aa5bea245b66786b4c9029e849a2be69d3 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Wed, 24 Aug 2011 22:39:28 -0700 Subject: [PATCH] =?utf8?q?Test=20CORE::break=E2=80=99s=20prototype?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- embed.fnc | 2 +- embed.h | 2 +- op.c | 180 ++++++++++++++++++++++------------------------------------ proto.h | 10 ++-- t/op/cproto.t | 3 +- 5 files changed, 78 insertions(+), 119 deletions(-) diff --git a/embed.fnc b/embed.fnc index 2ed8f60..636361b 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 |OP* |is_inplace_av |NN OP* o|NULLOK OP* oright +s |void |inplace_aassign |NN OP* o #endif Ap |void |leave_scope |I32 base : Public lexer API diff --git a/embed.h b/embed.h index 26d1bdb..c20e2b4 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 395b46b..d68389f 100644 --- a/op.c +++ b/op.c @@ -1260,6 +1260,11 @@ Perl_scalarvoid(pTHX_ OP *o) break; } + case OP_AASSIGN: { + inplace_aassign(o); + break; + } + case OP_OR: case OP_AND: kid = cLOGOPo->op_first; @@ -9599,59 +9604,57 @@ S_opt_scalarhv(pTHX_ OP *rep_op) { return (OP*)unop; } -/* 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. */ +/* Check for in place reverse and sort assignments like "@a = reverse @a" + and modify the optree to make them work inplace */ -STATIC OP * -S_is_inplace_av(pTHX_ OP *o, OP *oright) { - OP *o2; - OP *oleft = NULL; +STATIC void +S_inplace_aassign(pTHX_ OP *o) { - PERL_ARGS_ASSERT_IS_INPLACE_AV; + OP *modop, *modop_pushmark; + OP *oright; + OP *oleft, *oleft_pushmark; - if (!oright || - (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) - || oright->op_next != o - || (oright->op_private & OPpLVAL_INTRO) - ) - return NULL; + PERL_ARGS_ASSERT_INPLACE_AASSIGN; - /* 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 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; + assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); - /* check that the sort is the first arg on RHS of assign */ + 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; - 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; + if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) + return; + + /* no other operation except sort/reverse */ + if (modop->op_sibling) + return; + + assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); + oright = cUNOPx(modop)->op_first->op_sibling; + + if (modop->op_flags & OPf_STACKED) { + /* skip sort subroutine/block */ + assert(oright->op_type == OP_NULL); + oright = oright->op_sibling; + } + + 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; + + /* 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) + ) + return; + + /* Only one thing on the rhs */ + if (oright->op_sibling) + return; /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { @@ -9661,14 +9664,26 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) { || cGVOPx_gv(cUNOPx(oleft)->op_first) != cGVOPx_gv(cUNOPx(oright)->op_first) ) - return NULL; + return; } else if (oright->op_type != OP_PADAV || oright->op_targ != oleft->op_targ ) - return NULL; + return; + + /* This actually is an inplace assignment */ - return oleft; + modop->op_private |= OPpSORT_INPLACE; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + + /* 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); } #define MAX_DEFERRED 4 @@ -9973,15 +9988,14 @@ 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. */ @@ -10001,72 +10015,16 @@ 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; - /* @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; + if (o->op_private & OPpSORT_INPLACE) break; - } enter = (LISTOP *) o->op_next; if (!enter) diff --git a/proto.h b/proto.h index 7784a7a..73a322d 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 2c54c0c..c9cfe46 100644 --- a/t/op/cproto.t +++ b/t/op/cproto.t @@ -7,7 +7,7 @@ BEGIN { } BEGIN { require './test.pl'; } -plan tests => 244; +plan tests => 245; while () { chomp; @@ -41,6 +41,7 @@ atan2 ($$) bind (*$) binmode (*;$) bless ($;$) +break () caller (;$) chdir (;$) chmod (@) -- 2.7.4