Optimize reversing an array in-place

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 671212d..2699605 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -634,6 +634,7 @@ $priv{"list"}{64} = "GUESSED";
 $priv{"delete"}{64} = "SLICE";
 $priv{"exists"}{64} = "SUB";
 @{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");
+$priv{"reverse"}{8} = "INPLACE";
 $priv{"threadsv"}{64} = "SVREFd";
 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
   for ("open", "backtick");

diff --git a/op.c b/op.c
index e870a57..58b2508 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8892,8 +8892,36 @@ Perl_peep(pTHX_ register OP *o)
        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;
+               break;
+           }
+
            enter = (LISTOP *) o->op_next;
            if (!enter)
                break;

diff --git a/op.h b/op.h
index 9608564..25b59ea 100644 (file)
--- a/op.h
+++ b/op.h
@@ -258,6 +258,9 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpSORT_QSORT          32      /* Use quicksort (not mergesort) */
 #define OPpSORT_STABLE         64      /* Use a stable algorithm */
 
+/* Private for OP_REVERSE */
+#define OPpREVERSE_INPLACE     8       /* reverse in-place (@a = reverse @a) */
+
 /* Private for OP_OPEN and OP_BACKTICK */
 #define OPpOPEN_IN_RAW         16      /* binmode(F,":raw") on input fh */
 #define OPpOPEN_IN_CRLF                32      /* binmode(F,":crlf") on input fh */

diff --git a/pod/perl5112delta.pod b/pod/perl5112delta.pod
index d6dad5d..0fed626 100644 (file)
--- a/pod/perl5112delta.pod
+++ b/pod/perl5112delta.pod
@@ -162,14 +162,12 @@ Any changes to F<pod/perldiag.pod> should go in L</New or Changed Diagnostics>.
 
 =head1 Performance Enhancements
 
-XXX Changes which enhance performance without changing behaviour go here. There
-may well be none in a stable release.
-
 =over 4
 
 =item *
 
-XXX
+Reversing an array in-place in void context is now several orders of magnitude faster than it used to be.
+It will also preserve non-existent elements whenever possible, i.e. for non magical arrays or tied arrays with C<EXISTS> and C<DELETE> methods.
 
 =back
 

diff --git a/pp.c b/pp.c
index 86d79fb..67a2d11 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4791,17 +4791,76 @@ PP(pp_unshift)
 PP(pp_reverse)
 {
     dVAR; dSP; dMARK;
-    SV ** const oldsp = SP;
 
     if (GIMME == G_ARRAY) {
-       MARK++;
-       while (MARK < SP) {
-           register SV * const tmp = *MARK;
-           *MARK++ = *SP;
-           *SP-- = tmp;
+       if (PL_op->op_private & OPpREVERSE_INPLACE) {
+           AV *av;
+
+           /* See pp_sort() */
+           assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
+           (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
+           av = MUTABLE_AV((*SP));
+           /* In-place reversing only happens in void context for the array
+            * assignment. We don't need to push anything on the stack. */
+           SP = MARK;
+
+           if (SvMAGICAL(av)) {
+               I32 i, j;
+               register SV *tmp = sv_newmortal();
+               /* For SvCANEXISTDELETE */
+               HV *stash;
+               const MAGIC *mg;
+               bool can_preserve = SvCANEXISTDELETE(av);
+
+               for (i = 0, j = av_len(av); i < j; ++i, --j) {
+                   register SV *begin, *end;
+
+                   if (can_preserve) {
+                       if (!av_exists(av, i)) {
+                           if (av_exists(av, j)) {
+                               register SV *sv = av_delete(av, j, 0);
+                               begin = *av_fetch(av, i, TRUE);
+                               sv_setsv_mg(begin, sv);
+                           }
+                           continue;
+                       }
+                       else if (!av_exists(av, j)) {
+                           register SV *sv = av_delete(av, i, 0);
+                           end = *av_fetch(av, j, TRUE);
+                           sv_setsv_mg(end, sv);
+                           continue;
+                       }
+                   }
+
+                   begin = *av_fetch(av, i, TRUE);
+                   end   = *av_fetch(av, j, TRUE);
+                   sv_setsv(tmp,      begin);
+                   sv_setsv_mg(begin, end);
+                   sv_setsv_mg(end,   tmp);
+               }
+           }
+           else {
+               SV **begin = AvARRAY(av);
+               SV **end   = begin + AvFILLp(av);
+
+               while (begin < end) {
+                   register SV * const tmp = *begin;
+                   *begin++ = *end;
+                   *end--   = tmp;
+               }
+           }
+       }
+       else {
+           SV **oldsp = SP;
+           MARK++;
+           while (MARK < SP) {
+               register SV * const tmp = *MARK;
+               *MARK++ = *SP;
+               *SP--   = tmp;
+           }
+           /* safe as long as stack cannot get extended in the above */
+           SP = oldsp;
        }
-       /* safe as long as stack cannot get extended in the above */
-       SP = oldsp;
     }
     else {
        register char *up;

diff --git a/t/op/reverse.t b/t/op/reverse.t
index 7afaac7..1ad727a 100644 (file)
--- a/t/op/reverse.t
+++ b/t/op/reverse.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5;
+plan tests => 21;
 
 is(reverse("abc"), "cba");
 
@@ -22,6 +22,60 @@ is(reverse(), "raboof");
 }
 
 {
+    my @a = (1, 2, 3, 4);
+    @a = reverse @a;
+    is("@a", "4 3 2 1");
+
+    delete $a[1];
+    @a = reverse @a;
+    ok(!exists $a[2]);
+    is($a[0] . $a[1] . $a[3], '124');
+
+    @a = (5, 6, 7, 8, 9);
+    @a = reverse @a;
+    is("@a", "9 8 7 6 5");
+
+    delete $a[3];
+    @a = reverse @a;
+    ok(!exists $a[1]);
+    is($a[0] . $a[2] . $a[3] . $a[4], '5789');
+
+    delete $a[2];
+    @a = reverse @a;
+    ok(!exists $a[2] && !exists $a[3]);
+    is($a[0] . $a[1] . $a[4], '985');
+}
+
+use Tie::Array;
+
+{
+    tie my @a, 'Tie::StdArray';
+
+    @a = (1, 2, 3, 4);
+    @a = reverse @a;
+    is("@a", "4 3 2 1");
+
+    delete $a[1];
+    @a = reverse @a;
+    ok(!exists $a[2]);
+    is($a[0] . $a[1] . $a[3], '124');
+
+    @a = (5, 6, 7, 8, 9);
+    @a = reverse @a;
+    is("@a", "9 8 7 6 5");
+
+    delete $a[3];
+    @a = reverse @a;
+    ok(!exists $a[1]);
+    is($a[0] . $a[2] . $a[3] . $a[4], '5789');
+
+    delete $a[2];
+    @a = reverse @a;
+    ok(!exists $a[2] && !exists $a[3]);
+    is($a[0] . $a[1] . $a[4], '985');
+}
+
+{
     # Unicode.
 
     my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}";