optimise the sorting inplace of plain arrays: @a = sort @a

p4raw-id: //depot/perl@22349

diff --git a/op.c b/op.c
index 97dd955..bed697d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6554,6 +6554,96 @@ Perl_peep(pTHX_ register OP *o)
             break;
         }
 
+       case OP_SORT: {
+           /* make @a = sort @a act in-place */
+
+           /* will point to RV2AV or PADAV op on LHS/RHS of assign */
+           OP *oleft, *oright;
+           OP *o2;
+
+           o->op_seq = PL_op_seqmax++;
+
+           /* check that RHS of sort is a single plain array */
+           oright = cUNOPo->op_first;
+           if (!oright || oright->op_type != OP_PUSHMARK)
+               break;
+           oright = cUNOPx(oright)->op_sibling;
+           if (!oright)
+               break;
+           if (oright->op_type == OP_NULL) { /* skip sort block/sub */
+               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 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
+           )
+               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;
+       }
+       
+
+
        default:
            o->op_seq = PL_op_seqmax++;
            break;

diff --git a/op.h b/op.h
index e957e1b..bd267b5 100644 (file)
--- a/op.h
+++ b/op.h
@@ -194,6 +194,7 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpSORT_NUMERIC                1       /* Optimized away { $a <=> $b } */
 #define OPpSORT_INTEGER                2       /* Ditto while under "use integer" */
 #define OPpSORT_REVERSE                4       /* Descending sort */
+#define OPpSORT_INPLACE                8       /* sort in-place; eg @a = sort @a */
 /* Private for OP_THREADSV */
 #define OPpDONE_SVREF          64      /* Been through newSVREF once */
 

diff --git a/pp_sort.c b/pp_sort.c
index 8e6422d..ad9312d 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1413,9 +1413,9 @@ Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
 PP(pp_sort)
 {
     dSP; dMARK; dORIGMARK;
-    register SV **up;
-    SV **myorigmark = ORIGMARK;
-    register I32 max;
+    register SV **p1 = ORIGMARK+1, **p2;
+    register I32 max, i;
+    AV* av = Nullav;
     HV *stash;
     GV *gv;
     CV *cv = 0;
@@ -1424,6 +1424,7 @@ PP(pp_sort)
     I32 overloading = 0;
     bool hasargs = FALSE;
     I32 is_xsub = 0;
+    I32 sorting_av = 0;
 
     if (gimme != G_ARRAY) {
        SP = MARK;
@@ -1480,24 +1481,54 @@ PP(pp_sort)
        stash = CopSTASH(PL_curcop);
     }
 
-    up = myorigmark + 1;
-    while (MARK < SP) {        /* This may or may not shift down one here. */
-       /*SUPPRESS 560*/
-       if ((*up = *++MARK)) {                  /* Weed out nulls. */
-           SvTEMP_off(*up);
-           if (!PL_sortcop && !SvPOK(*up)) {
+    /* optimiser converts "@a = sort @a" to "sort \@a";
+     * in case of tied @a, pessimise: push (@a) onto stack, then assign
+     * result back to @a at the end of this function */
+    if (PL_op->op_private & OPpSORT_INPLACE) {
+       assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
+       (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
+       av = (AV*)(*SP);
+       max = AvFILL(av) + 1;
+       if (SvMAGICAL(av)) {
+           MEXTEND(SP, max);
+           p2 = SP;
+           for (i=0; i < (U32)max; i++) {
+               SV **svp = av_fetch(av, i, FALSE);
+               *SP++ = (svp) ? *svp : Nullsv;
+           }
+       }
+       else {
+           p1 = p2 = AvARRAY(av);
+           sorting_av = 1;
+       }
+    }
+    else {
+       p2 = MARK+1;
+       max = SP - MARK;
+   }
+
+    /* shuffle stack down, removing optional initial cv (p1!=p2), plus any
+     * nulls; also stringify any args */
+    for (i=max; i > 0 ; i--) {
+       if ((*p1 = *p2++)) {                    /* Weed out nulls. */
+           SvTEMP_off(*p1);
+           if (!PL_sortcop && !SvPOK(*p1)) {
                STRLEN n_a;
-               if (SvAMAGIC(*up))
+               if (SvAMAGIC(*p1))
                    overloading = 1;
                else
-                   (void)sv_2pv(*up, &n_a);
+                   (void)sv_2pv(*p1, &n_a);
            }
-           up++;
+           p1++;
        }
+       else
+           max--;
     }
-    max = --up - myorigmark;
-    if (PL_sortcop) {
-       if (max > 1) {
+    if (sorting_av)
+       AvFILLp(av) = max-1;
+
+    if (max > 1) {
+       if (PL_sortcop) {
            PERL_CONTEXT *cx;
            SV** newsp;
            bool oldcatch = CATCH_GET;
@@ -1536,7 +1567,7 @@ PP(pp_sort)
                CX_CURPAD_SAVE(cx->blk_sub);
                cx->blk_sub.argarray = av;
            }
-           sortsv((myorigmark+1), max,
+           sortsv(p1-max, max,
                   is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
            POPBLOCK(cx,PL_curpm);
@@ -1544,11 +1575,9 @@ PP(pp_sort)
            POPSTACK;
            CATCH_SET(oldcatch);
        }
-    }
-    else {
-       if (max > 1) {
+       else {
            MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
-           sortsv(ORIGMARK+1, max,
+           sortsv(sorting_av ? AvARRAY(av) : ORIGMARK+1, max,
                   (PL_op->op_private & OPpSORT_NUMERIC)
                        ? ( (PL_op->op_private & OPpSORT_INTEGER)
                            ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
@@ -1559,8 +1588,8 @@ PP(pp_sort)
                                : sv_cmp_locale_static)
                            : ( overloading ? amagic_cmp : sv_cmp_static)));
            if (PL_op->op_private & OPpSORT_REVERSE) {
-               SV **p = ORIGMARK+1;
-               SV **q = ORIGMARK+max;
+               SV **p = sorting_av ? AvARRAY(av) : ORIGMARK+1;
+               SV **q = p+max-1;
                while (p < q) {
                    SV *tmp = *p;
                    *p++ = *q;
@@ -1569,8 +1598,28 @@ PP(pp_sort)
            }
        }
     }
+    if (av && !sorting_av) {
+       /* simulate pp_aassign of tied AV */
+       SV *sv;
+       SV** base, **didstore;
+       for (base = ORIGMARK+1, i=0; i < max; i++) {
+           sv = NEWSV(28,0);
+           sv_setsv(sv, base[i]);
+           base[i] = sv;
+       }
+       av_clear(av);
+       av_extend(av, max);
+       for (i=0; i < max; i++) {
+           sv = base[i];
+           didstore = av_store(av, i, sv);
+           if (SvSMAGICAL(sv))
+               mg_set(sv);
+           if (!didstore)
+               sv_2mortal(sv);
+       }
+    }
     LEAVE;
-    PL_stack_sp = ORIGMARK + max;
+    PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
     return nextop;
 }
 

diff --git a/t/op/sort.t b/t/op/sort.t
index 2a86b38..a218e97 100755 (executable)
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 use warnings;
-print "1..58\n";
+print "1..65\n";
 
 # these shouldn't hang
 {
@@ -322,3 +322,47 @@ sub cxt_six { sort test_if_scalar 1,2 }
     @a = sort(routine(1));
     print "@a" eq "one two" ? "ok 58\n" : "not ok 58\n";
 }
+
+
+my $test = 59;
+sub ok {
+    print "not " unless $_[0] eq $_[1];
+    print "ok $test - $_[2]\n";
+    print "#[$_[0]] ne [$_[1]]\n" unless $_[0] eq $_[1];
+    $test++;
+}
+
+# check for in-place optimisation of @a = sort @a
+{
+    my ($r1,$r2,@a);
+    our @g;
+    @g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
+    ok "$r1-@g", "$r2-1 2 3", "inplace sort of global";
+
+    @a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
+    ok "$r1-@a", "$r2-a b c", "inplace sort of lexical";
+
+    @g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
+    ok "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
+
+    @g = (2,3,1);
+    $r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
+    ok "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
+
+    sub mysort { $b cmp $a };
+    @a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
+    ok "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
+
+    use Tie::Array;
+    tie @a, 'Tie::StdArray';
+
+    @a = qw(b c a); @a = sort @a;
+    ok "@a", "a b c", "inplace sort of tied array";
+
+    @a = qw(b c a); @a = sort mysort @a;
+    ok "@a", "c b a", "inplace sort of tied array with function";
+}
+
+
+
+