Skip to content

Commit

Permalink
Merge 70ae4f4 into 6a2e93d
Browse files Browse the repository at this point in the history
  • Loading branch information
@nwc10
nwc10 committed Jun 30, 2021
2 parents 6a2e93d + 70ae4f4 commit f272ca1
Show file tree
Hide file tree
Showing 9 changed files with 200 additions and 236 deletions.
4 changes: 2 additions & 2 deletions ext/B/t/f_sort.t
View file
Expand Up @@ -653,7 +653,7 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 3 <0> pushmark s
# 4 <#> gv[*old] s
# 5 <1> rv2av[t9] lKM/1
# 6 <@> sort lKS*/STABLE
# 6 <@> sort lKS*
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
Expand All @@ -665,7 +665,7 @@ EOT_EOT
# 3 <0> pushmark s
# 4 <$> gv(*old) s
# 5 <1> rv2av[t5] lKM/1
# 6 <@> sort lKS*/STABLE
# 6 <@> sort lKS*
# 7 <0> pushmark s
# 8 <$> gv(*new) s
# 9 <1> rv2av[t1] lKRM*/1
Expand Down
8 changes: 1 addition & 7 deletions lib/B/Op_private.pm
View file
Expand Up @@ -543,7 +543,7 @@ $bits{sin}{0} = $bf[0];
$bits{snetent}{0} = $bf[0];
@{$bits{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sort}}{7,6,4,3,2,1,0} = ('OPpSORT_UNSTABLE', 'OPpSORT_STABLE', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
@{$bits{sort}}{4,3,2,1,0} = ('OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM');
@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
Expand Down Expand Up @@ -684,8 +684,6 @@ our %defines = (
OPpSORT_INTEGER => 2,
OPpSORT_NUMERIC => 1,
OPpSORT_REVERSE => 4,
OPpSORT_STABLE => 64,
OPpSORT_UNSTABLE => 128,
OPpSPLIT_ASSIGN => 16,
OPpSPLIT_IMPLIM => 4,
OPpSPLIT_LEX => 8,
Expand Down Expand Up @@ -787,8 +785,6 @@ our %labels = (
OPpSORT_INTEGER => 'INT',
OPpSORT_NUMERIC => 'NUM',
OPpSORT_REVERSE => 'REV',
OPpSORT_STABLE => 'STABLE',
OPpSORT_UNSTABLE => 'UNSTABLE',
OPpSPLIT_ASSIGN => 'ASSIGN',
OPpSPLIT_IMPLIM => 'IMPLIM',
OPpSPLIT_LEX => 'LEX',
Expand Down Expand Up @@ -888,8 +884,6 @@ $ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_UNSTABLE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN};
$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN};
$ops_using{OPpTRANS_COMPLEMENT} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
Expand Down
143 changes: 46 additions & 97 deletions lib/sort.pm
View file
@@ -1,33 +1,22 @@
package sort;

our $VERSION = '2.04';

# The hints for pp_sort are now stored in $^H{sort}; older versions
# of perl used the global variable $sort::hints. -- rjh 2005-12-19

$sort::stable_bit = 0x00000100;
$sort::unstable_bit = 0x00000200;

use strict;
use warnings;

our $VERSION = '2.05';

sub import {
shift;
if (@_ == 0) {
require Carp;
Carp::croak("sort pragma requires arguments");
}
local $_;
$^H{sort} //= 0;
while ($_ = shift(@_)) {
if ($_ eq 'stable') {
$^H{sort} |= $sort::stable_bit;
$^H{sort} &= ~$sort::unstable_bit;
} elsif ($_ eq 'defaults') {
$^H{sort} = 0;
} else {
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
for my $subpragma (@_) {
next
if $subpragma eq 'stable' || $subpragma eq 'defaults';
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
}

Expand All @@ -37,25 +26,17 @@ sub unimport {
require Carp;
Carp::croak("sort pragma requires arguments");
}
local $_;
no warnings 'uninitialized'; # bitops would warn
while ($_ = shift(@_)) {
if ($_ eq 'stable') {
$^H{sort} &= ~$sort::stable_bit;
$^H{sort} |= $sort::unstable_bit;
} else {
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
for my $subpragma (@_) {
next
if $subpragma eq 'stable';
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
}

sub current {
my @sort;
if ($^H{sort}) {
push @sort, 'stable' if $^H{sort} & $sort::stable_bit;
}
join(' ', @sort);
warnings::warnif("deprecated", "sort::current is deprecated, and will always return 'stable'");
return 'stable';
}

1;
Expand All @@ -67,86 +48,54 @@ sort - perl pragma to control sort() behaviour
=head1 SYNOPSIS
The sort pragma is now a no-op, and its use is discouraged. These three
operations are valid, but have no effect:
use sort 'stable'; # guarantee stability
use sort 'defaults'; # revert to default behavior
no sort 'stable'; # stability not important
my $current;
BEGIN {
$current = sort::current(); # identify prevailing pragmata
}
=head1 DESCRIPTION
With the C<sort> pragma you can control the behaviour of the builtin
Historically the C<sort> pragma you can control the behaviour of the builtin
C<sort()> function.
A stable sort means that for records that compare equal, the original
input ordering is preserved.
Stability will matter only if elements that compare equal can be
distinguished in some other way. That means that simple numerical
and lexical sorts do not profit from stability, since equal elements
are indistinguishable. However, with a comparison such as
Prior to v5.28.0 there were two other options:
{ substr($a, 0, 3) cmp substr($b, 0, 3) }
use sort '_mergesort';
use sort '_qsort'; # or '_quicksort'
stability might matter because elements that compare equal on the
first 3 characters may be distinguished based on subsequent characters.
If you try and specify either of these in v5.28+ it will croak.
Whether sorting is stable by default is an accident of implementation
that can change (and has changed) between Perl versions.
If stability is important, be sure to
say so with a
The default sort has been stable since v5.8.0, and given this consistent
behaviour for almost two decades, everyone has come to assume stability.
use sort 'stable';
Stability will remain the default - hence there is no need for a pragma for
code to opt into stability "just in case" this changes - it won't.
The C<no sort> pragma doesn't
I<forbid> what follows, it just leaves the choice open. Thus, after
We do not foresee going back to offering multiple implementations of general
purpose sorting - hence there is no future need to offer a pragma to choose
between them.
no sort 'stable';
f you know that you care that much about performance of your sorting, and
that for your use case and your data, it was worth investigating
alternatives, possible to identify an alternative from our default that was
better, and the cost of switching was worth it, then you know more than we
do. Likely whatever choices we can give are not as good as implementing your
own. (For example, a Radix sort can be faster than O(n log n), but can't be
used for all keys and has larger overheads.)
sorting may happen to be stable anyway.
We are not averse to B<changing> the sort algorithm, but we don't see the
benefit in offering the choice of two general purpose implementations.
=head1 CAVEATS
As of Perl 5.10, this pragma is lexically scoped and takes effect
at compile time. In earlier versions its effect was global and took
effect at run-time; the documentation suggested using C<eval()> to
change the behaviour:
{ eval 'no sort "stable"'; # stability not wanted
print sort::current . "\n";
@a = sort @b;
eval 'use sort "defaults"'; # clean up, for others
}
{ eval 'use sort qw(defaults stable)'; # force stability
print sort::current . "\n";
@c = sort @d;
eval 'use sort "defaults"'; # clean up, for others
}
Such code no longer has the desired effect, for two reasons.
Firstly, the use of C<eval()> means that the sorting algorithm
is not changed until runtime, by which time it's too late to
have any effect. Secondly, C<sort::current> is also called at
run-time, when in fact the compile-time value of C<sort::current>
is the one that matters.
So now this code would be written:
{ no sort "stable"; # stability not wanted
my $current;
BEGIN { $current = sort::current; }
print "$current\n";
@a = sort @b;
# Pragmas go out of scope at the end of the block
}
{ use sort qw(defaults stable); # force stability
my $current;
BEGIN { $current = sort::current; }
print "$current\n";
@c = sort @d;
}
The function C<sort::current()> was provided to report the current state of
the sort pragmata. This function was not exported, and there is no code to
call it on CPAN. It is now deprecated, and will warn by default.
=cut
As we no longer store any sort "state", it can no longer return the correct
value, so it will always return the string C<stable>, as this is consistent
with what we actually have implemented.
=cut
58 changes: 55 additions & 3 deletions lib/sort.t
View file
Expand Up @@ -27,7 +27,7 @@ use warnings;

use Test::More tests => @TestSizes * 2 # sort() tests
* 3 # number of pragmas to test
+ 2; # tests for sort::current
+ 10; # tests for sort::current

# Generate array of specified size for testing sort.
#
Expand Down Expand Up @@ -148,7 +148,13 @@ main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);

{
use sort qw(stable);
my $sort_current; BEGIN { $sort_current = sort::current(); }
my $sort_current;
BEGIN {
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]};
$sort_current = sort::current();
like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
}
is($sort_current, 'stable', 'sort::current for stable');
main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
}
Expand All @@ -157,7 +163,53 @@ main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);

{
use sort qw(defaults stable);
my $sort_current; BEGIN { $sort_current = sort::current(); }
my $sort_current;
BEGIN {
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]};
$sort_current = sort::current();
like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
}
is($sort_current, 'stable', 'sort::current after defaults stable');
main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
}

# Tests added to check how sort::current is deprecated

{
no sort qw(stable);
my $sort_current;
BEGIN {
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]};
$sort_current = sort::current();
like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
}
is($sort_current, 'stable', 'sort::current *always* stable');
}

{
use sort qw(defaults);
my $sort_current;
BEGIN {
no warnings qw(deprecated);
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]};
$sort_current = sort::current();
is($a, "", "sort::current warning can be disabled");
}
is($sort_current, 'stable', 'sort::current *always* stable');
}

{
use sort qw(stable);
my $sort_current;
BEGIN {
no warnings qw(deprecated);
my $a = "" ;
local $SIG{__WARN__} = sub {$a = $_[0]};
$sort_current = sort::current();
is($a, "", "sort::current warning can be disabled");
}
is($sort_current, 'stable', 'sort::current for stable');
}
13 changes: 0 additions & 13 deletions op.c
View file
Expand Up @@ -14098,23 +14098,10 @@ Perl_ck_sort(pTHX_ OP *o)
{
OP *firstkid;
OP *kid;
HV * const hinthv =
PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
U8 stacked;

PERL_ARGS_ASSERT_CK_SORT;

if (hinthv) {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
if ((sorthints & HINT_SORT_UNSTABLE) != 0)
o->op_private |= OPpSORT_UNSTABLE;
}
}

if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
Expand Down

0 comments on commit f272ca1

Please sign in to comment.