Factor the "is this an in-place array operator construct" logic into a new is_inplace...

diff --git a/embed.fnc b/embed.fnc
index ae69dc0..1a15d5a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -508,6 +508,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) || defined(PERL_DECL_PROT)
 s      |OP*    |opt_scalarhv   |NN OP* rep_op
+s      |OP*    |is_inplace_av  |NN OP* o|NULLOK OP* oright
 #endif
 Ap     |void   |leave_scope    |I32 base
 : Used in pp_ctl.c, and by Data::Alias

diff --git a/embed.h b/embed.h
index 95c93f4..3e9e702 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -398,6 +398,7 @@
 #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define opt_scalarhv           S_opt_scalarhv
+#define is_inplace_av          S_is_inplace_av
 #endif
 #endif
 #define leave_scope            Perl_leave_scope
@@ -2770,6 +2771,7 @@
 #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define opt_scalarhv(a)                S_opt_scalarhv(aTHX_ a)
+#define is_inplace_av(a,b)     S_is_inplace_av(aTHX_ a,b)
 #endif
 #endif
 #define leave_scope(a)         Perl_leave_scope(aTHX_ a)

diff --git a/op.c b/op.c
index bd783d7..e870a57 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8352,6 +8352,78 @@ 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. */
+
+OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+    OP *o2;
+    OP *oleft = NULL;
+
+    PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+    if (!oright ||
+       (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+       || oright->op_next != o
+       || (oright->op_private & OPpLVAL_INTRO)
+    )
+       return NULL;
+
+    /* 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;
+
+    /* 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) {
+       if (oright->op_type != OP_RV2AV
+           || !cUNOPx(oright)->op_first
+           || cUNOPx(oright)->op_first->op_type != OP_GV
+           || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+              cGVOPx_gv(cUNOPx(oright)->op_first)
+       )
+           return NULL;
+    }
+    else if (oright->op_type != OP_PADAV
+       || oright->op_targ != oleft->op_targ
+    )
+       return NULL;
+
+    return oleft;
+}
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -8792,62 +8864,8 @@ Perl_peep(pTHX_ register OP *o)
                oright = cUNOPx(oright)->op_sibling;
            }
 
-           if (!oright ||
-               (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
-               || oright->op_next != o
-               || (oright->op_private & OPpLVAL_INTRO)
-           )
-               break;
-
-           /* 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)
-               break;
-           o2 = o2->op_next;
-           if (!o2 || o2->op_type != OP_PUSHMARK)
-               break;
-           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)
-           )
-               break;
-           oleft = o2;
-           o2 = o2->op_next;
-           if (!o2 || o2->op_type != OP_NULL)
-               break;
-           o2 = o2->op_next;
-           if (!o2 || o2->op_type != OP_AASSIGN
-                   || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
-               break;
-
-           /* check that the sort is the first arg on RHS of assign */
-
-           o2 = cUNOPx(o2)->op_first;
-           if (!o2 || o2->op_type != OP_NULL)
-               break;
-           o2 = cUNOPx(o2)->op_first;
-           if (!o2 || o2->op_type != OP_PUSHMARK)
-               break;
-           if (o2->op_sibling != o)
-               break;
-
-           /* check the array is the same on both sides */
-           if (oleft->op_type == OP_RV2AV) {
-               if (oright->op_type != OP_RV2AV
-                   || !cUNOPx(oright)->op_first
-                   || cUNOPx(oright)->op_first->op_type != OP_GV
-                   ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
-                       cGVOPx_gv(cUNOPx(oright)->op_first)
-               )
-                   break;
-           }
-           else if (oright->op_type != OP_PADAV
-               || oright->op_targ != oleft->op_targ
-           )
+           oleft = is_inplace_av(o, oright);
+           if (!oleft)
                break;
 
            /* transfer MODishness etc from LHS arg to RHS arg */

diff --git a/proto.h b/proto.h
index 3aa6ca3..5d326b5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1431,6 +1431,11 @@ STATIC OP*       S_opt_scalarhv(pTHX_ OP* rep_op)
 #define PERL_ARGS_ASSERT_OPT_SCALARHV  \
        assert(rep_op)
 
+STATIC OP*     S_is_inplace_av(pTHX_ OP* o, OP* oright)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_INPLACE_AV \
+       assert(o)
+
 #endif
 PERL_CALLCONV void     Perl_leave_scope(pTHX_ I32 base);
 PERL_CALLCONV void     Perl_lex_end(pTHX);