From: Dave Mitchell <davem@fdisolutions.com>
Date: Fri, 20 Feb 2004 14:54:35 +0000 (+0000)
Subject: optimise the sorting inplace of plain arrays: @a = sort @a
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fe1bc4cf71e7b04d33e679798964a090d9fa7b46;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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";
+}
+
+
+
+