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;
#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 */
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;
I32 overloading = 0;
bool hasargs = FALSE;
I32 is_xsub = 0;
+ I32 sorting_av = 0;
if (gimme != G_ARRAY) {
SP = MARK;
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;
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);
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)
: 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;
}
}
}
+ 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;
}
@INC = '../lib';
}
use warnings;
-print "1..58\n";
+print "1..65\n";
# these shouldn't hang
{
@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";
+}
+
+
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff