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
49 #define SORTf_UNSTABLE 8
52 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
54 * The original code was written in conjunction with BSD Computer Software
55 * Research Group at University of California, Berkeley.
57 * See also: "Optimistic Sorting and Information Theoretic Complexity"
59 * SODA (Fourth Annual ACM-SIAM Symposium on Discrete Algorithms),
60 * pp 467-474, Austin, Texas, 25-27 January 1993.
62 * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
64 * The code can be distributed under the same terms as Perl itself.
69 typedef char * aptr; /* pointer for arithmetic on sizes */
70 typedef SV * gptr; /* pointers in our lists */
72 /* Binary merge internal sort, with a few special mods
73 ** for the special perl environment it now finds itself in.
75 ** Things that were once options have been hotwired
76 ** to values suitable for this use. In particular, we'll always
77 ** initialize looking for natural runs, we'll always produce stable
78 ** output, and we'll always do Peter McIlroy's binary merge.
81 /* Pointer types for arithmetic and storage and convenience casts */
83 #define APTR(P) ((aptr)(P))
84 #define GPTP(P) ((gptr *)(P))
85 #define GPPP(P) ((gptr **)(P))
88 /* byte offset from pointer P to (larger) pointer Q */
89 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
91 #define PSIZE sizeof(gptr)
93 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
96 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
97 #define PNBYTE(N) ((N) << (PSHIFT))
98 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
100 /* Leave optimization to compiler */
101 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
102 #define PNBYTE(N) ((N) * (PSIZE))
103 #define PINDEX(P, N) (GPTP(P) + (N))
106 /* Pointer into other corresponding to pointer into this */
107 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
109 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
112 /* Runs are identified by a pointer in the auxiliary list.
113 ** The pointer is at the start of the list,
114 ** and it points to the start of the next list.
115 ** NEXT is used as an lvalue, too.
118 #define NEXT(P) (*GPPP(P))
121 /* PTHRESH is the minimum number of pairs with the same sense to justify
122 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
123 ** not just elements, so PTHRESH == 8 means a run of 16.
128 /* RTHRESH is the number of elements in a run that must compare low
129 ** to the low element from the opposing run before we justify
130 ** doing a binary rampup instead of single stepping.
131 ** In random input, N in a row low should only happen with
132 ** probability 2^(1-N), so we can risk that we are dealing
133 ** with orderly input without paying much when we aren't.
140 ** Overview of algorithm and variables.
141 ** The array of elements at list1 will be organized into runs of length 2,
142 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
143 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
145 ** Unless otherwise specified, pair pointers address the first of two elements.
147 ** b and b+1 are a pair that compare with sense "sense".
148 ** b is the "bottom" of adjacent pairs that might form a longer run.
150 ** p2 parallels b in the list2 array, where runs are defined by
153 ** t represents the "top" of the adjacent pairs that might extend
154 ** the run beginning at b. Usually, t addresses a pair
155 ** that compares with opposite sense from (b,b+1).
156 ** However, it may also address a singleton element at the end of list1,
157 ** or it may be equal to "last", the first element beyond list1.
159 ** r addresses the Nth pair following b. If this would be beyond t,
160 ** we back it off to t. Only when r is less than t do we consider the
161 ** run long enough to consider checking.
163 ** q addresses a pair such that the pairs at b through q already form a run.
164 ** Often, q will equal b, indicating we only are sure of the pair itself.
165 ** However, a search on the previous cycle may have revealed a longer run,
166 ** so q may be greater than b.
168 ** p is used to work back from a candidate r, trying to reach q,
169 ** which would mean b through r would be a run. If we discover such a run,
170 ** we start q at r and try to push it further towards t.
171 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
172 ** In any event, after the check (if any), we have two main cases.
174 ** 1) Short run. b <= q < p <= r <= t.
175 ** b through q is a run (perhaps trivial)
176 ** q through p are uninteresting pairs
177 ** p through r is a run
179 ** 2) Long run. b < r <= q < t.
180 ** b through q is a run (of length >= 2 * PTHRESH)
182 ** Note that degenerate cases are not only possible, but likely.
183 ** For example, if the pair following b compares with opposite sense,
184 ** then b == q < p == r == t.
189 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
192 gptr *b, *p, *q, *t, *p2;
197 last = PINDEX(b, nmemb);
198 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
199 for (p2 = list2; b < last; ) {
200 /* We just started, or just reversed sense.
201 ** Set t at end of pairs with the prevailing sense.
203 for (p = b+2, t = p; ++p < last; t = ++p) {
204 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
207 /* Having laid out the playing field, look for long runs */
209 p = r = b + (2 * PTHRESH);
210 if (r >= t) p = r = t; /* too short to care about */
212 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
215 /* b through r is a (long) run.
216 ** Extend it as far as possible.
219 while (((p += 2) < t) &&
220 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
221 r = p = q + 2; /* no simple pairs, no after-run */
224 if (q > b) { /* run of greater than 2 at b */
228 /* pick up singleton, if possible */
231 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
232 savep = r = p = q = last;
233 p2 = NEXT(p2) = p2 + (p - b); ++runs;
242 while (q < p) { /* simple pairs */
243 p2 = NEXT(p2) = p2 + 2; ++runs;
250 if (((b = p) == t) && ((t+1) == last)) {
251 NEXT(p2) = p2 + 1; ++runs;
262 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
263 * qsort on many platforms, but slower than qsort, conspicuously so,
264 * on others. The most likely explanation was platform-specific
265 * differences in cache sizes and relative speeds.
267 * The quicksort divide-and-conquer algorithm guarantees that, as the
268 * problem is subdivided into smaller and smaller parts, the parts
269 * fit into smaller (and faster) caches. So it doesn't matter how
270 * many levels of cache exist, quicksort will "find" them, and,
271 * as long as smaller is faster, take advantage of them.
273 * By contrast, consider how the original mergesort algorithm worked.
274 * Suppose we have five runs (each typically of length 2 after dynprep).
283 * Adjacent pairs are merged in "grand sweeps" through the input.
284 * This means, on pass 1, the records in runs 1 and 2 aren't revisited until
285 * runs 3 and 4 are merged and the runs from run 5 have been copied.
286 * The only cache that matters is one large enough to hold *all* the input.
287 * On some platforms, this may be many times slower than smaller caches.
289 * The following pseudo-code uses the same basic merge algorithm,
290 * but in a divide-and-conquer way.
292 * # merge $runs runs at offset $offset of list $list1 into $list2.
293 * # all unmerged runs ($runs == 1) originate in list $base.
295 * my ($offset, $runs, $base, $list1, $list2) = @_;
298 * if ($list1 is $base) copy run to $list2
299 * return offset of end of list (or copy)
301 * $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1)
302 * mgsort2($off2, $runs/2, $base, $list2, $list1)
303 * merge the adjacent runs at $offset of $list1 into $list2
304 * return the offset of the end of the merged runs
307 * mgsort2(0, $runs, $base, $aux, $base);
309 * For our 5 runs, the tree of calls looks like
318 * and the corresponding activity looks like
320 * copy runs 1 and 2 from base to aux
321 * merge runs 1 and 2 from aux to base
322 * (run 3 is where it belongs, no copy needed)
323 * merge runs 12 and 3 from base to aux
324 * (runs 4 and 5 are where they belong, no copy needed)
325 * merge runs 4 and 5 from base to aux
326 * merge runs 123 and 45 from aux to base
328 * Note that we merge runs 1 and 2 immediately after copying them,
329 * while they are still likely to be in fast cache. Similarly,
330 * run 3 is merged with run 12 while it still may be lingering in cache.
331 * This implementation should therefore enjoy much of the cache-friendly
332 * behavior that quicksort does. In addition, it does less copying
333 * than the original mergesort implementation (only runs 1 and 2 are copied)
334 * and the "balancing" of merges is better (merged runs comprise more nearly
335 * equal numbers of original runs).
337 * The actual cache-friendly implementation will use a pseudo-stack
338 * to avoid recursion, and will unroll processing of runs of length 2,
339 * but it is otherwise similar to the recursive implementation.
343 IV offset; /* offset of 1st of 2 runs at this level */
344 IV runs; /* how many runs must be combined into 1 */
345 } off_runs; /* pseudo-stack element */
349 cmp_desc(pTHX_ gptr const a, gptr const b)
351 return -PL_sort_RealCmp(aTHX_ a, b);
355 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
359 gptr *f1, *f2, *t, *b, *p;
363 gptr small[SMALLSORT];
365 off_runs stack[60], *stackp;
366 SVCOMPARE_t savecmp = NULL;
368 if (nmemb <= 1) return; /* sorted trivially */
370 if ((flags & SORTf_DESC) != 0) {
371 savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
372 PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
376 if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */
377 else { Newx(aux,nmemb,gptr); } /* allocate auxiliary array */
380 stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
381 stackp->offset = offset = 0;
382 which[0] = which[2] = base;
385 /* On levels where both runs have be constructed (stackp->runs == 0),
386 * merge them, and note the offset of their end, in case the offset
387 * is needed at the next level up. Hop up a level, and,
388 * as long as stackp->runs is 0, keep merging.
390 IV runs = stackp->runs;
394 list1 = which[iwhich]; /* area where runs are now */
395 list2 = which[++iwhich]; /* area for merged runs */
398 offset = stackp->offset;
399 f1 = p1 = list1 + offset; /* start of first run */
400 p = tp2 = list2 + offset; /* where merged run will go */
401 t = NEXT(p); /* where first run ends */
402 f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */
403 t = NEXT(t); /* where second runs ends */
404 l2 = POTHER(t, list2, list1); /* ... on the other side */
405 offset = PNELEM(list2, t);
406 while (f1 < l1 && f2 < l2) {
407 /* If head 1 is larger than head 2, find ALL the elements
408 ** in list 2 strictly less than head1, write them all,
409 ** then head 1. Then compare the new heads, and repeat,
410 ** until one or both lists are exhausted.
412 ** In all comparisons (after establishing
413 ** which head to merge) the item to merge
414 ** (at pointer q) is the first operand of
415 ** the comparison. When we want to know
416 ** if "q is strictly less than the other",
419 ** because stability demands that we treat equality
420 ** as high when q comes from l2, and as low when
421 ** q was from l1. So we ask the question by doing
422 ** cmp(q, other) <= sense
423 ** and make sense == 0 when equality should look low,
424 ** and -1 when equality should look high.
428 if (cmp(aTHX_ *f1, *f2) <= 0) {
429 q = f2; b = f1; t = l1;
432 q = f1; b = f2; t = l2;
439 ** Leave t at something strictly
440 ** greater than q (or at the end of the list),
441 ** and b at something strictly less than q.
443 for (i = 1, run = 0 ;;) {
444 if ((p = PINDEX(b, i)) >= t) {
446 if (((p = PINDEX(t, -1)) > b) &&
447 (cmp(aTHX_ *q, *p) <= sense))
451 } else if (cmp(aTHX_ *q, *p) <= sense) {
455 if (++run >= RTHRESH) i += i;
459 /* q is known to follow b and must be inserted before t.
460 ** Increment b, so the range of possibilities is [b,t).
461 ** Round binary split down, to favor early appearance.
462 ** Adjust b and t until q belongs just before t.
467 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
468 if (cmp(aTHX_ *q, *p) <= sense) {
474 /* Copy all the strictly low elements */
477 FROMTOUPTO(f2, tp2, t);
480 FROMTOUPTO(f1, tp2, t);
486 /* Run out remaining list */
488 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
489 } else FROMTOUPTO(f1, tp2, l1);
490 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
492 if (--level == 0) goto done;
494 t = list1; list1 = list2; list2 = t; /* swap lists */
495 } while ((runs = stackp->runs) == 0);
499 stackp->runs = 0; /* current run will finish level */
500 /* While there are more than 2 runs remaining,
501 * turn them into exactly 2 runs (at the "other" level),
502 * each made up of approximately half the runs.
503 * Stack the second half for later processing,
504 * and set about producing the first half now.
509 stackp->offset = offset;
510 runs -= stackp->runs = runs / 2;
512 /* We must construct a single run from 1 or 2 runs.
513 * All the original runs are in which[0] == base.
514 * The run we construct must end up in which[level&1].
518 /* Constructing a single run from a single run.
519 * If it's where it belongs already, there's nothing to do.
520 * Otherwise, copy it to where it belongs.
521 * A run of 1 is either a singleton at level 0,
522 * or the second half of a split 3. In neither event
523 * is it necessary to set offset. It will be set by the merge
524 * that immediately follows.
526 if (iwhich) { /* Belongs in aux, currently in base */
527 f1 = b = PINDEX(base, offset); /* where list starts */
528 f2 = PINDEX(aux, offset); /* where list goes */
529 t = NEXT(f2); /* where list will end */
530 offset = PNELEM(aux, t); /* offset thereof */
531 t = PINDEX(base, offset); /* where it currently ends */
532 FROMTOUPTO(f1, f2, t); /* copy */
533 NEXT(b) = t; /* set up parallel pointer */
534 } else if (level == 0) goto done; /* single run at level 0 */
536 /* Constructing a single run from two runs.
537 * The merge code at the top will do that.
538 * We need only make sure the two runs are in the "other" array,
539 * so they'll end up in the correct array after the merge.
543 stackp->offset = offset;
544 stackp->runs = 0; /* take care of both runs, trigger merge */
545 if (!iwhich) { /* Merged runs belong in aux, copy 1st */
546 f1 = b = PINDEX(base, offset); /* where first run starts */
547 f2 = PINDEX(aux, offset); /* where it will be copied */
548 t = NEXT(f2); /* where first run will end */
549 offset = PNELEM(aux, t); /* offset thereof */
550 p = PINDEX(base, offset); /* end of first run */
551 t = NEXT(t); /* where second run will end */
552 t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
553 FROMTOUPTO(f1, f2, t); /* copy both runs */
554 NEXT(b) = p; /* paralleled pointer for 1st */
555 NEXT(p) = t; /* ... and for second */
560 if (aux != small) Safefree(aux); /* free iff allocated */
561 if (savecmp != NULL) {
562 PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */
568 * The quicksort implementation was derived from source code contributed
571 * NOTE: this code was derived from Tom Horsley's qsort replacement
572 * and should not be confused with the original code.
575 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
577 Permission granted to distribute under the same terms as perl which are
580 This program is free software; you can redistribute it and/or modify
581 it under the terms of either:
583 a) the GNU General Public License as published by the Free
584 Software Foundation; either version 1, or (at your option) any
587 b) the "Artistic License" which comes with this Kit.
589 Details on the perl license can be found in the perl source code which
590 may be located via the www.perl.com web page.
592 This is the most wonderfulest possible qsort I can come up with (and
593 still be mostly portable) My (limited) tests indicate it consistently
594 does about 20% fewer calls to compare than does the qsort in the Visual
595 C++ library, other vendors may vary.
597 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
598 others I invented myself (or more likely re-invented since they seemed
599 pretty obvious once I watched the algorithm operate for a while).
601 Most of this code was written while watching the Marlins sweep the Giants
602 in the 1997 National League Playoffs - no Braves fans allowed to use this
603 code (just kidding :-).
605 I realize that if I wanted to be true to the perl tradition, the only
606 comment in this file would be something like:
608 ...they shuffled back towards the rear of the line. 'No, not at the
609 rear!' the slave-driver shouted. 'Three files up. And stay there...
611 However, I really needed to violate that tradition just so I could keep
612 track of what happens myself, not to mention some poor fool trying to
613 understand this years from now :-).
616 /* ********************************************************** Configuration */
618 #ifndef QSORT_ORDER_GUESS
619 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
622 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
623 future processing - a good max upper bound is log base 2 of memory size
624 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
625 safely be smaller than that since the program is taking up some space and
626 most operating systems only let you grab some subset of contiguous
627 memory (not to mention that you are normally sorting data larger than
628 1 byte element size :-).
630 #ifndef QSORT_MAX_STACK
631 #define QSORT_MAX_STACK 32
634 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
635 Anything bigger and we use qsort. If you make this too small, the qsort
636 will probably break (or become less efficient), because it doesn't expect
637 the middle element of a partition to be the same as the right or left -
638 you have been warned).
640 #ifndef QSORT_BREAK_EVEN
641 #define QSORT_BREAK_EVEN 6
644 /* QSORT_PLAY_SAFE is the size of the largest partition we're willing
645 to go quadratic on. We innoculate larger partitions against
646 quadratic behavior by shuffling them before sorting. This is not
647 an absolute guarantee of non-quadratic behavior, but it would take
648 staggeringly bad luck to pick extreme elements as the pivot
649 from randomized data.
651 #ifndef QSORT_PLAY_SAFE
652 #define QSORT_PLAY_SAFE 255
655 /* ************************************************************* Data Types */
657 /* hold left and right index values of a partition waiting to be sorted (the
658 partition includes both left and right - right is NOT one past the end or
661 struct partition_stack_entry {
664 #ifdef QSORT_ORDER_GUESS
665 int qsort_break_even;
669 /* ******************************************************* Shorthand Macros */
671 /* Note that these macros will be used from inside the qsort function where
672 we happen to know that the variable 'elt_size' contains the size of an
673 array element and the variable 'temp' points to enough space to hold a
674 temp element and the variable 'array' points to the array being sorted
675 and 'compare' is the pointer to the compare routine.
677 Also note that there are very many highly architecture specific ways
678 these might be sped up, but this is simply the most generally portable
679 code I could think of.
682 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
684 #define qsort_cmp(elt1, elt2) \
685 ((*compare)(aTHX_ array[elt1], array[elt2]))
687 #ifdef QSORT_ORDER_GUESS
688 #define QSORT_NOTICE_SWAP swapped++;
690 #define QSORT_NOTICE_SWAP
693 /* swaps contents of array elements elt1, elt2.
695 #define qsort_swap(elt1, elt2) \
698 temp = array[elt1]; \
699 array[elt1] = array[elt2]; \
700 array[elt2] = temp; \
703 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
704 elt3 and elt3 gets elt1.
706 #define qsort_rotate(elt1, elt2, elt3) \
709 temp = array[elt1]; \
710 array[elt1] = array[elt2]; \
711 array[elt2] = array[elt3]; \
712 array[elt3] = temp; \
715 /* ************************************************************ Debug stuff */
722 return; /* good place to set a breakpoint */
725 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
732 int (*compare)(const void * elt1, const void * elt2),
733 int pc_left, int pc_right, int u_left, int u_right)
737 qsort_assert(pc_left <= pc_right);
738 qsort_assert(u_right < pc_left);
739 qsort_assert(pc_right < u_left);
740 for (i = u_right + 1; i < pc_left; ++i) {
741 qsort_assert(qsort_cmp(i, pc_left) < 0);
743 for (i = pc_left; i < pc_right; ++i) {
744 qsort_assert(qsort_cmp(i, pc_right) == 0);
746 for (i = pc_right + 1; i < u_left; ++i) {
747 qsort_assert(qsort_cmp(pc_right, i) < 0);
751 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
752 doqsort_all_asserts(array, num_elts, elt_size, compare, \
753 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
757 #define qsort_assert(t) ((void)0)
759 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
763 /* ****************************************************************** qsort */
765 STATIC void /* the standard unstable (u) quicksort (qsort) */
766 S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
769 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
770 int next_stack_entry = 0;
773 #ifdef QSORT_ORDER_GUESS
774 int qsort_break_even;
778 PERL_ARGS_ASSERT_QSORTSVU;
780 /* Make sure we actually have work to do.
786 /* Inoculate large partitions against quadratic behavior */
787 if (num_elts > QSORT_PLAY_SAFE) {
789 SV ** const q = array;
790 for (n = num_elts; n > 1; ) {
791 const size_t j = (size_t)(n-- * Perl_internal_drand48());
798 /* Setup the initial partition definition and fall into the sorting loop
801 part_right = (int)(num_elts - 1);
802 #ifdef QSORT_ORDER_GUESS
803 qsort_break_even = QSORT_BREAK_EVEN;
805 #define qsort_break_even QSORT_BREAK_EVEN
808 if ((part_right - part_left) >= qsort_break_even) {
809 /* OK, this is gonna get hairy, so lets try to document all the
810 concepts and abbreviations and variables and what they keep
813 pc: pivot chunk - the set of array elements we accumulate in the
814 middle of the partition, all equal in value to the original
815 pivot element selected. The pc is defined by:
817 pc_left - the leftmost array index of the pc
818 pc_right - the rightmost array index of the pc
820 we start with pc_left == pc_right and only one element
821 in the pivot chunk (but it can grow during the scan).
823 u: uncompared elements - the set of elements in the partition
824 we have not yet compared to the pivot value. There are two
825 uncompared sets during the scan - one to the left of the pc
826 and one to the right.
828 u_right - the rightmost index of the left side's uncompared set
829 u_left - the leftmost index of the right side's uncompared set
831 The leftmost index of the left sides's uncompared set
832 doesn't need its own variable because it is always defined
833 by the leftmost edge of the whole partition (part_left). The
834 same goes for the rightmost edge of the right partition
837 We know there are no uncompared elements on the left once we
838 get u_right < part_left and no uncompared elements on the
839 right once u_left > part_right. When both these conditions
840 are met, we have completed the scan of the partition.
842 Any elements which are between the pivot chunk and the
843 uncompared elements should be less than the pivot value on
844 the left side and greater than the pivot value on the right
845 side (in fact, the goal of the whole algorithm is to arrange
846 for that to be true and make the groups of less-than and
847 greater-then elements into new partitions to sort again).
849 As you marvel at the complexity of the code and wonder why it
850 has to be so confusing. Consider some of the things this level
853 Once I do a compare, I squeeze every ounce of juice out of it. I
854 never do compare calls I don't have to do, and I certainly never
857 I also never swap any elements unless I can prove there is a
858 good reason. Many sort algorithms will swap a known value with
859 an uncompared value just to get things in the right place (or
860 avoid complexity :-), but that uncompared value, once it gets
861 compared, may then have to be swapped again. A lot of the
862 complexity of this code is due to the fact that it never swaps
863 anything except compared values, and it only swaps them when the
864 compare shows they are out of position.
866 int pc_left, pc_right;
871 pc_left = ((part_left + part_right) / 2);
873 u_right = pc_left - 1;
874 u_left = pc_right + 1;
876 /* Qsort works best when the pivot value is also the median value
877 in the partition (unfortunately you can't find the median value
878 without first sorting :-), so to give the algorithm a helping
879 hand, we pick 3 elements and sort them and use the median value
880 of that tiny set as the pivot value.
882 Some versions of qsort like to use the left middle and right as
883 the 3 elements to sort so they can insure the ends of the
884 partition will contain values which will stop the scan in the
885 compare loop, but when you have to call an arbitrarily complex
886 routine to do a compare, its really better to just keep track of
887 array index values to know when you hit the edge of the
888 partition and avoid the extra compare. An even better reason to
889 avoid using a compare call is the fact that you can drop off the
890 edge of the array if someone foolishly provides you with an
891 unstable compare function that doesn't always provide consistent
894 So, since it is simpler for us to compare the three adjacent
895 elements in the middle of the partition, those are the ones we
896 pick here (conveniently pointed at by u_right, pc_left, and
897 u_left). The values of the left, center, and right elements
898 are referred to as l c and r in the following comments.
901 #ifdef QSORT_ORDER_GUESS
904 s = qsort_cmp(u_right, pc_left);
907 s = qsort_cmp(pc_left, u_left);
908 /* if l < c, c < r - already in order - nothing to do */
910 /* l < c, c == r - already in order, pc grows */
912 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
914 /* l < c, c > r - need to know more */
915 s = qsort_cmp(u_right, u_left);
917 /* l < c, c > r, l < r - swap c & r to get ordered */
918 qsort_swap(pc_left, u_left);
919 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
921 /* l < c, c > r, l == r - swap c&r, grow pc */
922 qsort_swap(pc_left, u_left);
924 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
926 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
927 qsort_rotate(pc_left, u_right, u_left);
928 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
933 s = qsort_cmp(pc_left, u_left);
935 /* l == c, c < r - already in order, grow pc */
937 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
939 /* l == c, c == r - already in order, grow pc both ways */
942 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
944 /* l == c, c > r - swap l & r, grow pc */
945 qsort_swap(u_right, u_left);
947 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
951 s = qsort_cmp(pc_left, u_left);
953 /* l > c, c < r - need to know more */
954 s = qsort_cmp(u_right, u_left);
956 /* l > c, c < r, l < r - swap l & c to get ordered */
957 qsort_swap(u_right, pc_left);
958 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
960 /* l > c, c < r, l == r - swap l & c, grow pc */
961 qsort_swap(u_right, pc_left);
963 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
965 /* l > c, c < r, l > r - rotate lcr into crl to order */
966 qsort_rotate(u_right, pc_left, u_left);
967 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
970 /* l > c, c == r - swap ends, grow pc */
971 qsort_swap(u_right, u_left);
973 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
975 /* l > c, c > r - swap ends to get in order */
976 qsort_swap(u_right, u_left);
977 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
980 /* We now know the 3 middle elements have been compared and
981 arranged in the desired order, so we can shrink the uncompared
986 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
988 /* The above massive nested if was the simple part :-). We now have
989 the middle 3 elements ordered and we need to scan through the
990 uncompared sets on either side, swapping elements that are on
991 the wrong side or simply shuffling equal elements around to get
992 all equal elements into the pivot chunk.
996 int still_work_on_left;
997 int still_work_on_right;
999 /* Scan the uncompared values on the left. If I find a value
1000 equal to the pivot value, move it over so it is adjacent to
1001 the pivot chunk and expand the pivot chunk. If I find a value
1002 less than the pivot value, then just leave it - its already
1003 on the correct side of the partition. If I find a greater
1004 value, then stop the scan.
1006 while ((still_work_on_left = (u_right >= part_left))) {
1007 s = qsort_cmp(u_right, pc_left);
1010 } else if (s == 0) {
1012 if (pc_left != u_right) {
1013 qsort_swap(u_right, pc_left);
1019 qsort_assert(u_right < pc_left);
1020 qsort_assert(pc_left <= pc_right);
1021 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
1022 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1025 /* Do a mirror image scan of uncompared values on the right
1027 while ((still_work_on_right = (u_left <= part_right))) {
1028 s = qsort_cmp(pc_right, u_left);
1031 } else if (s == 0) {
1033 if (pc_right != u_left) {
1034 qsort_swap(pc_right, u_left);
1040 qsort_assert(u_left > pc_right);
1041 qsort_assert(pc_left <= pc_right);
1042 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
1043 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1046 if (still_work_on_left) {
1047 /* I know I have a value on the left side which needs to be
1048 on the right side, but I need to know more to decide
1049 exactly the best thing to do with it.
1051 if (still_work_on_right) {
1052 /* I know I have values on both side which are out of
1053 position. This is a big win because I kill two birds
1054 with one swap (so to speak). I can advance the
1055 uncompared pointers on both sides after swapping both
1056 of them into the right place.
1058 qsort_swap(u_right, u_left);
1061 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
1063 /* I have an out of position value on the left, but the
1064 right is fully scanned, so I "slide" the pivot chunk
1065 and any less-than values left one to make room for the
1066 greater value over on the right. If the out of position
1067 value is immediately adjacent to the pivot chunk (there
1068 are no less-than values), I can do that with a swap,
1069 otherwise, I have to rotate one of the less than values
1070 into the former position of the out of position value
1071 and the right end of the pivot chunk into the left end
1075 if (pc_left == u_right) {
1076 qsort_swap(u_right, pc_right);
1077 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1079 qsort_rotate(u_right, pc_left, pc_right);
1080 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1085 } else if (still_work_on_right) {
1086 /* Mirror image of complex case above: I have an out of
1087 position value on the right, but the left is fully
1088 scanned, so I need to shuffle things around to make room
1089 for the right value on the left.
1092 if (pc_right == u_left) {
1093 qsort_swap(u_left, pc_left);
1094 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1096 qsort_rotate(pc_right, pc_left, u_left);
1097 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1102 /* No more scanning required on either side of partition,
1103 break out of loop and figure out next set of partitions
1109 /* The elements in the pivot chunk are now in the right place. They
1110 will never move or be compared again. All I have to do is decide
1111 what to do with the stuff to the left and right of the pivot
1114 Notes on the QSORT_ORDER_GUESS ifdef code:
1116 1. If I just built these partitions without swapping any (or
1117 very many) elements, there is a chance that the elements are
1118 already ordered properly (being properly ordered will
1119 certainly result in no swapping, but the converse can't be
1122 2. A (properly written) insertion sort will run faster on
1123 already ordered data than qsort will.
1125 3. Perhaps there is some way to make a good guess about
1126 switching to an insertion sort earlier than partition size 6
1127 (for instance - we could save the partition size on the stack
1128 and increase the size each time we find we didn't swap, thus
1129 switching to insertion sort earlier for partitions with a
1130 history of not swapping).
1132 4. Naturally, if I just switch right away, it will make
1133 artificial benchmarks with pure ascending (or descending)
1134 data look really good, but is that a good reason in general?
1138 #ifdef QSORT_ORDER_GUESS
1140 #if QSORT_ORDER_GUESS == 1
1141 qsort_break_even = (part_right - part_left) + 1;
1143 #if QSORT_ORDER_GUESS == 2
1144 qsort_break_even *= 2;
1146 #if QSORT_ORDER_GUESS == 3
1147 const int prev_break = qsort_break_even;
1148 qsort_break_even *= qsort_break_even;
1149 if (qsort_break_even < prev_break) {
1150 qsort_break_even = (part_right - part_left) + 1;
1154 qsort_break_even = QSORT_BREAK_EVEN;
1158 if (part_left < pc_left) {
1159 /* There are elements on the left which need more processing.
1160 Check the right as well before deciding what to do.
1162 if (pc_right < part_right) {
1163 /* We have two partitions to be sorted. Stack the biggest one
1164 and process the smallest one on the next iteration. This
1165 minimizes the stack height by insuring that any additional
1166 stack entries must come from the smallest partition which
1167 (because it is smallest) will have the fewest
1168 opportunities to generate additional stack entries.
1170 if ((part_right - pc_right) > (pc_left - part_left)) {
1171 /* stack the right partition, process the left */
1172 partition_stack[next_stack_entry].left = pc_right + 1;
1173 partition_stack[next_stack_entry].right = part_right;
1174 #ifdef QSORT_ORDER_GUESS
1175 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1177 part_right = pc_left - 1;
1179 /* stack the left partition, process the right */
1180 partition_stack[next_stack_entry].left = part_left;
1181 partition_stack[next_stack_entry].right = pc_left - 1;
1182 #ifdef QSORT_ORDER_GUESS
1183 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1185 part_left = pc_right + 1;
1187 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
1190 /* The elements on the left are the only remaining elements
1191 that need sorting, arrange for them to be processed as the
1194 part_right = pc_left - 1;
1196 } else if (pc_right < part_right) {
1197 /* There is only one chunk on the right to be sorted, make it
1198 the new partition and loop back around.
1200 part_left = pc_right + 1;
1202 /* This whole partition wound up in the pivot chunk, so
1203 we need to get a new partition off the stack.
1205 if (next_stack_entry == 0) {
1206 /* the stack is empty - we are done */
1210 part_left = partition_stack[next_stack_entry].left;
1211 part_right = partition_stack[next_stack_entry].right;
1212 #ifdef QSORT_ORDER_GUESS
1213 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1217 /* This partition is too small to fool with qsort complexity, just
1218 do an ordinary insertion sort to minimize overhead.
1221 /* Assume 1st element is in right place already, and start checking
1222 at 2nd element to see where it should be inserted.
1224 for (i = part_left + 1; i <= part_right; ++i) {
1226 /* Scan (backwards - just in case 'i' is already in right place)
1227 through the elements already sorted to see if the ith element
1228 belongs ahead of one of them.
1230 for (j = i - 1; j >= part_left; --j) {
1231 if (qsort_cmp(i, j) >= 0) {
1232 /* i belongs right after j
1239 /* Looks like we really need to move some things
1243 for (k = i - 1; k >= j; --k)
1244 array[k + 1] = array[k];
1249 /* That partition is now sorted, grab the next one, or get out
1250 of the loop if there aren't any more.
1253 if (next_stack_entry == 0) {
1254 /* the stack is empty - we are done */
1258 part_left = partition_stack[next_stack_entry].left;
1259 part_right = partition_stack[next_stack_entry].right;
1260 #ifdef QSORT_ORDER_GUESS
1261 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1266 /* Believe it or not, the array is sorted at this point! */
1269 /* Stabilize what is, presumably, an otherwise unstable sort method.
1270 * We do that by allocating (or having on hand) an array of pointers
1271 * that is the same size as the original array of elements to be sorted.
1272 * We initialize this parallel array with the addresses of the original
1273 * array elements. This indirection can make you crazy.
1274 * Some pictures can help. After initializing, we have
1278 * | | --------------> | | ------> first element to be sorted
1280 * | | --------------> | | ------> second element to be sorted
1282 * | | --------------> | | ------> third element to be sorted
1286 * | | --------------> | | ------> n-1st element to be sorted
1288 * | | --------------> | | ------> n-th element to be sorted
1291 * During the sort phase, we leave the elements of list1 where they are,
1292 * and sort the pointers in the indirect array in the same order determined
1293 * by the original comparison routine on the elements pointed to.
1294 * Because we don't move the elements of list1 around through
1295 * this phase, we can break ties on elements that compare equal
1296 * using their address in the list1 array, ensuring stability.
1297 * This leaves us with something looking like
1301 * | | --+ +---> | | ------> first element to be sorted
1303 * | | --|-------|---> | | ------> second element to be sorted
1305 * | | --|-------+ +-> | | ------> third element to be sorted
1308 * +----+ | | | | +----+
1309 * | | ---|-+ | +--> | | ------> n-1st element to be sorted
1311 * | | ---+ +----> | | ------> n-th element to be sorted
1314 * where the i-th element of the indirect array points to the element
1315 * that should be i-th in the sorted array. After the sort phase,
1316 * we have to put the elements of list1 into the places
1317 * dictated by the indirect array.
1322 cmpindir(pTHX_ gptr const a, gptr const b)
1324 gptr * const ap = (gptr *)a;
1325 gptr * const bp = (gptr *)b;
1326 const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1330 return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1334 cmpindir_desc(pTHX_ gptr const a, gptr const b)
1336 gptr * const ap = (gptr *)a;
1337 gptr * const bp = (gptr *)b;
1338 const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1340 /* Reverse the default */
1343 /* But don't reverse the stability test. */
1344 return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1349 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1351 if ((flags & SORTf_STABLE) != 0) {
1354 gptr *small[SMALLSORT], **indir, tmp;
1355 SVCOMPARE_t savecmp;
1356 if (nmemb <= 1) return; /* sorted trivially */
1358 /* Small arrays can use the stack, big ones must be allocated */
1359 if (nmemb <= SMALLSORT) indir = small;
1360 else { Newx(indir, nmemb, gptr *); }
1362 /* Copy pointers to original array elements into indirect array */
1363 for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++;
1365 savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
1366 PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
1368 /* sort, with indirection */
1369 if (flags & SORTf_DESC)
1370 qsortsvu((gptr *)indir, nmemb, cmpindir_desc);
1372 qsortsvu((gptr *)indir, nmemb, cmpindir);
1376 for (n = nmemb; n--; ) {
1377 /* Assert A: all elements of q with index > n are already
1378 * in place. This is vacuously true at the start, and we
1379 * put element n where it belongs below (if it wasn't
1380 * already where it belonged). Assert B: we only move
1381 * elements that aren't where they belong,
1382 * so, by A, we never tamper with elements above n.
1384 j = pp[n] - q; /* This sets j so that q[j] is
1385 * at pp[n]. *pp[j] belongs in
1386 * q[j], by construction.
1388 if (n != j) { /* all's well if n == j */
1389 tmp = q[j]; /* save what's in q[j] */
1391 q[j] = *pp[j]; /* put *pp[j] where it belongs */
1392 i = pp[j] - q; /* the index in q of the element
1394 pp[j] = q + j; /* this is ok now */
1395 } while ((j = i) != n);
1396 /* There are only finitely many (nmemb) addresses
1398 * So we must eventually revisit an index we saw before.
1399 * Suppose the first revisited index is k != n.
1400 * An index is visited because something else belongs there.
1401 * If we visit k twice, then two different elements must
1402 * belong in the same place, which cannot be.
1403 * So j must get back to n, the loop terminates,
1404 * and we put the saved element where it belongs.
1406 q[n] = tmp; /* put what belongs into
1407 * the n-th element */
1411 /* free iff allocated */
1412 if (indir != small) { Safefree(indir); }
1413 /* restore prevailing comparison routine */
1414 PL_sort_RealCmp = savecmp;
1415 } else if ((flags & SORTf_DESC) != 0) {
1416 const SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
1417 PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
1419 qsortsvu(list1, nmemb, cmp);
1420 /* restore prevailing comparison routine */
1421 PL_sort_RealCmp = savecmp;
1423 qsortsvu(list1, nmemb, cmp);
1428 =head1 Array Manipulation Functions
1432 In-place sort an array of SV pointers with the given comparison routine.
1434 Currently this always uses mergesort. See C<L</sortsv_flags>> for a more
1441 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1443 PERL_ARGS_ASSERT_SORTSV;
1445 sortsv_flags(array, nmemb, cmp, 0);
1449 =for apidoc sortsv_flags
1451 In-place sort an array of SV pointers with the given comparison routine,
1452 with various SORTf_* flag options.
1457 Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1459 PERL_ARGS_ASSERT_SORTSV_FLAGS;
1461 if (flags & SORTf_QSORT)
1462 S_qsortsv(aTHX_ array, nmemb, cmp, flags);
1464 S_mergesortsv(aTHX_ array, nmemb, cmp, flags);
1467 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
1468 #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
1469 #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
1473 dSP; dMARK; dORIGMARK;
1474 SV **p1 = ORIGMARK+1, **p2;
1480 OP* const nextop = PL_op->op_next;
1481 I32 overloading = 0;
1482 bool hasargs = FALSE;
1485 const U8 priv = PL_op->op_private;
1486 const U8 flags = PL_op->op_flags;
1488 void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1489 = Perl_sortsv_flags;
1492 if ((priv & OPpSORT_DESCEND) != 0)
1493 sort_flags |= SORTf_DESC;
1494 if ((priv & OPpSORT_QSORT) != 0)
1495 sort_flags |= SORTf_QSORT;
1496 if ((priv & OPpSORT_STABLE) != 0)
1497 sort_flags |= SORTf_STABLE;
1498 if ((priv & OPpSORT_UNSTABLE) != 0)
1499 sort_flags |= SORTf_UNSTABLE;
1501 if (gimme != G_ARRAY) {
1508 SAVEVPTR(PL_sortcop);
1509 if (flags & OPf_STACKED) {
1510 if (flags & OPf_SPECIAL) {
1511 OP *nullop = OpSIBLING(cLISTOP->op_first); /* pass pushmark */
1512 assert(nullop->op_type == OP_NULL);
1513 PL_sortcop = nullop->op_next;
1518 cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
1520 if (cv && SvPOK(cv)) {
1521 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
1522 if (proto && strEQ(proto, "$$")) {
1526 if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
1529 else if (!(cv && CvROOT(cv))) {
1533 else if (!CvANON(cv) && (gv = CvGV(cv))) {
1534 if (cv != GvCV(gv)) cv = GvCV(gv);
1537 autogv = gv_autoload_pvn(
1538 GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1539 GvNAMEUTF8(gv) ? SVf_UTF8 : 0
1546 SV *tmpstr = sv_newmortal();
1547 gv_efullname3(tmpstr, gv, NULL);
1548 DIE(aTHX_ "Undefined sort subroutine \"%" SVf "\" called",
1553 DIE(aTHX_ "Undefined subroutine in sort");
1558 PL_sortcop = (OP*)cv;
1560 PL_sortcop = CvSTART(cv);
1567 /* optimiser converts "@a = sort @a" to "sort \@a". In this case,
1568 * push (@a) onto stack, then assign result back to @a at the end of
1570 if (priv & OPpSORT_INPLACE) {
1571 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
1572 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
1573 av = MUTABLE_AV((*SP));
1575 Perl_croak_no_modify();
1576 max = AvFILL(av) + 1;
1578 if (SvMAGICAL(av)) {
1579 for (i=0; i < max; i++) {
1580 SV **svp = av_fetch(av, i, FALSE);
1581 *SP++ = (svp) ? *svp : NULL;
1585 SV **svp = AvARRAY(av);
1586 assert(svp || max == 0);
1587 for (i = 0; i < max; i++)
1591 p1 = p2 = SP - (max-1);
1598 /* shuffle stack down, removing optional initial cv (p1!=p2), plus
1599 * any nulls; also stringify or converting to integer or number as
1600 * required any args */
1601 copytmps = cBOOL(PL_sortcop);
1602 for (i=max; i > 0 ; i--) {
1603 if ((*p1 = *p2++)) { /* Weed out nulls. */
1604 if (copytmps && SvPADTMP(*p1)) {
1605 *p1 = sv_mortalcopy(*p1);
1609 if (priv & OPpSORT_NUMERIC) {
1610 if (priv & OPpSORT_INTEGER) {
1612 (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1616 (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1617 if (all_SIVs && !SvSIOK(*p1))
1623 (void)sv_2pv_flags(*p1, 0,
1624 SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
1638 const bool oldcatch = CATCH_GET;
1639 I32 old_savestack_ix = PL_savestack_ix;
1644 PUSHSTACKi(PERLSI_SORT);
1645 if (!hasargs && !is_xsub) {
1646 SAVEGENERICSV(PL_firstgv);
1647 SAVEGENERICSV(PL_secondgv);
1648 PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
1649 gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
1651 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
1652 gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
1654 /* make sure the GP isn't removed out from under us for
1656 save_gp(PL_firstgv, 0);
1657 save_gp(PL_secondgv, 0);
1658 /* we don't want modifications localized */
1659 GvINTRO_off(PL_firstgv);
1660 GvINTRO_off(PL_secondgv);
1661 SAVESPTR(GvSV(PL_firstgv));
1662 SAVESPTR(GvSV(PL_secondgv));
1666 cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix);
1667 if (!(flags & OPf_SPECIAL)) {
1668 cx->cx_type = CXt_SUB|CXp_MULTICALL;
1669 cx_pushsub(cx, cv, NULL, hasargs);
1671 PADLIST * const padlist = CvPADLIST(cv);
1673 if (++CvDEPTH(cv) >= 2)
1674 pad_push(padlist, CvDEPTH(cv));
1675 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1678 /* This is mostly copied from pp_entersub */
1679 AV * const av = MUTABLE_AV(PAD_SVl(0));
1681 cx->blk_sub.savearray = GvAV(PL_defgv);
1682 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1689 sortsvp(aTHX_ start, max,
1690 (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1693 /* Reset cx, in case the context stack has been reallocated. */
1696 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1699 if (!(flags & OPf_SPECIAL)) {
1700 assert(CxTYPE(cx) == CXt_SUB);
1704 assert(CxTYPE(cx) == CXt_NULL);
1705 /* there isn't a POPNULL ! */
1710 CATCH_SET(oldcatch);
1713 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1715 sortsvp(aTHX_ start, max,
1716 (priv & OPpSORT_NUMERIC)
1717 ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1718 ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1719 : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1721 #ifdef USE_LOCALE_COLLATE
1722 IN_LC_RUNTIME(LC_COLLATE)
1724 ? (SVCOMPARE_t)S_amagic_cmp_locale
1725 : (SVCOMPARE_t)sv_cmp_locale_static)
1728 ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1731 if ((priv & OPpSORT_REVERSE) != 0) {
1732 SV **q = start+max-1;
1734 SV * const tmp = *start;
1742 /* copy back result to the array */
1743 SV** const base = MARK+1;
1744 if (SvMAGICAL(av)) {
1745 for (i = 0; i < max; i++)
1746 base[i] = newSVsv(base[i]);
1749 for (i=0; i < max; i++) {
1750 SV * const sv = base[i];
1751 SV ** const didstore = av_store(av, i, sv);
1759 /* the elements of av are likely to be the same as the
1760 * (non-refcounted) elements on the stack, just in a different
1761 * order. However, its possible that someone's messed with av
1762 * in the meantime. So bump and unbump the relevant refcounts
1765 for (i = 0; i < max; i++) {
1768 if (SvREFCNT(sv) > 1)
1769 base[i] = newSVsv(sv);
1771 SvREFCNT_inc_simple_void_NN(sv);
1779 Copy(base, AvARRAY(av), max, SV*);
1781 AvFILLp(av) = max - 1;
1787 PL_stack_sp = ORIGMARK + max;
1792 S_sortcv(pTHX_ SV *const a, SV *const b)
1794 const I32 oldsaveix = PL_savestack_ix;
1796 PMOP * const pm = PL_curpm;
1797 COP * const cop = PL_curcop;
1799 PERL_ARGS_ASSERT_SORTCV;
1801 GvSV(PL_firstgv) = a;
1802 GvSV(PL_secondgv) = b;
1803 PL_stack_sp = PL_stack_base;
1807 /* entry zero of a stack is always PL_sv_undef, which
1808 * simplifies converting a '()' return into undef in scalar context */
1809 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1810 result = SvIV(*PL_stack_sp);
1812 LEAVE_SCOPE(oldsaveix);
1818 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1820 const I32 oldsaveix = PL_savestack_ix;
1822 AV * const av = GvAV(PL_defgv);
1823 PMOP * const pm = PL_curpm;
1824 COP * const cop = PL_curcop;
1826 PERL_ARGS_ASSERT_SORTCV_STACKED;
1833 if (AvMAX(av) < 1) {
1834 SV **ary = AvALLOC(av);
1835 if (AvARRAY(av) != ary) {
1836 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1839 if (AvMAX(av) < 1) {
1850 PL_stack_sp = PL_stack_base;
1854 /* entry zero of a stack is always PL_sv_undef, which
1855 * simplifies converting a '()' return into undef in scalar context */
1856 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1857 result = SvIV(*PL_stack_sp);
1859 LEAVE_SCOPE(oldsaveix);
1865 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1868 const I32 oldsaveix = PL_savestack_ix;
1869 CV * const cv=MUTABLE_CV(PL_sortcop);
1871 PMOP * const pm = PL_curpm;
1873 PERL_ARGS_ASSERT_SORTCV_XSUB;
1881 (void)(*CvXSUB(cv))(aTHX_ cv);
1882 /* entry zero of a stack is always PL_sv_undef, which
1883 * simplifies converting a '()' return into undef in scalar context */
1884 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1885 result = SvIV(*PL_stack_sp);
1887 LEAVE_SCOPE(oldsaveix);
1894 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1896 I32 cmp = do_ncmp(a, b);
1898 PERL_ARGS_ASSERT_SV_NCMP;
1901 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1909 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1911 const IV iv1 = SvIV(a);
1912 const IV iv2 = SvIV(b);
1914 PERL_ARGS_ASSERT_SV_I_NCMP;
1916 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1919 #define tryCALL_AMAGICbin(left,right,meth) \
1920 (SvAMAGIC(left)||SvAMAGIC(right)) \
1921 ? amagic_call(left, right, meth, 0) \
1924 #define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
1927 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1929 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1931 PERL_ARGS_ASSERT_AMAGIC_NCMP;
1935 const I32 i = SvIVX(tmpsv);
1936 return SORT_NORMAL_RETURN_VALUE(i);
1939 const NV d = SvNV(tmpsv);
1940 return SORT_NORMAL_RETURN_VALUE(d);
1943 return S_sv_ncmp(aTHX_ a, b);
1947 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1949 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1951 PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1955 const I32 i = SvIVX(tmpsv);
1956 return SORT_NORMAL_RETURN_VALUE(i);
1959 const NV d = SvNV(tmpsv);
1960 return SORT_NORMAL_RETURN_VALUE(d);
1963 return S_sv_i_ncmp(aTHX_ a, b);
1967 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1969 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1971 PERL_ARGS_ASSERT_AMAGIC_CMP;
1975 const I32 i = SvIVX(tmpsv);
1976 return SORT_NORMAL_RETURN_VALUE(i);
1979 const NV d = SvNV(tmpsv);
1980 return SORT_NORMAL_RETURN_VALUE(d);
1983 return sv_cmp(str1, str2);
1986 #ifdef USE_LOCALE_COLLATE
1989 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1991 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1993 PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1997 const I32 i = SvIVX(tmpsv);
1998 return SORT_NORMAL_RETURN_VALUE(i);
2001 const NV d = SvNV(tmpsv);
2002 return SORT_NORMAL_RETURN_VALUE(d);
2005 return sv_cmp_locale(str1, str2);
2011 * ex: set ts=8 sts=4 sw=4 et: