diff options
| -rw-r--r-- | op.c | 90 | ||||
| -rw-r--r-- | op.h | 1 | ||||
| -rw-r--r-- | pp_sort.c | 95 | ||||
| -rwxr-xr-x | t/op/sort.t | 46 |
4 files changed, 208 insertions, 24 deletions
@@ -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; @@ -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 */ @@ -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 2a86b38c71..a218e97437 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"; +} + + + + |