In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/45c198c1bc981a507ab719edbd292922a896a397?hp=9c575c5c562583fedc6e491a509a388ce3b386bd>
- Log ----------------------------------------------------------------- commit 45c198c1bc981a507ab719edbd292922a896a397 Author: David Mitchell <[email protected]> Date: Wed Aug 10 16:19:55 2016 +0100 in-place sort preserved element lvalue identity RT #128340 The in-place sorting optimisation @a = sort @a, was preserving the elements of @a rather than (logically) making copies. So make a copy of any element whose refcount is greater than 1. This may not be the perfect condition, but keeps performance for the common cases. Note that several of the tests in t/op/sort.t actually relied on this behaviour to test whether the sort was being in-placed, so I've added tests for in-placing to t/perf/opcount.t instead. See the previous commit for a general discussion of performance; to the A, B, C in that commit message, here's a fourth column added: D is like C but with this commit added: A B C D ------ ------ ------ ------ Ir 5238.0 2324.0 2772.0 2801.0 Dr 1464.0 649.0 765.0 765.0 Dw 919.0 298.0 370.0 380.0 COND 782.0 320.0 405.0 405.0 IND 25.0 25.0 26.0 26.0 COND_m 14.9 13.0 17.0 17.1 IND_m 8.0 5.0 5.0 5.0 so it has little effect on performance. M pp_sort.c M t/op/sort.t M t/perf/opcount.t commit 84721d614eb7d9835d9a09505b0001c7be40a865 Author: David Mitchell <[email protected]> Date: Wed Aug 10 15:12:56 2016 +0100 Partially pessimise in-place sorting There's currently an optimisation that converts at compile-time @a = sort { .... } @a into (approximately) sort { ... } \@a Then at run time, rather than passing an svp pointer to the appropriate sort routine which points to a list of SV*'s on the stack, pp_sort() passes a pointer to @a's AvARRAY. This allows the array to be sorted in-place, which is more efficient. However, it has some issues. First, the @a visible to the sort routine will be varying, whereas logically it should still hold the original list of values until after the '@a = ...' assignment. Secondly, the mergesort algorithm cureently used internally, when in mid-sort, temporarily stores pointers in the array which aren't pointers to SVs - this means that if @a elements are accessed mid-sort, it can crash. The solution to both these problems is for pp_sort() to push the elements of @a onto the stack at the beginning, sort the stack (like normal sorts do), then copy back to @a at the end. This is less efficient than before, but is still a lot more efficient than executing separate padav and aassign ops. Here are benchmark results in raw instruction counts etc (lower is better) for the sort line in this code block: my (@a, @b); @a = reverse 1..10; @b = sort { $a <=> $b } @a; A is for a non-in-place sort, i.e. @b = sort ... @a; B and C are for an inline sort, i.e. as above, but @a = sort ... @a; where B is blead before this commit and C is this commit. A B C ------ ------ ------ Ir 5238.0 2324.0 2772.0 Dr 1464.0 649.0 765.0 Dw 919.0 298.0 370.0 COND 782.0 320.0 405.0 IND 25.0 25.0 26.0 COND_m 14.9 13.0 17.0 IND_m 8.0 5.0 5.0 As can be seen, this partial pessimisation slows down in-place sorting by round 20%, but overall in-place is still nearly twice the speed as without the optimisation. These are the figures for a plain numeric sort (which is optimised to use a C comparison function); for other types of sort, the cost of the comparator dominates, and so the slowdown is much less marked. M pp_sort.c M t/op/sort.t M t/perf/benchmarks ----------------------------------------------------------------------- Summary of changes: pp_sort.c | 99 ++++++++++++++++++++++++++++++++----------------------- t/op/sort.t | 41 ++++++++++++++--------- t/perf/benchmarks | 67 ++++++++++++++++++++++++++++++++++++- t/perf/opcount.t | 48 ++++++++++++++++++++++++++- 4 files changed, 196 insertions(+), 59 deletions(-) diff --git a/pp_sort.c b/pp_sort.c index c91aab0..b68e80c 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1482,7 +1482,6 @@ PP(pp_sort) bool hasargs = FALSE; bool copytmps; I32 is_xsub = 0; - I32 sorting_av = 0; const U8 priv = PL_op->op_private; const U8 flags = PL_op->op_flags; U32 sort_flags = 0; @@ -1563,34 +1562,31 @@ PP(pp_sort) PL_sortcop = NULL; } - /* 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 */ + /* optimiser converts "@a = sort @a" to "sort \@a". In this case, + * push (@a) onto stack, then assign result back to @a at the end of + * this function */ if (priv & OPpSORT_INPLACE) { assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ av = MUTABLE_AV((*SP)); + if (SvREADONLY(av)) + Perl_croak_no_modify(); max = AvFILL(av) + 1; + MEXTEND(SP, max); if (SvMAGICAL(av)) { - MEXTEND(SP, max); for (i=0; i < max; i++) { SV **svp = av_fetch(av, i, FALSE); *SP++ = (svp) ? *svp : NULL; } - SP--; - p1 = p2 = SP - (max-1); } - else { - if (SvREADONLY(av)) - Perl_croak_no_modify(); - else - { - SvREADONLY_on(av); - save_pushptr((void *)av, SAVEt_READONLY_OFF); - } - p1 = p2 = AvARRAY(av); - sorting_av = 1; + else { + SV **svp = AvARRAY(av); + assert(svp || max == 0); + for (i = 0; i < max; i++) + *SP++ = *svp++; } + SP--; + p1 = p2 = SP - (max-1); } else { p2 = MARK+1; @@ -1600,7 +1596,7 @@ PP(pp_sort) /* shuffle stack down, removing optional initial cv (p1!=p2), plus * any nulls; also stringify or converting to integer or number as * required any args */ - copytmps = !sorting_av && PL_sortcop; + copytmps = PL_sortcop; for (i=max; i > 0 ; i--) { if ((*p1 = *p2++)) { /* Weed out nulls. */ if (copytmps && SvPADTMP(*p1)) { @@ -1633,9 +1629,6 @@ PP(pp_sort) else max--; } - if (sorting_av) - AvFILLp(av) = max-1; - if (max > 1) { SV **start; if (PL_sortcop) { @@ -1716,7 +1709,7 @@ PP(pp_sort) } else { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - start = sorting_av ? AvARRAY(av) : ORIGMARK+1; + start = ORIGMARK+1; sortsvp(aTHX_ start, max, (priv & OPpSORT_NUMERIC) ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs) @@ -1742,27 +1735,51 @@ PP(pp_sort) } } } - if (sorting_av) - SvREADONLY_off(av); - else if (av && !sorting_av) { - /* simulate pp_aassign of tied AV */ - SV** const base = MARK+1; - for (i=0; i < max; i++) { - base[i] = newSVsv(base[i]); - } - av_clear(av); - av_extend(av, max); - for (i=0; i < max; i++) { - SV * const sv = base[i]; - SV ** const didstore = av_store(av, i, sv); - if (SvSMAGICAL(sv)) - mg_set(sv); - if (!didstore) - sv_2mortal(sv); - } + + if (av) { + /* copy back result to the array */ + SV** const base = MARK+1; + if (SvMAGICAL(av)) { + for (i = 0; i < max; i++) + base[i] = newSVsv(base[i]); + av_clear(av); + av_extend(av, max); + for (i=0; i < max; i++) { + SV * const sv = base[i]; + SV ** const didstore = av_store(av, i, sv); + if (SvSMAGICAL(sv)) + mg_set(sv); + if (!didstore) + sv_2mortal(sv); + } + } + else { + /* the elements of av are likely to be the same as the + * (non-refcounted) elements on the stack, just in a different + * order. However, its possible that someone's messed with av + * in the meantime. So bump and unbump the relevant refcounts + * first. + */ + for (i = 0; i < max; i++) { + SV *sv = base[i]; + assert(sv); + if (SvREFCNT(sv) > 1) + base[i] = newSVsv(sv); + else + SvREFCNT_inc_simple_void_NN(sv); + } + av_clear(av); + if (max > 0) { + av_extend(av, max); + Copy(base, AvARRAY(av), max, SV*); + } + AvFILLp(av) = max - 1; + AvREIFY_off(av); + AvREAL_on(av); + } } LEAVE; - PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max); + PL_stack_sp = ORIGMARK + max; return nextop; } diff --git a/t/op/sort.t b/t/op/sort.t index badd684..cd1c6eb 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -7,7 +7,7 @@ BEGIN { set_up_inc('../lib'); } use warnings; -plan(tests => 195); +plan(tests => 196); # these shouldn't hang { @@ -417,21 +417,21 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar my ($r1,$r2,@a); our @g; @g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0]; - is "$r1-@g", "$r2-1 2 3", "inplace sort of global"; + is "$$r1-$$r2-@g", "1-1-1 2 3", "inplace sort of global"; @a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0]; - is "$r1-@a", "$r2-a b c", "inplace sort of lexical"; + is "$$r1-$$r2-@a", "a-a-a b c", "inplace sort of lexical"; @g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0]; - is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global"; + is "$$r1-$$r2-@g", "3-3-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]; - is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global"; + is "$$r1-$$r2-@g", "3-3-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]; - is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical"; + is "$$r1-$$r2-@a", "c-c-c b a", "inplace sort with function of lexical"; use Tie::Array; my @t; @@ -474,6 +474,25 @@ cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other ar no warnings 'void'; my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m; ::pass("in-place sorting segfault"); + + # RT #39358 - array should be preserved during sort + + { + my @aa = qw(b c a); + my @copy; + @aa = sort { @copy = @aa; $a cmp $b } @aa; + is "@aa", "a b c", "RT 39358 - aa"; + is "@copy", "b c a", "RT 39358 - copy"; + } + + # RT #128340: in-place sort incorrectly preserves element lvalue identity + + @a = (5, 4, 3); + my $r = \$a[2]; + @a = sort { $a <=> $b } @a; + $$r = "z"; + is ("@a", "3 4 5", "RT #128340"); + } # Test optimisations of reversed sorts. As we now guarantee stability by @@ -846,16 +865,6 @@ cmp_ok($answer,'eq','good','sort subr called from other package'); } -# Bug 7567 - an array shouldn't be modifiable while it's being -# sorted in-place. -{ - eval { @a=(1..8); @a = sort { @a = (0) } @a; }; - - $fail_msg = q(Modification of a read-only value attempted); - cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567'); - eval { @a=1..3 }; - is $@, "", 'abrupt scope exit turns off readonliness'; -} # I commented out this TODO test because messing with FREEd scalars on the # stack can have all sorts of strange side-effects, not made safe by eval diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 88b20de..6ea1ce8 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -33,6 +33,7 @@ # # call:: subroutine and method handling # expr:: expressions: e.g. $x=1, $foo{bar}[0] +# func:: perl functions, e.g. func::sort::... # loop:: structural code like for, while(), etc # regex:: regular expressions # string:: string handling @@ -895,9 +896,73 @@ code => '$y = $x--', # scalar context so not optimised to --$x }, + + 'func::sort::num' => { + desc => 'plain numeric sort', + setup => 'my (@a, @b); @a = reverse 1..10;', + code => '@b = sort { $a <=> $b } @a', + }, + 'func::sort::num_block' => { + desc => 'codeblock numeric sort', + setup => 'my (@a, @b); @a = reverse 1..10;', + code => '@b = sort { $a + 1 <=> $b + 1 } @a', + }, + 'func::sort::num_fn' => { + desc => 'function numeric sort', + setup => 'sub f { $a + 1 <=> $b + 1 } my (@a, @b); @a = reverse 1..10;', + code => '@b = sort f @a', + }, + 'func::sort::str' => { + desc => 'plain string sort', + setup => 'my (@a, @b); @a = reverse "a".."j";', + code => '@b = sort { $a cmp $b } @a', + }, + 'func::sort::str_block' => { + desc => 'codeblock string sort', + setup => 'my (@a, @b); @a = reverse "a".."j";', + code => '@b = sort { ($a . "") cmp ($b . "") } @a', + }, + 'func::sort::str_fn' => { + desc => 'function string sort', + setup => 'sub f { ($a . "") cmp ($b . "") } my (@a, @b); @a = reverse "a".."j";', + code => '@b = sort f @a', + }, + + 'func::sort::num_inplace' => { + desc => 'plain numeric sort in-place', + setup => 'my @a = reverse 1..10;', + code => '@a = sort { $a <=> $b } @a', + }, + 'func::sort::num_block_inplace' => { + desc => 'codeblock numeric sort in-place', + setup => 'my @a = reverse 1..10;', + code => '@a = sort { $a + 1 <=> $b + 1 } @a', + }, + 'func::sort::num_fn_inplace' => { + desc => 'function numeric sort in-place', + setup => 'sub f { $a + 1 <=> $b + 1 } my @a = reverse 1..10;', + code => '@a = sort f @a', + }, + 'func::sort::str_inplace' => { + desc => 'plain string sort in-place', + setup => 'my @a = reverse "a".."j";', + code => '@a = sort { $a cmp $b } @a', + }, + 'func::sort::str_block_inplace' => { + desc => 'codeblock string sort in-place', + setup => 'my @a = reverse "a".."j";', + code => '@a = sort { ($a . "") cmp ($b . "") } @a', + }, + 'func::sort::str_fn_inplace' => { + desc => 'function string sort in-place', + setup => 'sub f { ($a . "") cmp ($b . "") } my @a = reverse "a".."j";', + code => '@a = sort f @a', + }, + + 'loop::block' => { desc => 'empty basic loop', - setup => ';', + setup => '', code => '{1;}', }, diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 3cdd334..f65695d 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -20,7 +20,7 @@ BEGIN { use warnings; use strict; -plan 2251; +plan 2256; use B (); @@ -279,3 +279,49 @@ test_opcount(0, 'barewords can be constant-folded', aelemfast_lex => 1, }); } + +# in-place sorting + +{ + local our @global = (3,2,1); + my @lex = qw(a b c); + + test_opcount(0, 'in-place sort of global', + sub { @global = sort @global; 1 }, + { + rv2av => 1, + aassign => 0, + }); + + test_opcount(0, 'in-place sort of lexical', + sub { @lex = sort @lex; 1 }, + { + padav => 1, + aassign => 0, + }); + + test_opcount(0, 'in-place reversed sort of global', + sub { @global = sort { $b <=> $a } @global; 1 }, + { + rv2av => 1, + aassign => 0, + }); + + + test_opcount(0, 'in-place custom sort of global', + sub { @global = sort { $a<$b?1:$a>$b?-1:0 } @global; 1 }, + { + rv2av => 1, + aassign => 0, + }); + + sub mysort { $b cmp $a }; + test_opcount(0, 'in-place sort with function of lexical', + sub { @lex = sort mysort @lex; 1 }, + { + padav => 1, + aassign => 0, + }); + + +} -- Perl5 Master Repository
