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
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 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
358 gptr *f1, *f2, *t, *b, *p;
362 gptr small[SMALLSORT];
364 off_runs stack[60], *stackp;
365 SVCOMPARE_t savecmp = NULL;
367 if (nmemb <= 1) return; /* sorted trivially */
369 if ((flags & SORTf_DESC) != 0) {
370 savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
371 PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
375 if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */
376 else { Newx(aux,nmemb,gptr); } /* allocate auxiliary array */
379 stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
380 stackp->offset = offset = 0;
381 which[0] = which[2] = base;
384 /* On levels where both runs have be constructed (stackp->runs == 0),
385 * merge them, and note the offset of their end, in case the offset
386 * is needed at the next level up. Hop up a level, and,
387 * as long as stackp->runs is 0, keep merging.
389 IV runs = stackp->runs;
393 list1 = which[iwhich]; /* area where runs are now */
394 list2 = which[++iwhich]; /* area for merged runs */
397 offset = stackp->offset;
398 f1 = p1 = list1 + offset; /* start of first run */
399 p = tp2 = list2 + offset; /* where merged run will go */
400 t = NEXT(p); /* where first run ends */
401 f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */
402 t = NEXT(t); /* where second runs ends */
403 l2 = POTHER(t, list2, list1); /* ... on the other side */
404 offset = PNELEM(list2, t);
405 while (f1 < l1 && f2 < l2) {
406 /* If head 1 is larger than head 2, find ALL the elements
407 ** in list 2 strictly less than head1, write them all,
408 ** then head 1. Then compare the new heads, and repeat,
409 ** until one or both lists are exhausted.
411 ** In all comparisons (after establishing
412 ** which head to merge) the item to merge
413 ** (at pointer q) is the first operand of
414 ** the comparison. When we want to know
415 ** if "q is strictly less than the other",
418 ** because stability demands that we treat equality
419 ** as high when q comes from l2, and as low when
420 ** q was from l1. So we ask the question by doing
421 ** cmp(q, other) <= sense
422 ** and make sense == 0 when equality should look low,
423 ** and -1 when equality should look high.
427 if (cmp(aTHX_ *f1, *f2) <= 0) {
428 q = f2; b = f1; t = l1;
431 q = f1; b = f2; t = l2;
438 ** Leave t at something strictly
439 ** greater than q (or at the end of the list),
440 ** and b at something strictly less than q.
442 for (i = 1, run = 0 ;;) {
443 if ((p = PINDEX(b, i)) >= t) {
445 if (((p = PINDEX(t, -1)) > b) &&
446 (cmp(aTHX_ *q, *p) <= sense))
450 } else if (cmp(aTHX_ *q, *p) <= sense) {
454 if (++run >= RTHRESH) i += i;
458 /* q is known to follow b and must be inserted before t.
459 ** Increment b, so the range of possibilities is [b,t).
460 ** Round binary split down, to favor early appearance.
461 ** Adjust b and t until q belongs just before t.
466 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
467 if (cmp(aTHX_ *q, *p) <= sense) {
473 /* Copy all the strictly low elements */
476 FROMTOUPTO(f2, tp2, t);
479 FROMTOUPTO(f1, tp2, t);
485 /* Run out remaining list */
487 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
488 } else FROMTOUPTO(f1, tp2, l1);
489 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
491 if (--level == 0) goto done;
493 t = list1; list1 = list2; list2 = t; /* swap lists */
494 } while ((runs = stackp->runs) == 0);
498 stackp->runs = 0; /* current run will finish level */
499 /* While there are more than 2 runs remaining,
500 * turn them into exactly 2 runs (at the "other" level),
501 * each made up of approximately half the runs.
502 * Stack the second half for later processing,
503 * and set about producing the first half now.
508 stackp->offset = offset;
509 runs -= stackp->runs = runs / 2;
511 /* We must construct a single run from 1 or 2 runs.
512 * All the original runs are in which[0] == base.
513 * The run we construct must end up in which[level&1].
517 /* Constructing a single run from a single run.
518 * If it's where it belongs already, there's nothing to do.
519 * Otherwise, copy it to where it belongs.
520 * A run of 1 is either a singleton at level 0,
521 * or the second half of a split 3. In neither event
522 * is it necessary to set offset. It will be set by the merge
523 * that immediately follows.
525 if (iwhich) { /* Belongs in aux, currently in base */
526 f1 = b = PINDEX(base, offset); /* where list starts */
527 f2 = PINDEX(aux, offset); /* where list goes */
528 t = NEXT(f2); /* where list will end */
529 offset = PNELEM(aux, t); /* offset thereof */
530 t = PINDEX(base, offset); /* where it currently ends */
531 FROMTOUPTO(f1, f2, t); /* copy */
532 NEXT(b) = t; /* set up parallel pointer */
533 } else if (level == 0) goto done; /* single run at level 0 */
535 /* Constructing a single run from two runs.
536 * The merge code at the top will do that.
537 * We need only make sure the two runs are in the "other" array,
538 * so they'll end up in the correct array after the merge.
542 stackp->offset = offset;
543 stackp->runs = 0; /* take care of both runs, trigger merge */
544 if (!iwhich) { /* Merged runs belong in aux, copy 1st */
545 f1 = b = PINDEX(base, offset); /* where first run starts */
546 f2 = PINDEX(aux, offset); /* where it will be copied */
547 t = NEXT(f2); /* where first run will end */
548 offset = PNELEM(aux, t); /* offset thereof */
549 p = PINDEX(base, offset); /* end of first run */
550 t = NEXT(t); /* where second run will end */
551 t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
552 FROMTOUPTO(f1, f2, t); /* copy both runs */
553 NEXT(b) = p; /* paralleled pointer for 1st */
554 NEXT(p) = t; /* ... and for second */
559 if (aux != small) Safefree(aux); /* free iff allocated */
561 PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */
567 * The quicksort implementation was derived from source code contributed
570 * NOTE: this code was derived from Tom Horsley's qsort replacement
571 * and should not be confused with the original code.
574 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
576 Permission granted to distribute under the same terms as perl which are
579 This program is free software; you can redistribute it and/or modify
580 it under the terms of either:
582 a) the GNU General Public License as published by the Free
583 Software Foundation; either version 1, or (at your option) any
586 b) the "Artistic License" which comes with this Kit.
588 Details on the perl license can be found in the perl source code which
589 may be located via the www.perl.com web page.
591 This is the most wonderfulest possible qsort I can come up with (and
592 still be mostly portable) My (limited) tests indicate it consistently
593 does about 20% fewer calls to compare than does the qsort in the Visual
594 C++ library, other vendors may vary.
596 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
597 others I invented myself (or more likely re-invented since they seemed
598 pretty obvious once I watched the algorithm operate for a while).
600 Most of this code was written while watching the Marlins sweep the Giants
601 in the 1997 National League Playoffs - no Braves fans allowed to use this
602 code (just kidding :-).
604 I realize that if I wanted to be true to the perl tradition, the only
605 comment in this file would be something like:
607 ...they shuffled back towards the rear of the line. 'No, not at the
608 rear!' the slave-driver shouted. 'Three files up. And stay there...
610 However, I really needed to violate that tradition just so I could keep
611 track of what happens myself, not to mention some poor fool trying to
612 understand this years from now :-).
615 /* ********************************************************** Configuration */
617 #ifndef QSORT_ORDER_GUESS
618 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
621 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
622 future processing - a good max upper bound is log base 2 of memory size
623 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
624 safely be smaller than that since the program is taking up some space and
625 most operating systems only let you grab some subset of contiguous
626 memory (not to mention that you are normally sorting data larger than
627 1 byte element size :-).
629 #ifndef QSORT_MAX_STACK
630 #define QSORT_MAX_STACK 32
633 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
634 Anything bigger and we use qsort. If you make this too small, the qsort
635 will probably break (or become less efficient), because it doesn't expect
636 the middle element of a partition to be the same as the right or left -
637 you have been warned).
639 #ifndef QSORT_BREAK_EVEN
640 #define QSORT_BREAK_EVEN 6
643 /* QSORT_PLAY_SAFE is the size of the largest partition we're willing
644 to go quadratic on. We innoculate larger partitions against
645 quadratic behavior by shuffling them before sorting. This is not
646 an absolute guarantee of non-quadratic behavior, but it would take
647 staggeringly bad luck to pick extreme elements as the pivot
648 from randomized data.
650 #ifndef QSORT_PLAY_SAFE
651 #define QSORT_PLAY_SAFE 255
654 /* ************************************************************* Data Types */
656 /* hold left and right index values of a partition waiting to be sorted (the
657 partition includes both left and right - right is NOT one past the end or
660 struct partition_stack_entry {
663 #ifdef QSORT_ORDER_GUESS
664 int qsort_break_even;
668 /* ******************************************************* Shorthand Macros */
670 /* Note that these macros will be used from inside the qsort function where
671 we happen to know that the variable 'elt_size' contains the size of an
672 array element and the variable 'temp' points to enough space to hold a
673 temp element and the variable 'array' points to the array being sorted
674 and 'compare' is the pointer to the compare routine.
676 Also note that there are very many highly architecture specific ways
677 these might be sped up, but this is simply the most generally portable
678 code I could think of.
681 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
683 #define qsort_cmp(elt1, elt2) \
684 ((*compare)(aTHX_ array[elt1], array[elt2]))
686 #ifdef QSORT_ORDER_GUESS
687 #define QSORT_NOTICE_SWAP swapped++;
689 #define QSORT_NOTICE_SWAP
692 /* swaps contents of array elements elt1, elt2.
694 #define qsort_swap(elt1, elt2) \
697 temp = array[elt1]; \
698 array[elt1] = array[elt2]; \
699 array[elt2] = temp; \
702 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
703 elt3 and elt3 gets elt1.
705 #define qsort_rotate(elt1, elt2, elt3) \
708 temp = array[elt1]; \
709 array[elt1] = array[elt2]; \
710 array[elt2] = array[elt3]; \
711 array[elt3] = temp; \
714 /* ************************************************************ Debug stuff */
721 return; /* good place to set a breakpoint */
724 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
731 int (*compare)(const void * elt1, const void * elt2),
732 int pc_left, int pc_right, int u_left, int u_right)
736 qsort_assert(pc_left <= pc_right);
737 qsort_assert(u_right < pc_left);
738 qsort_assert(pc_right < u_left);
739 for (i = u_right + 1; i < pc_left; ++i) {
740 qsort_assert(qsort_cmp(i, pc_left) < 0);
742 for (i = pc_left; i < pc_right; ++i) {
743 qsort_assert(qsort_cmp(i, pc_right) == 0);
745 for (i = pc_right + 1; i < u_left; ++i) {
746 qsort_assert(qsort_cmp(pc_right, i) < 0);
750 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
751 doqsort_all_asserts(array, num_elts, elt_size, compare, \
752 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
756 #define qsort_assert(t) ((void)0)
758 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
762 /* ****************************************************************** qsort */
764 STATIC void /* the standard unstable (u) quicksort (qsort) */
765 S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
768 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
769 int next_stack_entry = 0;
772 #ifdef QSORT_ORDER_GUESS
773 int qsort_break_even;
777 PERL_ARGS_ASSERT_QSORTSVU;
779 /* Make sure we actually have work to do.
785 /* Inoculate large partitions against quadratic behavior */
786 if (num_elts > QSORT_PLAY_SAFE) {
788 SV ** const q = array;
789 for (n = num_elts; n > 1; ) {
790 const size_t j = (size_t)(n-- * Drand01());
797 /* Setup the initial partition definition and fall into the sorting loop
800 part_right = (int)(num_elts - 1);
801 #ifdef QSORT_ORDER_GUESS
802 qsort_break_even = QSORT_BREAK_EVEN;
804 #define qsort_break_even QSORT_BREAK_EVEN
807 if ((part_right - part_left) >= qsort_break_even) {
808 /* OK, this is gonna get hairy, so lets try to document all the
809 concepts and abbreviations and variables and what they keep
812 pc: pivot chunk - the set of array elements we accumulate in the
813 middle of the partition, all equal in value to the original
814 pivot element selected. The pc is defined by:
816 pc_left - the leftmost array index of the pc
817 pc_right - the rightmost array index of the pc
819 we start with pc_left == pc_right and only one element
820 in the pivot chunk (but it can grow during the scan).
822 u: uncompared elements - the set of elements in the partition
823 we have not yet compared to the pivot value. There are two
824 uncompared sets during the scan - one to the left of the pc
825 and one to the right.
827 u_right - the rightmost index of the left side's uncompared set
828 u_left - the leftmost index of the right side's uncompared set
830 The leftmost index of the left sides's uncompared set
831 doesn't need its own variable because it is always defined
832 by the leftmost edge of the whole partition (part_left). The
833 same goes for the rightmost edge of the right partition
836 We know there are no uncompared elements on the left once we
837 get u_right < part_left and no uncompared elements on the
838 right once u_left > part_right. When both these conditions
839 are met, we have completed the scan of the partition.
841 Any elements which are between the pivot chunk and the
842 uncompared elements should be less than the pivot value on
843 the left side and greater than the pivot value on the right
844 side (in fact, the goal of the whole algorithm is to arrange
845 for that to be true and make the groups of less-than and
846 greater-then elements into new partitions to sort again).
848 As you marvel at the complexity of the code and wonder why it
849 has to be so confusing. Consider some of the things this level
852 Once I do a compare, I squeeze every ounce of juice out of it. I
853 never do compare calls I don't have to do, and I certainly never
856 I also never swap any elements unless I can prove there is a
857 good reason. Many sort algorithms will swap a known value with
858 an uncompared value just to get things in the right place (or
859 avoid complexity :-), but that uncompared value, once it gets
860 compared, may then have to be swapped again. A lot of the
861 complexity of this code is due to the fact that it never swaps
862 anything except compared values, and it only swaps them when the
863 compare shows they are out of position.
865 int pc_left, pc_right;
870 pc_left = ((part_left + part_right) / 2);
872 u_right = pc_left - 1;
873 u_left = pc_right + 1;
875 /* Qsort works best when the pivot value is also the median value
876 in the partition (unfortunately you can't find the median value
877 without first sorting :-), so to give the algorithm a helping
878 hand, we pick 3 elements and sort them and use the median value
879 of that tiny set as the pivot value.
881 Some versions of qsort like to use the left middle and right as
882 the 3 elements to sort so they can insure the ends of the
883 partition will contain values which will stop the scan in the
884 compare loop, but when you have to call an arbitrarily complex
885 routine to do a compare, its really better to just keep track of
886 array index values to know when you hit the edge of the
887 partition and avoid the extra compare. An even better reason to
888 avoid using a compare call is the fact that you can drop off the
889 edge of the array if someone foolishly provides you with an
890 unstable compare function that doesn't always provide consistent
893 So, since it is simpler for us to compare the three adjacent
894 elements in the middle of the partition, those are the ones we
895 pick here (conveniently pointed at by u_right, pc_left, and
896 u_left). The values of the left, center, and right elements
897 are referred to as l c and r in the following comments.
900 #ifdef QSORT_ORDER_GUESS
903 s = qsort_cmp(u_right, pc_left);
906 s = qsort_cmp(pc_left, u_left);
907 /* if l < c, c < r - already in order - nothing to do */
909 /* l < c, c == r - already in order, pc grows */
911 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
913 /* l < c, c > r - need to know more */
914 s = qsort_cmp(u_right, u_left);
916 /* l < c, c > r, l < r - swap c & r to get ordered */
917 qsort_swap(pc_left, u_left);
918 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
920 /* l < c, c > r, l == r - swap c&r, grow pc */
921 qsort_swap(pc_left, u_left);
923 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
925 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
926 qsort_rotate(pc_left, u_right, u_left);
927 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
932 s = qsort_cmp(pc_left, u_left);
934 /* l == c, c < r - already in order, grow pc */
936 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
938 /* l == c, c == r - already in order, grow pc both ways */
941 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
943 /* l == c, c > r - swap l & r, grow pc */
944 qsort_swap(u_right, u_left);
946 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
950 s = qsort_cmp(pc_left, u_left);
952 /* l > c, c < r - need to know more */
953 s = qsort_cmp(u_right, u_left);
955 /* l > c, c < r, l < r - swap l & c to get ordered */
956 qsort_swap(u_right, pc_left);
957 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
959 /* l > c, c < r, l == r - swap l & c, grow pc */
960 qsort_swap(u_right, pc_left);
962 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
964 /* l > c, c < r, l > r - rotate lcr into crl to order */
965 qsort_rotate(u_right, pc_left, u_left);
966 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
969 /* l > c, c == r - swap ends, grow pc */
970 qsort_swap(u_right, u_left);
972 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
974 /* l > c, c > r - swap ends to get in order */
975 qsort_swap(u_right, u_left);
976 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
979 /* We now know the 3 middle elements have been compared and
980 arranged in the desired order, so we can shrink the uncompared
985 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
987 /* The above massive nested if was the simple part :-). We now have
988 the middle 3 elements ordered and we need to scan through the
989 uncompared sets on either side, swapping elements that are on
990 the wrong side or simply shuffling equal elements around to get
991 all equal elements into the pivot chunk.
995 int still_work_on_left;
996 int still_work_on_right;
998 /* Scan the uncompared values on the left. If I find a value
999 equal to the pivot value, move it over so it is adjacent to
1000 the pivot chunk and expand the pivot chunk. If I find a value
1001 less than the pivot value, then just leave it - its already
1002 on the correct side of the partition. If I find a greater
1003 value, then stop the scan.
1005 while ((still_work_on_left = (u_right >= part_left))) {
1006 s = qsort_cmp(u_right, pc_left);
1009 } else if (s == 0) {
1011 if (pc_left != u_right) {
1012 qsort_swap(u_right, pc_left);
1018 qsort_assert(u_right < pc_left);
1019 qsort_assert(pc_left <= pc_right);
1020 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
1021 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1024 /* Do a mirror image scan of uncompared values on the right
1026 while ((still_work_on_right = (u_left <= part_right))) {
1027 s = qsort_cmp(pc_right, u_left);
1030 } else if (s == 0) {
1032 if (pc_right != u_left) {
1033 qsort_swap(pc_right, u_left);
1039 qsort_assert(u_left > pc_right);
1040 qsort_assert(pc_left <= pc_right);
1041 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
1042 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1045 if (still_work_on_left) {
1046 /* I know I have a value on the left side which needs to be
1047 on the right side, but I need to know more to decide
1048 exactly the best thing to do with it.
1050 if (still_work_on_right) {
1051 /* I know I have values on both side which are out of
1052 position. This is a big win because I kill two birds
1053 with one swap (so to speak). I can advance the
1054 uncompared pointers on both sides after swapping both
1055 of them into the right place.
1057 qsort_swap(u_right, u_left);
1060 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
1062 /* I have an out of position value on the left, but the
1063 right is fully scanned, so I "slide" the pivot chunk
1064 and any less-than values left one to make room for the
1065 greater value over on the right. If the out of position
1066 value is immediately adjacent to the pivot chunk (there
1067 are no less-than values), I can do that with a swap,
1068 otherwise, I have to rotate one of the less than values
1069 into the former position of the out of position value
1070 and the right end of the pivot chunk into the left end
1074 if (pc_left == u_right) {
1075 qsort_swap(u_right, pc_right);
1076 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1078 qsort_rotate(u_right, pc_left, pc_right);
1079 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1084 } else if (still_work_on_right) {
1085 /* Mirror image of complex case above: I have an out of
1086 position value on the right, but the left is fully
1087 scanned, so I need to shuffle things around to make room
1088 for the right value on the left.
1091 if (pc_right == u_left) {
1092 qsort_swap(u_left, pc_left);
1093 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1095 qsort_rotate(pc_right, pc_left, u_left);
1096 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1101 /* No more scanning required on either side of partition,
1102 break out of loop and figure out next set of partitions
1108 /* The elements in the pivot chunk are now in the right place. They
1109 will never move or be compared again. All I have to do is decide
1110 what to do with the stuff to the left and right of the pivot
1113 Notes on the QSORT_ORDER_GUESS ifdef code:
1115 1. If I just built these partitions without swapping any (or
1116 very many) elements, there is a chance that the elements are
1117 already ordered properly (being properly ordered will
1118 certainly result in no swapping, but the converse can't be
1121 2. A (properly written) insertion sort will run faster on
1122 already ordered data than qsort will.
1124 3. Perhaps there is some way to make a good guess about
1125 switching to an insertion sort earlier than partition size 6
1126 (for instance - we could save the partition size on the stack
1127 and increase the size each time we find we didn't swap, thus
1128 switching to insertion sort earlier for partitions with a
1129 history of not swapping).
1131 4. Naturally, if I just switch right away, it will make
1132 artificial benchmarks with pure ascending (or descending)
1133 data look really good, but is that a good reason in general?
1137 #ifdef QSORT_ORDER_GUESS
1139 #if QSORT_ORDER_GUESS == 1
1140 qsort_break_even = (part_right - part_left) + 1;
1142 #if QSORT_ORDER_GUESS == 2
1143 qsort_break_even *= 2;
1145 #if QSORT_ORDER_GUESS == 3
1146 const int prev_break = qsort_break_even;
1147 qsort_break_even *= qsort_break_even;
1148 if (qsort_break_even < prev_break) {
1149 qsort_break_even = (part_right - part_left) + 1;
1153 qsort_break_even = QSORT_BREAK_EVEN;
1157 if (part_left < pc_left) {
1158 /* There are elements on the left which need more processing.
1159 Check the right as well before deciding what to do.
1161 if (pc_right < part_right) {
1162 /* We have two partitions to be sorted. Stack the biggest one
1163 and process the smallest one on the next iteration. This
1164 minimizes the stack height by insuring that any additional
1165 stack entries must come from the smallest partition which
1166 (because it is smallest) will have the fewest
1167 opportunities to generate additional stack entries.
1169 if ((part_right - pc_right) > (pc_left - part_left)) {
1170 /* stack the right partition, process the left */
1171 partition_stack[next_stack_entry].left = pc_right + 1;
1172 partition_stack[next_stack_entry].right = part_right;
1173 #ifdef QSORT_ORDER_GUESS
1174 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1176 part_right = pc_left - 1;
1178 /* stack the left partition, process the right */
1179 partition_stack[next_stack_entry].left = part_left;
1180 partition_stack[next_stack_entry].right = pc_left - 1;
1181 #ifdef QSORT_ORDER_GUESS
1182 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1184 part_left = pc_right + 1;
1186 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
1189 /* The elements on the left are the only remaining elements
1190 that need sorting, arrange for them to be processed as the
1193 part_right = pc_left - 1;
1195 } else if (pc_right < part_right) {
1196 /* There is only one chunk on the right to be sorted, make it
1197 the new partition and loop back around.
1199 part_left = pc_right + 1;
1201 /* This whole partition wound up in the pivot chunk, so
1202 we need to get a new partition off the stack.
1204 if (next_stack_entry == 0) {
1205 /* the stack is empty - we are done */
1209 part_left = partition_stack[next_stack_entry].left;
1210 part_right = partition_stack[next_stack_entry].right;
1211 #ifdef QSORT_ORDER_GUESS
1212 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1216 /* This partition is too small to fool with qsort complexity, just
1217 do an ordinary insertion sort to minimize overhead.
1220 /* Assume 1st element is in right place already, and start checking
1221 at 2nd element to see where it should be inserted.
1223 for (i = part_left + 1; i <= part_right; ++i) {
1225 /* Scan (backwards - just in case 'i' is already in right place)
1226 through the elements already sorted to see if the ith element
1227 belongs ahead of one of them.
1229 for (j = i - 1; j >= part_left; --j) {
1230 if (qsort_cmp(i, j) >= 0) {
1231 /* i belongs right after j
1238 /* Looks like we really need to move some things
1242 for (k = i - 1; k >= j; --k)
1243 array[k + 1] = array[k];
1248 /* That partition is now sorted, grab the next one, or get out
1249 of the loop if there aren't any more.
1252 if (next_stack_entry == 0) {
1253 /* the stack is empty - we are done */
1257 part_left = partition_stack[next_stack_entry].left;
1258 part_right = partition_stack[next_stack_entry].right;
1259 #ifdef QSORT_ORDER_GUESS
1260 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1265 /* Believe it or not, the array is sorted at this point! */
1268 /* Stabilize what is, presumably, an otherwise unstable sort method.
1269 * We do that by allocating (or having on hand) an array of pointers
1270 * that is the same size as the original array of elements to be sorted.
1271 * We initialize this parallel array with the addresses of the original
1272 * array elements. This indirection can make you crazy.
1273 * Some pictures can help. After initializing, we have
1277 * | | --------------> | | ------> first element to be sorted
1279 * | | --------------> | | ------> second element to be sorted
1281 * | | --------------> | | ------> third element to be sorted
1285 * | | --------------> | | ------> n-1st element to be sorted
1287 * | | --------------> | | ------> n-th element to be sorted
1290 * During the sort phase, we leave the elements of list1 where they are,
1291 * and sort the pointers in the indirect array in the same order determined
1292 * by the original comparison routine on the elements pointed to.
1293 * Because we don't move the elements of list1 around through
1294 * this phase, we can break ties on elements that compare equal
1295 * using their address in the list1 array, ensuring stability.
1296 * This leaves us with something looking like
1300 * | | --+ +---> | | ------> first element to be sorted
1302 * | | --|-------|---> | | ------> second element to be sorted
1304 * | | --|-------+ +-> | | ------> third element to be sorted
1307 * +----+ | | | | +----+
1308 * | | ---|-+ | +--> | | ------> n-1st element to be sorted
1310 * | | ---+ +----> | | ------> n-th element to be sorted
1313 * where the i-th element of the indirect array points to the element
1314 * that should be i-th in the sorted array. After the sort phase,
1315 * we have to put the elements of list1 into the places
1316 * dictated by the indirect array.
1321 cmpindir(pTHX_ gptr const a, gptr const b)
1323 gptr * const ap = (gptr *)a;
1324 gptr * const bp = (gptr *)b;
1325 const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1329 return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1333 cmpindir_desc(pTHX_ gptr const a, gptr const b)
1335 gptr * const ap = (gptr *)a;
1336 gptr * const bp = (gptr *)b;
1337 const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1339 /* Reverse the default */
1342 /* But don't reverse the stability test. */
1343 return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1348 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1350 if ((flags & SORTf_STABLE) != 0) {
1353 gptr *small[SMALLSORT], **indir, tmp;
1354 SVCOMPARE_t savecmp;
1355 if (nmemb <= 1) return; /* sorted trivially */
1357 /* Small arrays can use the stack, big ones must be allocated */
1358 if (nmemb <= SMALLSORT) indir = small;
1359 else { Newx(indir, nmemb, gptr *); }
1361 /* Copy pointers to original array elements into indirect array */
1362 for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++;
1364 savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
1365 PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
1367 /* sort, with indirection */
1368 if (flags & SORTf_DESC)
1369 qsortsvu((gptr *)indir, nmemb, cmpindir_desc);
1371 qsortsvu((gptr *)indir, nmemb, cmpindir);
1375 for (n = nmemb; n--; ) {
1376 /* Assert A: all elements of q with index > n are already
1377 * in place. This is vacuously true at the start, and we
1378 * put element n where it belongs below (if it wasn't
1379 * already where it belonged). Assert B: we only move
1380 * elements that aren't where they belong,
1381 * so, by A, we never tamper with elements above n.
1383 j = pp[n] - q; /* This sets j so that q[j] is
1384 * at pp[n]. *pp[j] belongs in
1385 * q[j], by construction.
1387 if (n != j) { /* all's well if n == j */
1388 tmp = q[j]; /* save what's in q[j] */
1390 q[j] = *pp[j]; /* put *pp[j] where it belongs */
1391 i = pp[j] - q; /* the index in q of the element
1393 pp[j] = q + j; /* this is ok now */
1394 } while ((j = i) != n);
1395 /* There are only finitely many (nmemb) addresses
1397 * So we must eventually revisit an index we saw before.
1398 * Suppose the first revisited index is k != n.
1399 * An index is visited because something else belongs there.
1400 * If we visit k twice, then two different elements must
1401 * belong in the same place, which cannot be.
1402 * So j must get back to n, the loop terminates,
1403 * and we put the saved element where it belongs.
1405 q[n] = tmp; /* put what belongs into
1406 * the n-th element */
1410 /* free iff allocated */
1411 if (indir != small) { Safefree(indir); }
1412 /* restore prevailing comparison routine */
1413 PL_sort_RealCmp = savecmp;
1414 } else if ((flags & SORTf_DESC) != 0) {
1415 const SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
1416 PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
1418 qsortsvu(list1, nmemb, cmp);
1419 /* restore prevailing comparison routine */
1420 PL_sort_RealCmp = savecmp;
1422 qsortsvu(list1, nmemb, cmp);
1427 =head1 Array Manipulation Functions
1431 Sort an array. Here is an example:
1433 sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
1435 Currently this always uses mergesort. See sortsv_flags for a more
1442 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1444 PERL_ARGS_ASSERT_SORTSV;
1446 sortsv_flags(array, nmemb, cmp, 0);
1450 =for apidoc sortsv_flags
1452 Sort an array, with various 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;
1479 I32 gimme = GIMME_V;
1480 OP* const nextop = PL_op->op_next;
1481 I32 overloading = 0;
1482 bool hasargs = FALSE;
1486 const U8 priv = PL_op->op_private;
1487 const U8 flags = PL_op->op_flags;
1489 void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1490 = Perl_sortsv_flags;
1493 if ((priv & OPpSORT_DESCEND) != 0)
1494 sort_flags |= SORTf_DESC;
1495 if ((priv & OPpSORT_QSORT) != 0)
1496 sort_flags |= SORTf_QSORT;
1497 if ((priv & OPpSORT_STABLE) != 0)
1498 sort_flags |= SORTf_STABLE;
1500 if (gimme != G_ARRAY) {
1507 SAVEVPTR(PL_sortcop);
1508 if (flags & OPf_STACKED) {
1509 if (flags & OPf_SPECIAL) {
1510 OP *nullop = OpSIBLING(cLISTOP->op_first); /* pass pushmark */
1511 assert(nullop->op_type == OP_NULL);
1512 PL_sortcop = nullop->op_next;
1517 cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
1519 if (cv && SvPOK(cv)) {
1520 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
1521 if (proto && strEQ(proto, "$$")) {
1525 if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
1528 else if (!(cv && CvROOT(cv))) {
1532 else if (!CvANON(cv) && (gv = CvGV(cv))) {
1533 if (cv != GvCV(gv)) cv = GvCV(gv);
1536 autogv = gv_autoload_pvn(
1537 GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1538 GvNAMEUTF8(gv) ? SVf_UTF8 : 0
1545 SV *tmpstr = sv_newmortal();
1546 gv_efullname3(tmpstr, gv, NULL);
1547 DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
1552 DIE(aTHX_ "Undefined subroutine in sort");
1557 PL_sortcop = (OP*)cv;
1559 PL_sortcop = CvSTART(cv);
1566 /* optimiser converts "@a = sort @a" to "sort \@a";
1567 * in case of tied @a, pessimise: push (@a) onto stack, then assign
1568 * result back to @a at the end of this function */
1569 if (priv & OPpSORT_INPLACE) {
1570 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
1571 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
1572 av = MUTABLE_AV((*SP));
1573 max = AvFILL(av) + 1;
1574 if (SvMAGICAL(av)) {
1576 for (i=0; i < max; i++) {
1577 SV **svp = av_fetch(av, i, FALSE);
1578 *SP++ = (svp) ? *svp : NULL;
1581 p1 = p2 = SP - (max-1);
1585 Perl_croak_no_modify();
1589 save_pushptr((void *)av, SAVEt_READONLY_OFF);
1591 p1 = p2 = AvARRAY(av);
1600 /* shuffle stack down, removing optional initial cv (p1!=p2), plus
1601 * any nulls; also stringify or converting to integer or number as
1602 * required any args */
1603 copytmps = !sorting_av && PL_sortcop;
1604 for (i=max; i > 0 ; i--) {
1605 if ((*p1 = *p2++)) { /* Weed out nulls. */
1606 if (copytmps && SvPADTMP(*p1)) {
1607 *p1 = sv_mortalcopy(*p1);
1611 if (priv & OPpSORT_NUMERIC) {
1612 if (priv & OPpSORT_INTEGER) {
1614 (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1618 (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1619 if (all_SIVs && !SvSIOK(*p1))
1625 (void)sv_2pv_flags(*p1, 0,
1626 SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
1637 AvFILLp(av) = max-1;
1644 const bool oldcatch = CATCH_GET;
1650 PUSHSTACKi(PERLSI_SORT);
1651 if (!hasargs && !is_xsub) {
1652 SAVEGENERICSV(PL_firstgv);
1653 SAVEGENERICSV(PL_secondgv);
1654 PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
1655 gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
1657 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
1658 gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
1660 SAVESPTR(GvSV(PL_firstgv));
1661 SAVESPTR(GvSV(PL_secondgv));
1664 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1665 if (!(flags & OPf_SPECIAL)) {
1666 cx->cx_type = CXt_SUB;
1667 cx->blk_gimme = G_SCALAR;
1668 /* If our comparison routine is already active (CvDEPTH is
1669 * is not 0), then PUSHSUB does not increase the refcount,
1670 * so we have to do it ourselves, because the LEAVESUB fur-
1671 * ther down lowers it. */
1672 if (CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv);
1675 PADLIST * const padlist = CvPADLIST(cv);
1677 if (++CvDEPTH(cv) >= 2) {
1678 PERL_STACK_OVERFLOW_CHECK();
1679 pad_push(padlist, CvDEPTH(cv));
1682 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1685 /* This is mostly copied from pp_entersub */
1686 AV * const av = MUTABLE_AV(PAD_SVl(0));
1688 cx->blk_sub.savearray = GvAV(PL_defgv);
1689 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1690 CX_CURPAD_SAVE(cx->blk_sub);
1691 cx->blk_sub.argarray = av;
1696 cx->cx_type |= CXp_MULTICALL;
1699 sortsvp(aTHX_ start, max,
1700 (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1703 if (!(flags & OPf_SPECIAL)) {
1705 /* Reset cx, in case the context stack has been
1707 cx = &cxstack[cxstack_ix];
1711 POPBLOCK(cx,PL_curpm);
1712 PL_stack_sp = newsp;
1714 CATCH_SET(oldcatch);
1717 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1718 start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
1719 sortsvp(aTHX_ start, max,
1720 (priv & OPpSORT_NUMERIC)
1721 ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1722 ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1723 : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1725 #ifdef USE_LOCALE_COLLATE
1726 IN_LC_RUNTIME(LC_COLLATE)
1728 ? (SVCOMPARE_t)S_amagic_cmp_locale
1729 : (SVCOMPARE_t)sv_cmp_locale_static)
1732 ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1735 if ((priv & OPpSORT_REVERSE) != 0) {
1736 SV **q = start+max-1;
1738 SV * const tmp = *start;
1746 else if (av && !sorting_av) {
1747 /* simulate pp_aassign of tied AV */
1748 SV** const base = MARK+1;
1749 for (i=0; i < max; i++) {
1750 base[i] = newSVsv(base[i]);
1754 for (i=0; i < max; i++) {
1755 SV * const sv = base[i];
1756 SV ** const didstore = av_store(av, i, sv);
1764 PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
1769 S_sortcv(pTHX_ SV *const a, SV *const b)
1771 const I32 oldsaveix = PL_savestack_ix;
1772 const I32 oldscopeix = PL_scopestack_ix;
1775 PMOP * const pm = PL_curpm;
1776 OP * const sortop = PL_op;
1777 COP * const cop = PL_curcop;
1779 PERL_ARGS_ASSERT_SORTCV;
1781 GvSV(PL_firstgv) = a;
1782 GvSV(PL_secondgv) = b;
1783 PL_stack_sp = PL_stack_base;
1788 if (PL_stack_sp != PL_stack_base + 1) {
1789 assert(PL_stack_sp == PL_stack_base);
1790 resultsv = &PL_sv_undef;
1792 else resultsv = *PL_stack_sp;
1793 if (SvNIOK_nog(resultsv)) result = SvIV(resultsv);
1796 SAVEVPTR(PL_curpad);
1798 result = SvIV(resultsv);
1801 while (PL_scopestack_ix > oldscopeix) {
1804 leave_scope(oldsaveix);
1810 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1812 const I32 oldsaveix = PL_savestack_ix;
1813 const I32 oldscopeix = PL_scopestack_ix;
1815 AV * const av = GvAV(PL_defgv);
1816 PMOP * const pm = PL_curpm;
1817 OP * const sortop = PL_op;
1818 COP * const cop = PL_curcop;
1821 PERL_ARGS_ASSERT_SORTCV_STACKED;
1828 if (AvMAX(av) < 1) {
1829 SV **ary = AvALLOC(av);
1830 if (AvARRAY(av) != ary) {
1831 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1834 if (AvMAX(av) < 1) {
1845 PL_stack_sp = PL_stack_base;
1850 pad = PL_curpad; PL_curpad = 0;
1851 if (PL_stack_sp != PL_stack_base + 1) {
1852 assert(PL_stack_sp == PL_stack_base);
1853 result = SvIV(&PL_sv_undef);
1855 else result = SvIV(*PL_stack_sp);
1857 while (PL_scopestack_ix > oldscopeix) {
1860 leave_scope(oldsaveix);
1866 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1869 const I32 oldsaveix = PL_savestack_ix;
1870 const I32 oldscopeix = PL_scopestack_ix;
1871 CV * const cv=MUTABLE_CV(PL_sortcop);
1873 PMOP * const pm = PL_curpm;
1875 PERL_ARGS_ASSERT_SORTCV_XSUB;
1883 (void)(*CvXSUB(cv))(aTHX_ cv);
1884 if (PL_stack_sp != PL_stack_base + 1)
1885 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1886 result = SvIV(*PL_stack_sp);
1887 while (PL_scopestack_ix > oldscopeix) {
1890 leave_scope(oldsaveix);
1897 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1899 const NV nv1 = SvNSIV(a);
1900 const NV nv2 = SvNSIV(b);
1902 PERL_ARGS_ASSERT_SV_NCMP;
1904 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1905 if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
1907 if (nv1 != nv1 || nv2 != nv2) {
1909 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1912 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
1916 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1918 const IV iv1 = SvIV(a);
1919 const IV iv2 = SvIV(b);
1921 PERL_ARGS_ASSERT_SV_I_NCMP;
1923 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1926 #define tryCALL_AMAGICbin(left,right,meth) \
1927 (SvAMAGIC(left)||SvAMAGIC(right)) \
1928 ? amagic_call(left, right, meth, 0) \
1931 #define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
1934 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1936 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1938 PERL_ARGS_ASSERT_AMAGIC_NCMP;
1942 const I32 i = SvIVX(tmpsv);
1943 return SORT_NORMAL_RETURN_VALUE(i);
1946 const NV d = SvNV(tmpsv);
1947 return SORT_NORMAL_RETURN_VALUE(d);
1950 return S_sv_ncmp(aTHX_ a, b);
1954 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1956 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1958 PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1962 const I32 i = SvIVX(tmpsv);
1963 return SORT_NORMAL_RETURN_VALUE(i);
1966 const NV d = SvNV(tmpsv);
1967 return SORT_NORMAL_RETURN_VALUE(d);
1970 return S_sv_i_ncmp(aTHX_ a, b);
1974 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1976 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1978 PERL_ARGS_ASSERT_AMAGIC_CMP;
1982 const I32 i = SvIVX(tmpsv);
1983 return SORT_NORMAL_RETURN_VALUE(i);
1986 const NV d = SvNV(tmpsv);
1987 return SORT_NORMAL_RETURN_VALUE(d);
1990 return sv_cmp(str1, str2);
1993 #ifdef USE_LOCALE_COLLATE
1996 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1998 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
2000 PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
2004 const I32 i = SvIVX(tmpsv);
2005 return SORT_NORMAL_RETURN_VALUE(i);
2008 const NV d = SvNV(tmpsv);
2009 return SORT_NORMAL_RETURN_VALUE(d);
2012 return sv_cmp_locale(str1, str2);
2018 * ex: set ts=8 sts=4 sw=4 et: