3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * ...they shuffled back towards the rear of the line. 'No, not at the
13 * rear!' the slave-driver shouted. 'Three files up. And stay there...
15 * [p.931 of _The Lord of the Rings_, VI/ii: "The Land of Shadow"]
18 /* This file contains pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * This particular file just contains pp_sort(), which is complex
25 * enough to merit its own file! See the other pp*.c files for the rest of
30 #define PERL_IN_PP_SORT_C
34 /* looks like 'small' is reserved word for WINCE (or somesuch)*/
38 #define sv_cmp_static Perl_sv_cmp
39 #define sv_cmp_locale_static Perl_sv_cmp_locale
42 #define SMALLSORT (200)
45 /* Flags for qsortsv and mergesortsv */
47 #define SORTf_STABLE 2
48 #define SORTf_UNSTABLE 8
51 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
53 * The original code was written in conjunction with BSD Computer Software
54 * Research Group at University of California, Berkeley.
56 * See also: "Optimistic Sorting and Information Theoretic Complexity"
58 * SODA (Fourth Annual ACM-SIAM Symposium on Discrete Algorithms),
59 * pp 467-474, Austin, Texas, 25-27 January 1993.
61 * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
63 * The code can be distributed under the same terms as Perl itself.
68 typedef char * aptr; /* pointer for arithmetic on sizes */
69 typedef SV * gptr; /* pointers in our lists */
71 /* Binary merge internal sort, with a few special mods
72 ** for the special perl environment it now finds itself in.
74 ** Things that were once options have been hotwired
75 ** to values suitable for this use. In particular, we'll always
76 ** initialize looking for natural runs, we'll always produce stable
77 ** output, and we'll always do Peter McIlroy's binary merge.
80 /* Pointer types for arithmetic and storage and convenience casts */
82 #define APTR(P) ((aptr)(P))
83 #define GPTP(P) ((gptr *)(P))
84 #define GPPP(P) ((gptr **)(P))
87 /* byte offset from pointer P to (larger) pointer Q */
88 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
90 #define PSIZE sizeof(gptr)
92 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
95 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
96 #define PNBYTE(N) ((N) << (PSHIFT))
97 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
99 /* Leave optimization to compiler */
100 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
101 #define PNBYTE(N) ((N) * (PSIZE))
102 #define PINDEX(P, N) (GPTP(P) + (N))
105 /* Pointer into other corresponding to pointer into this */
106 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
108 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
111 /* Runs are identified by a pointer in the auxiliary list.
112 ** The pointer is at the start of the list,
113 ** and it points to the start of the next list.
114 ** NEXT is used as an lvalue, too.
117 #define NEXT(P) (*GPPP(P))
120 /* PTHRESH is the minimum number of pairs with the same sense to justify
121 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
122 ** not just elements, so PTHRESH == 8 means a run of 16.
127 /* RTHRESH is the number of elements in a run that must compare low
128 ** to the low element from the opposing run before we justify
129 ** doing a binary rampup instead of single stepping.
130 ** In random input, N in a row low should only happen with
131 ** probability 2^(1-N), so we can risk that we are dealing
132 ** with orderly input without paying much when we aren't.
139 ** Overview of algorithm and variables.
140 ** The array of elements at list1 will be organized into runs of length 2,
141 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
142 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
144 ** Unless otherwise specified, pair pointers address the first of two elements.
146 ** b and b+1 are a pair that compare with sense "sense".
147 ** b is the "bottom" of adjacent pairs that might form a longer run.
149 ** p2 parallels b in the list2 array, where runs are defined by
152 ** t represents the "top" of the adjacent pairs that might extend
153 ** the run beginning at b. Usually, t addresses a pair
154 ** that compares with opposite sense from (b,b+1).
155 ** However, it may also address a singleton element at the end of list1,
156 ** or it may be equal to "last", the first element beyond list1.
158 ** r addresses the Nth pair following b. If this would be beyond t,
159 ** we back it off to t. Only when r is less than t do we consider the
160 ** run long enough to consider checking.
162 ** q addresses a pair such that the pairs at b through q already form a run.
163 ** Often, q will equal b, indicating we only are sure of the pair itself.
164 ** However, a search on the previous cycle may have revealed a longer run,
165 ** so q may be greater than b.
167 ** p is used to work back from a candidate r, trying to reach q,
168 ** which would mean b through r would be a run. If we discover such a run,
169 ** we start q at r and try to push it further towards t.
170 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
171 ** In any event, after the check (if any), we have two main cases.
173 ** 1) Short run. b <= q < p <= r <= t.
174 ** b through q is a run (perhaps trivial)
175 ** q through p are uninteresting pairs
176 ** p through r is a run
178 ** 2) Long run. b < r <= q < t.
179 ** b through q is a run (of length >= 2 * PTHRESH)
181 ** Note that degenerate cases are not only possible, but likely.
182 ** For example, if the pair following b compares with opposite sense,
183 ** then b == q < p == r == t.
188 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
191 gptr *b, *p, *q, *t, *p2;
196 last = PINDEX(b, nmemb);
197 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
198 for (p2 = list2; b < last; ) {
199 /* We just started, or just reversed sense.
200 ** Set t at end of pairs with the prevailing sense.
202 for (p = b+2, t = p; ++p < last; t = ++p) {
203 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
206 /* Having laid out the playing field, look for long runs */
208 p = r = b + (2 * PTHRESH);
209 if (r >= t) p = r = t; /* too short to care about */
211 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
214 /* b through r is a (long) run.
215 ** Extend it as far as possible.
218 while (((p += 2) < t) &&
219 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
220 r = p = q + 2; /* no simple pairs, no after-run */
223 if (q > b) { /* run of greater than 2 at b */
227 /* pick up singleton, if possible */
230 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
231 savep = r = p = q = last;
232 p2 = NEXT(p2) = p2 + (p - b); ++runs;
241 while (q < p) { /* simple pairs */
242 p2 = NEXT(p2) = p2 + 2; ++runs;
249 if (((b = p) == t) && ((t+1) == last)) {
250 NEXT(p2) = p2 + 1; ++runs;
261 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
262 * qsort on many platforms, but slower than qsort, conspicuously so,
263 * on others. The most likely explanation was platform-specific
264 * differences in cache sizes and relative speeds.
266 * The quicksort divide-and-conquer algorithm guarantees that, as the
267 * problem is subdivided into smaller and smaller parts, the parts
268 * fit into smaller (and faster) caches. So it doesn't matter how
269 * many levels of cache exist, quicksort will "find" them, and,
270 * as long as smaller is faster, take advantage of them.
272 * By contrast, consider how the original mergesort algorithm worked.
273 * Suppose we have five runs (each typically of length 2 after dynprep).
282 * Adjacent pairs are merged in "grand sweeps" through the input.
283 * This means, on pass 1, the records in runs 1 and 2 aren't revisited until
284 * runs 3 and 4 are merged and the runs from run 5 have been copied.
285 * The only cache that matters is one large enough to hold *all* the input.
286 * On some platforms, this may be many times slower than smaller caches.
288 * The following pseudo-code uses the same basic merge algorithm,
289 * but in a divide-and-conquer way.
291 * # merge $runs runs at offset $offset of list $list1 into $list2.
292 * # all unmerged runs ($runs == 1) originate in list $base.
294 * my ($offset, $runs, $base, $list1, $list2) = @_;
297 * if ($list1 is $base) copy run to $list2
298 * return offset of end of list (or copy)
300 * $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1)
301 * mgsort2($off2, $runs/2, $base, $list2, $list1)
302 * merge the adjacent runs at $offset of $list1 into $list2
303 * return the offset of the end of the merged runs
306 * mgsort2(0, $runs, $base, $aux, $base);
308 * For our 5 runs, the tree of calls looks like
317 * and the corresponding activity looks like
319 * copy runs 1 and 2 from base to aux
320 * merge runs 1 and 2 from aux to base
321 * (run 3 is where it belongs, no copy needed)
322 * merge runs 12 and 3 from base to aux
323 * (runs 4 and 5 are where they belong, no copy needed)
324 * merge runs 4 and 5 from base to aux
325 * merge runs 123 and 45 from aux to base
327 * Note that we merge runs 1 and 2 immediately after copying them,
328 * while they are still likely to be in fast cache. Similarly,
329 * run 3 is merged with run 12 while it still may be lingering in cache.
330 * This implementation should therefore enjoy much of the cache-friendly
331 * behavior that quicksort does. In addition, it does less copying
332 * than the original mergesort implementation (only runs 1 and 2 are copied)
333 * and the "balancing" of merges is better (merged runs comprise more nearly
334 * equal numbers of original runs).
336 * The actual cache-friendly implementation will use a pseudo-stack
337 * to avoid recursion, and will unroll processing of runs of length 2,
338 * but it is otherwise similar to the recursive implementation.
342 IV offset; /* offset of 1st of 2 runs at this level */
343 IV runs; /* how many runs must be combined into 1 */
344 } off_runs; /* pseudo-stack element */
348 cmp_desc(pTHX_ gptr const a, gptr const b)
350 return -PL_sort_RealCmp(aTHX_ a, b);
354 =for apidoc sortsv_flags
356 In-place sort an array of SV pointers with the given comparison routine,
357 with various SORTf_* flag options.
362 Perl_sortsv_flags(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
366 gptr *f1, *f2, *t, *b, *p;
370 gptr small[SMALLSORT];
372 off_runs stack[60], *stackp;
373 SVCOMPARE_t savecmp = NULL;
375 PERL_ARGS_ASSERT_SORTSV_FLAGS;
376 if (nmemb <= 1) return; /* sorted trivially */
378 if ((flags & SORTf_DESC) != 0) {
379 savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
380 PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
384 if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */
385 else { Newx(aux,nmemb,gptr); } /* allocate auxiliary array */
388 stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
389 stackp->offset = offset = 0;
390 which[0] = which[2] = base;
393 /* On levels where both runs have be constructed (stackp->runs == 0),
394 * merge them, and note the offset of their end, in case the offset
395 * is needed at the next level up. Hop up a level, and,
396 * as long as stackp->runs is 0, keep merging.
398 IV runs = stackp->runs;
402 list1 = which[iwhich]; /* area where runs are now */
403 list2 = which[++iwhich]; /* area for merged runs */
406 offset = stackp->offset;
407 f1 = p1 = list1 + offset; /* start of first run */
408 p = tp2 = list2 + offset; /* where merged run will go */
409 t = NEXT(p); /* where first run ends */
410 f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */
411 t = NEXT(t); /* where second runs ends */
412 l2 = POTHER(t, list2, list1); /* ... on the other side */
413 offset = PNELEM(list2, t);
414 while (f1 < l1 && f2 < l2) {
415 /* If head 1 is larger than head 2, find ALL the elements
416 ** in list 2 strictly less than head1, write them all,
417 ** then head 1. Then compare the new heads, and repeat,
418 ** until one or both lists are exhausted.
420 ** In all comparisons (after establishing
421 ** which head to merge) the item to merge
422 ** (at pointer q) is the first operand of
423 ** the comparison. When we want to know
424 ** if "q is strictly less than the other",
427 ** because stability demands that we treat equality
428 ** as high when q comes from l2, and as low when
429 ** q was from l1. So we ask the question by doing
430 ** cmp(q, other) <= sense
431 ** and make sense == 0 when equality should look low,
432 ** and -1 when equality should look high.
436 if (cmp(aTHX_ *f1, *f2) <= 0) {
437 q = f2; b = f1; t = l1;
440 q = f1; b = f2; t = l2;
447 ** Leave t at something strictly
448 ** greater than q (or at the end of the list),
449 ** and b at something strictly less than q.
451 for (i = 1, run = 0 ;;) {
452 if ((p = PINDEX(b, i)) >= t) {
454 if (((p = PINDEX(t, -1)) > b) &&
455 (cmp(aTHX_ *q, *p) <= sense))
459 } else if (cmp(aTHX_ *q, *p) <= sense) {
463 if (++run >= RTHRESH) i += i;
467 /* q is known to follow b and must be inserted before t.
468 ** Increment b, so the range of possibilities is [b,t).
469 ** Round binary split down, to favor early appearance.
470 ** Adjust b and t until q belongs just before t.
475 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
476 if (cmp(aTHX_ *q, *p) <= sense) {
482 /* Copy all the strictly low elements */
485 FROMTOUPTO(f2, tp2, t);
488 FROMTOUPTO(f1, tp2, t);
494 /* Run out remaining list */
496 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
497 } else FROMTOUPTO(f1, tp2, l1);
498 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
500 if (--level == 0) goto done;
502 t = list1; list1 = list2; list2 = t; /* swap lists */
503 } while ((runs = stackp->runs) == 0);
507 stackp->runs = 0; /* current run will finish level */
508 /* While there are more than 2 runs remaining,
509 * turn them into exactly 2 runs (at the "other" level),
510 * each made up of approximately half the runs.
511 * Stack the second half for later processing,
512 * and set about producing the first half now.
517 stackp->offset = offset;
518 runs -= stackp->runs = runs / 2;
520 /* We must construct a single run from 1 or 2 runs.
521 * All the original runs are in which[0] == base.
522 * The run we construct must end up in which[level&1].
526 /* Constructing a single run from a single run.
527 * If it's where it belongs already, there's nothing to do.
528 * Otherwise, copy it to where it belongs.
529 * A run of 1 is either a singleton at level 0,
530 * or the second half of a split 3. In neither event
531 * is it necessary to set offset. It will be set by the merge
532 * that immediately follows.
534 if (iwhich) { /* Belongs in aux, currently in base */
535 f1 = b = PINDEX(base, offset); /* where list starts */
536 f2 = PINDEX(aux, offset); /* where list goes */
537 t = NEXT(f2); /* where list will end */
538 offset = PNELEM(aux, t); /* offset thereof */
539 t = PINDEX(base, offset); /* where it currently ends */
540 FROMTOUPTO(f1, f2, t); /* copy */
541 NEXT(b) = t; /* set up parallel pointer */
542 } else if (level == 0) goto done; /* single run at level 0 */
544 /* Constructing a single run from two runs.
545 * The merge code at the top will do that.
546 * We need only make sure the two runs are in the "other" array,
547 * so they'll end up in the correct array after the merge.
551 stackp->offset = offset;
552 stackp->runs = 0; /* take care of both runs, trigger merge */
553 if (!iwhich) { /* Merged runs belong in aux, copy 1st */
554 f1 = b = PINDEX(base, offset); /* where first run starts */
555 f2 = PINDEX(aux, offset); /* where it will be copied */
556 t = NEXT(f2); /* where first run will end */
557 offset = PNELEM(aux, t); /* offset thereof */
558 p = PINDEX(base, offset); /* end of first run */
559 t = NEXT(t); /* where second run will end */
560 t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
561 FROMTOUPTO(f1, f2, t); /* copy both runs */
562 NEXT(b) = p; /* paralleled pointer for 1st */
563 NEXT(p) = t; /* ... and for second */
568 if (aux != small) Safefree(aux); /* free iff allocated */
569 if (savecmp != NULL) {
570 PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */
576 * The quicksort implementation was derived from source code contributed
579 * NOTE: this code was derived from Tom Horsley's qsort replacement
580 * and should not be confused with the original code.
583 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
585 Permission granted to distribute under the same terms as perl which are
588 This program is free software; you can redistribute it and/or modify
589 it under the terms of either:
591 a) the GNU General Public License as published by the Free
592 Software Foundation; either version 1, or (at your option) any
595 b) the "Artistic License" which comes with this Kit.
597 Details on the perl license can be found in the perl source code which
598 may be located via the www.perl.com web page.
600 This is the most wonderfulest possible qsort I can come up with (and
601 still be mostly portable) My (limited) tests indicate it consistently
602 does about 20% fewer calls to compare than does the qsort in the Visual
603 C++ library, other vendors may vary.
605 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
606 others I invented myself (or more likely re-invented since they seemed
607 pretty obvious once I watched the algorithm operate for a while).
609 Most of this code was written while watching the Marlins sweep the Giants
610 in the 1997 National League Playoffs - no Braves fans allowed to use this
611 code (just kidding :-).
613 I realize that if I wanted to be true to the perl tradition, the only
614 comment in this file would be something like:
616 ...they shuffled back towards the rear of the line. 'No, not at the
617 rear!' the slave-driver shouted. 'Three files up. And stay there...
619 However, I really needed to violate that tradition just so I could keep
620 track of what happens myself, not to mention some poor fool trying to
621 understand this years from now :-).
624 /* ********************************************************** Configuration */
626 #ifndef QSORT_ORDER_GUESS
627 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
630 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
631 future processing - a good max upper bound is log base 2 of memory size
632 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
633 safely be smaller than that since the program is taking up some space and
634 most operating systems only let you grab some subset of contiguous
635 memory (not to mention that you are normally sorting data larger than
636 1 byte element size :-).
638 #ifndef QSORT_MAX_STACK
639 #define QSORT_MAX_STACK 32
642 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
643 Anything bigger and we use qsort. If you make this too small, the qsort
644 will probably break (or become less efficient), because it doesn't expect
645 the middle element of a partition to be the same as the right or left -
646 you have been warned).
648 #ifndef QSORT_BREAK_EVEN
649 #define QSORT_BREAK_EVEN 6
652 /* QSORT_PLAY_SAFE is the size of the largest partition we're willing
653 to go quadratic on. We innoculate larger partitions against
654 quadratic behavior by shuffling them before sorting. This is not
655 an absolute guarantee of non-quadratic behavior, but it would take
656 staggeringly bad luck to pick extreme elements as the pivot
657 from randomized data.
659 #ifndef QSORT_PLAY_SAFE
660 #define QSORT_PLAY_SAFE 255
663 /* ************************************************************* Data Types */
665 /* hold left and right index values of a partition waiting to be sorted (the
666 partition includes both left and right - right is NOT one past the end or
669 struct partition_stack_entry {
672 #ifdef QSORT_ORDER_GUESS
673 int qsort_break_even;
677 /* ******************************************************* Shorthand Macros */
679 /* Note that these macros will be used from inside the qsort function where
680 we happen to know that the variable 'elt_size' contains the size of an
681 array element and the variable 'temp' points to enough space to hold a
682 temp element and the variable 'array' points to the array being sorted
683 and 'compare' is the pointer to the compare routine.
685 Also note that there are very many highly architecture specific ways
686 these might be sped up, but this is simply the most generally portable
687 code I could think of.
690 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
692 #define qsort_cmp(elt1, elt2) \
693 ((*compare)(aTHX_ array[elt1], array[elt2]))
695 #ifdef QSORT_ORDER_GUESS
696 #define QSORT_NOTICE_SWAP swapped++;
698 #define QSORT_NOTICE_SWAP
701 /* swaps contents of array elements elt1, elt2.
703 #define qsort_swap(elt1, elt2) \
706 temp = array[elt1]; \
707 array[elt1] = array[elt2]; \
708 array[elt2] = temp; \
711 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
712 elt3 and elt3 gets elt1.
714 #define qsort_rotate(elt1, elt2, elt3) \
717 temp = array[elt1]; \
718 array[elt1] = array[elt2]; \
719 array[elt2] = array[elt3]; \
720 array[elt3] = temp; \
723 /* ************************************************************ Debug stuff */
730 return; /* good place to set a breakpoint */
733 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
740 int (*compare)(const void * elt1, const void * elt2),
741 int pc_left, int pc_right, int u_left, int u_right)
745 qsort_assert(pc_left <= pc_right);
746 qsort_assert(u_right < pc_left);
747 qsort_assert(pc_right < u_left);
748 for (i = u_right + 1; i < pc_left; ++i) {
749 qsort_assert(qsort_cmp(i, pc_left) < 0);
751 for (i = pc_left; i < pc_right; ++i) {
752 qsort_assert(qsort_cmp(i, pc_right) == 0);
754 for (i = pc_right + 1; i < u_left; ++i) {
755 qsort_assert(qsort_cmp(pc_right, i) < 0);
759 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
760 doqsort_all_asserts(array, num_elts, elt_size, compare, \
761 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
765 #define qsort_assert(t) ((void)0)
767 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
772 =head1 Array Manipulation Functions
776 In-place sort an array of SV pointers with the given comparison routine.
778 Currently this always uses mergesort. See C<L</sortsv_flags>> for a more
785 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
787 PERL_ARGS_ASSERT_SORTSV;
789 sortsv_flags(array, nmemb, cmp, 0);
792 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
793 #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
794 #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
798 dSP; dMARK; dORIGMARK;
799 SV **p1 = ORIGMARK+1, **p2;
805 OP* const nextop = PL_op->op_next;
807 bool hasargs = FALSE;
810 const U8 priv = PL_op->op_private;
811 const U8 flags = PL_op->op_flags;
813 void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
817 if ((priv & OPpSORT_DESCEND) != 0)
818 sort_flags |= SORTf_DESC;
819 if ((priv & OPpSORT_STABLE) != 0)
820 sort_flags |= SORTf_STABLE;
821 if ((priv & OPpSORT_UNSTABLE) != 0)
822 sort_flags |= SORTf_UNSTABLE;
824 if (gimme != G_ARRAY) {
831 SAVEVPTR(PL_sortcop);
832 if (flags & OPf_STACKED) {
833 if (flags & OPf_SPECIAL) {
834 OP *nullop = OpSIBLING(cLISTOP->op_first); /* pass pushmark */
835 assert(nullop->op_type == OP_NULL);
836 PL_sortcop = nullop->op_next;
841 cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
843 if (cv && SvPOK(cv)) {
844 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
845 if (proto && strEQ(proto, "$$")) {
849 if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
852 else if (!(cv && CvROOT(cv))) {
856 else if (!CvANON(cv) && (gv = CvGV(cv))) {
857 if (cv != GvCV(gv)) cv = GvCV(gv);
860 autogv = gv_autoload_pvn(
861 GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
862 GvNAMEUTF8(gv) ? SVf_UTF8 : 0
869 SV *tmpstr = sv_newmortal();
870 gv_efullname3(tmpstr, gv, NULL);
871 DIE(aTHX_ "Undefined sort subroutine \"%" SVf "\" called",
876 DIE(aTHX_ "Undefined subroutine in sort");
881 PL_sortcop = (OP*)cv;
883 PL_sortcop = CvSTART(cv);
890 /* optimiser converts "@a = sort @a" to "sort \@a". In this case,
891 * push (@a) onto stack, then assign result back to @a at the end of
893 if (priv & OPpSORT_INPLACE) {
894 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
895 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
896 av = MUTABLE_AV((*SP));
898 Perl_croak_no_modify();
899 max = AvFILL(av) + 1;
902 for (i=0; i < max; i++) {
903 SV **svp = av_fetch(av, i, FALSE);
904 *SP++ = (svp) ? *svp : NULL;
908 SV **svp = AvARRAY(av);
909 assert(svp || max == 0);
910 for (i = 0; i < max; i++)
914 p1 = p2 = SP - (max-1);
921 /* shuffle stack down, removing optional initial cv (p1!=p2), plus
922 * any nulls; also stringify or converting to integer or number as
923 * required any args */
924 copytmps = cBOOL(PL_sortcop);
925 for (i=max; i > 0 ; i--) {
926 if ((*p1 = *p2++)) { /* Weed out nulls. */
927 if (copytmps && SvPADTMP(*p1)) {
928 *p1 = sv_mortalcopy(*p1);
932 if (priv & OPpSORT_NUMERIC) {
933 if (priv & OPpSORT_INTEGER) {
935 (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
939 (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
940 if (all_SIVs && !SvSIOK(*p1))
946 (void)sv_2pv_flags(*p1, 0,
947 SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
961 const bool oldcatch = CATCH_GET;
962 I32 old_savestack_ix = PL_savestack_ix;
967 PUSHSTACKi(PERLSI_SORT);
968 if (!hasargs && !is_xsub) {
969 SAVEGENERICSV(PL_firstgv);
970 SAVEGENERICSV(PL_secondgv);
971 PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
972 gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
974 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
975 gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
977 /* make sure the GP isn't removed out from under us for
979 save_gp(PL_firstgv, 0);
980 save_gp(PL_secondgv, 0);
981 /* we don't want modifications localized */
982 GvINTRO_off(PL_firstgv);
983 GvINTRO_off(PL_secondgv);
984 SAVEGENERICSV(GvSV(PL_firstgv));
985 SvREFCNT_inc(GvSV(PL_firstgv));
986 SAVEGENERICSV(GvSV(PL_secondgv));
987 SvREFCNT_inc(GvSV(PL_secondgv));
991 cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix);
992 if (!(flags & OPf_SPECIAL)) {
993 cx->cx_type = CXt_SUB|CXp_MULTICALL;
994 cx_pushsub(cx, cv, NULL, hasargs);
996 PADLIST * const padlist = CvPADLIST(cv);
998 if (++CvDEPTH(cv) >= 2)
999 pad_push(padlist, CvDEPTH(cv));
1000 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1003 /* This is mostly copied from pp_entersub */
1004 AV * const av = MUTABLE_AV(PAD_SVl(0));
1006 cx->blk_sub.savearray = GvAV(PL_defgv);
1007 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1014 sortsvp(aTHX_ start, max,
1015 (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1018 /* Reset cx, in case the context stack has been reallocated. */
1021 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1024 if (!(flags & OPf_SPECIAL)) {
1025 assert(CxTYPE(cx) == CXt_SUB);
1029 assert(CxTYPE(cx) == CXt_NULL);
1030 /* there isn't a POPNULL ! */
1035 CATCH_SET(oldcatch);
1038 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1040 sortsvp(aTHX_ start, max,
1041 (priv & OPpSORT_NUMERIC)
1042 ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1043 ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1044 : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1046 #ifdef USE_LOCALE_COLLATE
1047 IN_LC_RUNTIME(LC_COLLATE)
1049 ? (SVCOMPARE_t)S_amagic_cmp_locale
1050 : (SVCOMPARE_t)sv_cmp_locale_static)
1053 ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1056 if ((priv & OPpSORT_REVERSE) != 0) {
1057 SV **q = start+max-1;
1059 SV * const tmp = *start;
1067 /* copy back result to the array */
1068 SV** const base = MARK+1;
1069 if (SvMAGICAL(av)) {
1070 for (i = 0; i < max; i++)
1071 base[i] = newSVsv(base[i]);
1074 for (i=0; i < max; i++) {
1075 SV * const sv = base[i];
1076 SV ** const didstore = av_store(av, i, sv);
1084 /* the elements of av are likely to be the same as the
1085 * (non-refcounted) elements on the stack, just in a different
1086 * order. However, its possible that someone's messed with av
1087 * in the meantime. So bump and unbump the relevant refcounts
1090 for (i = 0; i < max; i++) {
1093 if (SvREFCNT(sv) > 1)
1094 base[i] = newSVsv(sv);
1096 SvREFCNT_inc_simple_void_NN(sv);
1104 Copy(base, AvARRAY(av), max, SV*);
1106 AvFILLp(av) = max - 1;
1112 PL_stack_sp = ORIGMARK + max;
1117 S_sortcv(pTHX_ SV *const a, SV *const b)
1119 const I32 oldsaveix = PL_savestack_ix;
1121 PMOP * const pm = PL_curpm;
1122 COP * const cop = PL_curcop;
1125 PERL_ARGS_ASSERT_SORTCV;
1127 olda = GvSV(PL_firstgv);
1128 GvSV(PL_firstgv) = SvREFCNT_inc_simple_NN(a);
1130 oldb = GvSV(PL_secondgv);
1131 GvSV(PL_secondgv) = SvREFCNT_inc_simple_NN(b);
1133 PL_stack_sp = PL_stack_base;
1137 /* entry zero of a stack is always PL_sv_undef, which
1138 * simplifies converting a '()' return into undef in scalar context */
1139 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1140 result = SvIV(*PL_stack_sp);
1142 LEAVE_SCOPE(oldsaveix);
1148 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1150 const I32 oldsaveix = PL_savestack_ix;
1152 AV * const av = GvAV(PL_defgv);
1153 PMOP * const pm = PL_curpm;
1154 COP * const cop = PL_curcop;
1156 PERL_ARGS_ASSERT_SORTCV_STACKED;
1163 if (AvMAX(av) < 1) {
1164 SV **ary = AvALLOC(av);
1165 if (AvARRAY(av) != ary) {
1166 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1169 if (AvMAX(av) < 1) {
1180 PL_stack_sp = PL_stack_base;
1184 /* entry zero of a stack is always PL_sv_undef, which
1185 * simplifies converting a '()' return into undef in scalar context */
1186 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1187 result = SvIV(*PL_stack_sp);
1189 LEAVE_SCOPE(oldsaveix);
1195 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1198 const I32 oldsaveix = PL_savestack_ix;
1199 CV * const cv=MUTABLE_CV(PL_sortcop);
1201 PMOP * const pm = PL_curpm;
1203 PERL_ARGS_ASSERT_SORTCV_XSUB;
1211 (void)(*CvXSUB(cv))(aTHX_ cv);
1212 /* entry zero of a stack is always PL_sv_undef, which
1213 * simplifies converting a '()' return into undef in scalar context */
1214 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1215 result = SvIV(*PL_stack_sp);
1217 LEAVE_SCOPE(oldsaveix);
1224 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1226 I32 cmp = do_ncmp(a, b);
1228 PERL_ARGS_ASSERT_SV_NCMP;
1231 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1239 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1241 const IV iv1 = SvIV(a);
1242 const IV iv2 = SvIV(b);
1244 PERL_ARGS_ASSERT_SV_I_NCMP;
1246 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1249 #define tryCALL_AMAGICbin(left,right,meth) \
1250 (SvAMAGIC(left)||SvAMAGIC(right)) \
1251 ? amagic_call(left, right, meth, 0) \
1254 #define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
1257 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1259 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1261 PERL_ARGS_ASSERT_AMAGIC_NCMP;
1265 const I32 i = SvIVX(tmpsv);
1266 return SORT_NORMAL_RETURN_VALUE(i);
1269 const NV d = SvNV(tmpsv);
1270 return SORT_NORMAL_RETURN_VALUE(d);
1273 return S_sv_ncmp(aTHX_ a, b);
1277 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1279 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1281 PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1285 const I32 i = SvIVX(tmpsv);
1286 return SORT_NORMAL_RETURN_VALUE(i);
1289 const NV d = SvNV(tmpsv);
1290 return SORT_NORMAL_RETURN_VALUE(d);
1293 return S_sv_i_ncmp(aTHX_ a, b);
1297 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1299 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1301 PERL_ARGS_ASSERT_AMAGIC_CMP;
1305 const I32 i = SvIVX(tmpsv);
1306 return SORT_NORMAL_RETURN_VALUE(i);
1309 const NV d = SvNV(tmpsv);
1310 return SORT_NORMAL_RETURN_VALUE(d);
1313 return sv_cmp(str1, str2);
1316 #ifdef USE_LOCALE_COLLATE
1319 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1321 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1323 PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1327 const I32 i = SvIVX(tmpsv);
1328 return SORT_NORMAL_RETURN_VALUE(i);
1331 const NV d = SvNV(tmpsv);
1332 return SORT_NORMAL_RETURN_VALUE(d);
1335 return sv_cmp_locale(str1, str2);
1341 * ex: set ts=8 sts=4 sw=4 et: