Move making inplace sort and reverse away from the peephole optimiser to scalarvoid.

Why: The in place assignment is not just an optimisation but has
significant different behaviour and thus doesn't belong in the
peephole optimiser.  Also the optree changes are unified and simpler.

diff --git a/embed.fnc b/embed.fnc
index 2ed8f60..636361b 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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__;