(perl #131746) avoid undefined behaviour in Copy() etc
[perl.git] / pp_sort.c
1 /*    pp_sort.c
2  *
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
5  *
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.
8  *
9  */
10
11 /*
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...
14  *
15  *     [p.931 of _The Lord of the Rings_, VI/ii: "The Land of Shadow"]
16  */
17
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.
23  *
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
26  * the pp_ functions.
27  */
28
29 #include "EXTERN.h"
30 #define PERL_IN_PP_SORT_C
31 #include "perl.h"
32
33 #if defined(UNDER_CE)
34 /* looks like 'small' is reserved word for WINCE (or somesuch)*/
35 #define small xsmall
36 #endif
37
38 #define sv_cmp_static Perl_sv_cmp
39 #define sv_cmp_locale_static Perl_sv_cmp_locale
40
41 #ifndef SMALLSORT
42 #define SMALLSORT (200)
43 #endif
44
45 /* Flags for qsortsv and mergesortsv */
46 #define SORTf_DESC   1
47 #define SORTf_STABLE 2
48 #define SORTf_QSORT  4
49 #define SORTf_UNSTABLE 8
50
51 /*
52  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
53  *
54  * The original code was written in conjunction with BSD Computer Software
55  * Research Group at University of California, Berkeley.
56  *
57  * See also: "Optimistic Sorting and Information Theoretic Complexity"
58  *           Peter McIlroy
59  *           SODA (Fourth Annual ACM-SIAM Symposium on Discrete Algorithms),
60  *           pp 467-474, Austin, Texas, 25-27 January 1993.
61  *
62  * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
63  *
64  * The code can be distributed under the same terms as Perl itself.
65  *
66  */
67
68
69 typedef char * aptr;            /* pointer for arithmetic on sizes */
70 typedef SV * gptr;              /* pointers in our lists */
71
72 /* Binary merge internal sort, with a few special mods
73 ** for the special perl environment it now finds itself in.
74 **
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.
79 */
80
81 /* Pointer types for arithmetic and storage and convenience casts */
82
83 #define APTR(P) ((aptr)(P))
84 #define GPTP(P) ((gptr *)(P))
85 #define GPPP(P) ((gptr **)(P))
86
87
88 /* byte offset from pointer P to (larger) pointer Q */
89 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
90
91 #define PSIZE sizeof(gptr)
92
93 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
94
95 #ifdef  PSHIFT
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)))
99 #else
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))
104 #endif
105
106 /* Pointer into other corresponding to pointer into this */
107 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
108
109 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
110
111
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.
116 */
117
118 #define NEXT(P)         (*GPPP(P))
119
120
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.
124 */
125
126 #define PTHRESH (8)
127
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.
134 */
135
136 #define RTHRESH (6)
137
138
139 /*
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.
144 **
145 ** Unless otherwise specified, pair pointers address the first of two elements.
146 **
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.
149 **
150 ** p2 parallels b in the list2 array, where runs are defined by
151 ** a pointer chain.
152 **
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.
158 **
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.
162 **
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.
167 **
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.
173 **
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
178 **
179 ** 2) Long run.  b < r <= q < t.
180 **      b through q is a run (of length >= 2 * PTHRESH)
181 **
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.
185 */
186
187
188 static IV
189 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
190 {
191     I32 sense;
192     gptr *b, *p, *q, *t, *p2;
193     gptr *last, *r;
194     IV runs = 0;
195
196     b = list1;
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.
202         */
203         for (p = b+2, t = p; ++p < last; t = ++p) {
204             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
205         }
206         q = b;
207         /* Having laid out the playing field, look for long runs */
208         do {
209             p = r = b + (2 * PTHRESH);
210             if (r >= t) p = r = t;      /* too short to care about */
211             else {
212                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
213                        ((p -= 2) > q)) {}
214                 if (p <= q) {
215                     /* b through r is a (long) run.
216                     ** Extend it as far as possible.
217                     */
218                     p = q = r;
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 */
222                 }
223             }
224             if (q > b) {                /* run of greater than 2 at b */
225                 gptr *savep = p;
226
227                 p = q += 2;
228                 /* pick up singleton, if possible */
229                 if ((p == t) &&
230                     ((t + 1) == last) &&
231                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
232                     savep = r = p = q = last;
233                 p2 = NEXT(p2) = p2 + (p - b); ++runs;
234                 if (sense)
235                     while (b < --p) {
236                         const gptr c = *b;
237                         *b++ = *p;
238                         *p = c;
239                     }
240                 p = savep;
241             }
242             while (q < p) {             /* simple pairs */
243                 p2 = NEXT(p2) = p2 + 2; ++runs;
244                 if (sense) {
245                     const gptr c = *q++;
246                     *(q-1) = *q;
247                     *q++ = c;
248                 } else q += 2;
249             }
250             if (((b = p) == t) && ((t+1) == last)) {
251                 NEXT(p2) = p2 + 1; ++runs;
252                 b++;
253             }
254             q = r;
255         } while (b < t);
256         sense = !sense;
257     }
258     return runs;
259 }
260
261
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.
266  *
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.
272  *
273  * By contrast, consider how the original mergesort algorithm worked.
274  * Suppose we have five runs (each typically of length 2 after dynprep).
275  * 
276  * pass               base                        aux
277  *  0              1 2 3 4 5
278  *  1                                           12 34 5
279  *  2                1234 5
280  *  3                                            12345
281  *  4                 12345
282  *
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.
288  *
289  * The following pseudo-code uses the same basic merge algorithm,
290  * but in a divide-and-conquer way.
291  *
292  * # merge $runs runs at offset $offset of list $list1 into $list2.
293  * # all unmerged runs ($runs == 1) originate in list $base.
294  * sub mgsort2 {
295  *     my ($offset, $runs, $base, $list1, $list2) = @_;
296  *
297  *     if ($runs == 1) {
298  *         if ($list1 is $base) copy run to $list2
299  *         return offset of end of list (or copy)
300  *     } else {
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
305  *     }
306  * }
307  * mgsort2(0, $runs, $base, $aux, $base);
308  *
309  * For our 5 runs, the tree of calls looks like 
310  *
311  *           5
312  *      3        2
313  *   2     1   1   1
314  * 1   1
315  *
316  * 1   2   3   4   5
317  *
318  * and the corresponding activity looks like
319  *
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
327  *
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).
336  *
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.
340  */
341
342 typedef struct {
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 */
346
347
348 static I32
349 cmp_desc(pTHX_ gptr const a, gptr const b)
350 {
351     return -PL_sort_RealCmp(aTHX_ a, b);
352 }
353
354 STATIC void
355 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
356 {
357     IV i, run, offset;
358     I32 sense, level;
359     gptr *f1, *f2, *t, *b, *p;
360     int iwhich;
361     gptr *aux;
362     gptr *p1;
363     gptr small[SMALLSORT];
364     gptr *which[3];
365     off_runs stack[60], *stackp;
366     SVCOMPARE_t savecmp = NULL;
367
368     if (nmemb <= 1) return;                     /* sorted trivially */
369
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 */
373         cmp = cmp_desc;
374     }
375
376     if (nmemb <= SMALLSORT) aux = small;        /* use stack for aux array */
377     else { Newx(aux,nmemb,gptr); }              /* allocate auxiliary array */
378     level = 0;
379     stackp = stack;
380     stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
381     stackp->offset = offset = 0;
382     which[0] = which[2] = base;
383     which[1] = aux;
384     for (;;) {
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.
389          */
390         IV runs = stackp->runs;
391         if (runs == 0) {
392             gptr *list1, *list2;
393             iwhich = level & 1;
394             list1 = which[iwhich];              /* area where runs are now */
395             list2 = which[++iwhich];            /* area for merged runs */
396             do {
397                 gptr *l1, *l2, *tp2;
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.
411                     **
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",
417                     ** we can't just do
418                     **    cmp(q, other) < 0
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.
425                     */
426
427                     gptr *q;
428                     if (cmp(aTHX_ *f1, *f2) <= 0) {
429                         q = f2; b = f1; t = l1;
430                         sense = -1;
431                     } else {
432                         q = f1; b = f2; t = l2;
433                         sense = 0;
434                     }
435
436
437                     /* ramp up
438                     **
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.
442                     */
443                     for (i = 1, run = 0 ;;) {
444                         if ((p = PINDEX(b, i)) >= t) {
445                             /* off the end */
446                             if (((p = PINDEX(t, -1)) > b) &&
447                                 (cmp(aTHX_ *q, *p) <= sense))
448                                  t = p;
449                             else b = p;
450                             break;
451                         } else if (cmp(aTHX_ *q, *p) <= sense) {
452                             t = p;
453                             break;
454                         } else b = p;
455                         if (++run >= RTHRESH) i += i;
456                     }
457
458
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.
463                     */
464
465                     b++;
466                     while (b < t) {
467                         p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
468                         if (cmp(aTHX_ *q, *p) <= sense) {
469                             t = p;
470                         } else b = p + 1;
471                     }
472
473
474                     /* Copy all the strictly low elements */
475
476                     if (q == f1) {
477                         FROMTOUPTO(f2, tp2, t);
478                         *tp2++ = *f1++;
479                     } else {
480                         FROMTOUPTO(f1, tp2, t);
481                         *tp2++ = *f2++;
482                     }
483                 }
484
485
486                 /* Run out remaining list */
487                 if (f1 == l1) {
488                        if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
489                 } else              FROMTOUPTO(f1, tp2, l1);
490                 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
491
492                 if (--level == 0) goto done;
493                 --stackp;
494                 t = list1; list1 = list2; list2 = t;    /* swap lists */
495             } while ((runs = stackp->runs) == 0);
496         }
497
498
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.
505          */
506         while (runs > 2) {
507             ++level;
508             ++stackp;
509             stackp->offset = offset;
510             runs -= stackp->runs = runs / 2;
511         }
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].
515          */
516         iwhich = level & 1;
517         if (runs == 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.
525              */
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 */
535         } else {
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.
540              */
541             ++level;
542             ++stackp;
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 */
556             }
557         }
558     }
559   done:
560     if (aux != small) Safefree(aux);    /* free iff allocated */
561     if (flags) {
562          PL_sort_RealCmp = savecmp;     /* Restore current comparison routine, if any */
563     }
564     return;
565 }
566
567 /*
568  * The quicksort implementation was derived from source code contributed
569  * by Tom Horsley.
570  *
571  * NOTE: this code was derived from Tom Horsley's qsort replacement
572  * and should not be confused with the original code.
573  */
574
575 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
576
577    Permission granted to distribute under the same terms as perl which are
578    (briefly):
579
580     This program is free software; you can redistribute it and/or modify
581     it under the terms of either:
582
583         a) the GNU General Public License as published by the Free
584         Software Foundation; either version 1, or (at your option) any
585         later version, or
586
587         b) the "Artistic License" which comes with this Kit.
588
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.
591
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.
596
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).
600
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 :-).
604
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:
607
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...
610
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 :-).
614 */
615
616 /* ********************************************************** Configuration */
617
618 #ifndef QSORT_ORDER_GUESS
619 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
620 #endif
621
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 :-).
629 */
630 #ifndef QSORT_MAX_STACK
631 #define QSORT_MAX_STACK 32
632 #endif
633
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).
639 */
640 #ifndef QSORT_BREAK_EVEN
641 #define QSORT_BREAK_EVEN 6
642 #endif
643
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.
650 */
651 #ifndef QSORT_PLAY_SAFE
652 #define QSORT_PLAY_SAFE 255
653 #endif
654
655 /* ************************************************************* Data Types */
656
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
659    anything like that).
660 */
661 struct partition_stack_entry {
662    int left;
663    int right;
664 #ifdef QSORT_ORDER_GUESS
665    int qsort_break_even;
666 #endif
667 };
668
669 /* ******************************************************* Shorthand Macros */
670
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.
676
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.
680 */
681
682 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
683 */
684 #define qsort_cmp(elt1, elt2) \
685    ((*compare)(aTHX_ array[elt1], array[elt2]))
686
687 #ifdef QSORT_ORDER_GUESS
688 #define QSORT_NOTICE_SWAP swapped++;
689 #else
690 #define QSORT_NOTICE_SWAP
691 #endif
692
693 /* swaps contents of array elements elt1, elt2.
694 */
695 #define qsort_swap(elt1, elt2) \
696    STMT_START { \
697       QSORT_NOTICE_SWAP \
698       temp = array[elt1]; \
699       array[elt1] = array[elt2]; \
700       array[elt2] = temp; \
701    } STMT_END
702
703 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
704    elt3 and elt3 gets elt1.
705 */
706 #define qsort_rotate(elt1, elt2, elt3) \
707    STMT_START { \
708       QSORT_NOTICE_SWAP \
709       temp = array[elt1]; \
710       array[elt1] = array[elt2]; \
711       array[elt2] = array[elt3]; \
712       array[elt3] = temp; \
713    } STMT_END
714
715 /* ************************************************************ Debug stuff */
716
717 #ifdef QSORT_DEBUG
718
719 static void
720 break_here()
721 {
722    return; /* good place to set a breakpoint */
723 }
724
725 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
726
727 static void
728 doqsort_all_asserts(
729    void * array,
730    size_t num_elts,
731    size_t elt_size,
732    int (*compare)(const void * elt1, const void * elt2),
733    int pc_left, int pc_right, int u_left, int u_right)
734 {
735    int i;
736
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);
742    }
743    for (i = pc_left; i < pc_right; ++i) {
744       qsort_assert(qsort_cmp(i, pc_right) == 0);
745    }
746    for (i = pc_right + 1; i < u_left; ++i) {
747       qsort_assert(qsort_cmp(pc_right, i) < 0);
748    }
749 }
750
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)
754
755 #else
756
757 #define qsort_assert(t) ((void)0)
758
759 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
760
761 #endif
762
763 /* ****************************************************************** qsort */
764
765 STATIC void /* the standard unstable (u) quicksort (qsort) */
766 S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
767 {
768    SV * temp;
769    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
770    int next_stack_entry = 0;
771    int part_left;
772    int part_right;
773 #ifdef QSORT_ORDER_GUESS
774    int qsort_break_even;
775    int swapped;
776 #endif
777
778     PERL_ARGS_ASSERT_QSORTSVU;
779
780    /* Make sure we actually have work to do.
781    */
782    if (num_elts <= 1) {
783       return;
784    }
785
786    /* Inoculate large partitions against quadratic behavior */
787    if (num_elts > QSORT_PLAY_SAFE) {
788       size_t n;
789       SV ** const q = array;
790       for (n = num_elts; n > 1; ) {
791          const size_t j = (size_t)(n-- * Drand01());
792          temp = q[j];
793          q[j] = q[n];
794          q[n] = temp;
795       }
796    }
797
798    /* Setup the initial partition definition and fall into the sorting loop
799    */
800    part_left = 0;
801    part_right = (int)(num_elts - 1);
802 #ifdef QSORT_ORDER_GUESS
803    qsort_break_even = QSORT_BREAK_EVEN;
804 #else
805 #define qsort_break_even QSORT_BREAK_EVEN
806 #endif
807    for ( ; ; ) {
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
811             track of:
812
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:
816
817                 pc_left - the leftmost array index of the pc
818                 pc_right - the rightmost array index of the pc
819
820                 we start with pc_left == pc_right and only one element
821                 in the pivot chunk (but it can grow during the scan).
822
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.
827
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
830
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
835                 (part_right).
836
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.
841
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).
848
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
851             of confusion brings:
852
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
855             do redundant calls.
856
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.
865          */
866          int pc_left, pc_right;
867          int u_right, u_left;
868
869          int s;
870
871          pc_left = ((part_left + part_right) / 2);
872          pc_right = pc_left;
873          u_right = pc_left - 1;
874          u_left = pc_right + 1;
875
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.
881
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
892             results.
893
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.
899          */
900
901 #ifdef QSORT_ORDER_GUESS
902          swapped = 0;
903 #endif
904          s = qsort_cmp(u_right, pc_left);
905          if (s < 0) {
906             /* l < c */
907             s = qsort_cmp(pc_left, u_left);
908             /* if l < c, c < r - already in order - nothing to do */
909             if (s == 0) {
910                /* l < c, c == r - already in order, pc grows */
911                ++pc_right;
912                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
913             } else if (s > 0) {
914                /* l < c, c > r - need to know more */
915                s = qsort_cmp(u_right, u_left);
916                if (s < 0) {
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);
920                } else if (s == 0) {
921                   /* l < c, c > r, l == r - swap c&r, grow pc */
922                   qsort_swap(pc_left, u_left);
923                   --pc_left;
924                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
925                } else {
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);
929                }
930             }
931          } else if (s == 0) {
932             /* l == c */
933             s = qsort_cmp(pc_left, u_left);
934             if (s < 0) {
935                /* l == c, c < r - already in order, grow pc */
936                --pc_left;
937                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
938             } else if (s == 0) {
939                /* l == c, c == r - already in order, grow pc both ways */
940                --pc_left;
941                ++pc_right;
942                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
943             } else {
944                /* l == c, c > r - swap l & r, grow pc */
945                qsort_swap(u_right, u_left);
946                ++pc_right;
947                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
948             }
949          } else {
950             /* l > c */
951             s = qsort_cmp(pc_left, u_left);
952             if (s < 0) {
953                /* l > c, c < r - need to know more */
954                s = qsort_cmp(u_right, u_left);
955                if (s < 0) {
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);
959                } else if (s == 0) {
960                   /* l > c, c < r, l == r - swap l & c, grow pc */
961                   qsort_swap(u_right, pc_left);
962                   ++pc_right;
963                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
964                } else {
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);
968                }
969             } else if (s == 0) {
970                /* l > c, c == r - swap ends, grow pc */
971                qsort_swap(u_right, u_left);
972                --pc_left;
973                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
974             } else {
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);
978             }
979          }
980          /* We now know the 3 middle elements have been compared and
981             arranged in the desired order, so we can shrink the uncompared
982             sets on both sides
983          */
984          --u_right;
985          ++u_left;
986          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
987
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.
993          */
994
995          for ( ; ; ) {
996             int still_work_on_left;
997             int still_work_on_right;
998
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.
1005             */
1006             while ((still_work_on_left = (u_right >= part_left))) {
1007                s = qsort_cmp(u_right, pc_left);
1008                if (s < 0) {
1009                   --u_right;
1010                } else if (s == 0) {
1011                   --pc_left;
1012                   if (pc_left != u_right) {
1013                      qsort_swap(u_right, pc_left);
1014                   }
1015                   --u_right;
1016                } else {
1017                   break;
1018                }
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);
1023             }
1024
1025             /* Do a mirror image scan of uncompared values on the right
1026             */
1027             while ((still_work_on_right = (u_left <= part_right))) {
1028                s = qsort_cmp(pc_right, u_left);
1029                if (s < 0) {
1030                   ++u_left;
1031                } else if (s == 0) {
1032                   ++pc_right;
1033                   if (pc_right != u_left) {
1034                      qsort_swap(pc_right, u_left);
1035                   }
1036                   ++u_left;
1037                } else {
1038                   break;
1039                }
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);
1044             }
1045
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.
1050                */
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.
1057                   */
1058                   qsort_swap(u_right, u_left);
1059                   --u_right;
1060                   ++u_left;
1061                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
1062                } else {
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
1072                      (got all that?).
1073                   */
1074                   --pc_left;
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);
1078                   } else {
1079                      qsort_rotate(u_right, pc_left, pc_right);
1080                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1081                   }
1082                   --pc_right;
1083                   --u_right;
1084                }
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.
1090                */
1091                ++pc_right;
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);
1095                } else {
1096                   qsort_rotate(pc_right, pc_left, u_left);
1097                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1098                }
1099                ++pc_left;
1100                ++u_left;
1101             } else {
1102                /* No more scanning required on either side of partition,
1103                   break out of loop and figure out next set of partitions
1104                */
1105                break;
1106             }
1107          }
1108
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
1112             chunk.
1113
1114             Notes on the QSORT_ORDER_GUESS ifdef code:
1115
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
1120                proved :-).
1121
1122             2. A (properly written) insertion sort will run faster on
1123                already ordered data than qsort will.
1124
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).
1131
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?
1135                Hard to say...
1136          */
1137
1138 #ifdef QSORT_ORDER_GUESS
1139          if (swapped < 3) {
1140 #if QSORT_ORDER_GUESS == 1
1141             qsort_break_even = (part_right - part_left) + 1;
1142 #endif
1143 #if QSORT_ORDER_GUESS == 2
1144             qsort_break_even *= 2;
1145 #endif
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;
1151             }
1152 #endif
1153          } else {
1154             qsort_break_even = QSORT_BREAK_EVEN;
1155          }
1156 #endif
1157
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.
1161             */
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.
1169                */
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;
1176 #endif
1177                   part_right = pc_left - 1;
1178                } else {
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;
1184 #endif
1185                   part_left = pc_right + 1;
1186                }
1187                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
1188                ++next_stack_entry;
1189             } else {
1190                /* The elements on the left are the only remaining elements
1191                   that need sorting, arrange for them to be processed as the
1192                   next partition.
1193                */
1194                part_right = pc_left - 1;
1195             }
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.
1199             */
1200             part_left = pc_right + 1;
1201          } else {
1202             /* This whole partition wound up in the pivot chunk, so
1203                we need to get a new partition off the stack.
1204             */
1205             if (next_stack_entry == 0) {
1206                /* the stack is empty - we are done */
1207                break;
1208             }
1209             --next_stack_entry;
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;
1214 #endif
1215          }
1216       } else {
1217          /* This partition is too small to fool with qsort complexity, just
1218             do an ordinary insertion sort to minimize overhead.
1219          */
1220          int i;
1221          /* Assume 1st element is in right place already, and start checking
1222             at 2nd element to see where it should be inserted.
1223          */
1224          for (i = part_left + 1; i <= part_right; ++i) {
1225             int j;
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.
1229             */
1230             for (j = i - 1; j >= part_left; --j) {
1231                if (qsort_cmp(i, j) >= 0) {
1232                   /* i belongs right after j
1233                   */
1234                   break;
1235                }
1236             }
1237             ++j;
1238             if (j != i) {
1239                /* Looks like we really need to move some things
1240                */
1241                int k;
1242                temp = array[i];
1243                for (k = i - 1; k >= j; --k)
1244                   array[k + 1] = array[k];
1245                array[j] = temp;
1246             }
1247          }
1248
1249          /* That partition is now sorted, grab the next one, or get out
1250             of the loop if there aren't any more.
1251          */
1252
1253          if (next_stack_entry == 0) {
1254             /* the stack is empty - we are done */
1255             break;
1256          }
1257          --next_stack_entry;
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;
1262 #endif
1263       }
1264    }
1265
1266    /* Believe it or not, the array is sorted at this point! */
1267 }
1268
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
1275  *
1276  *  indir                  list1
1277  * +----+                 +----+
1278  * |    | --------------> |    | ------> first element to be sorted
1279  * +----+                 +----+
1280  * |    | --------------> |    | ------> second element to be sorted
1281  * +----+                 +----+
1282  * |    | --------------> |    | ------> third element to be sorted
1283  * +----+                 +----+
1284  *  ...
1285  * +----+                 +----+
1286  * |    | --------------> |    | ------> n-1st element to be sorted
1287  * +----+                 +----+
1288  * |    | --------------> |    | ------> n-th element to be sorted
1289  * +----+                 +----+
1290  *
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
1298  *
1299  *  indir                  list1
1300  * +----+                 +----+
1301  * |    | --+       +---> |    | ------> first element to be sorted
1302  * +----+   |       |     +----+
1303  * |    | --|-------|---> |    | ------> second element to be sorted
1304  * +----+   |       |     +----+
1305  * |    | --|-------+ +-> |    | ------> third element to be sorted
1306  * +----+   |         |   +----+
1307  *  ...
1308  * +----+    | |   | |    +----+
1309  * |    | ---|-+   | +--> |    | ------> n-1st element to be sorted
1310  * +----+    |     |      +----+
1311  * |    | ---+     +----> |    | ------> n-th element to be sorted
1312  * +----+                 +----+
1313  *
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.
1318  */
1319
1320
1321 static I32
1322 cmpindir(pTHX_ gptr const a, gptr const b)
1323 {
1324     gptr * const ap = (gptr *)a;
1325     gptr * const bp = (gptr *)b;
1326     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1327
1328     if (sense)
1329         return sense;
1330     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1331 }
1332
1333 static I32
1334 cmpindir_desc(pTHX_ gptr const a, gptr const b)
1335 {
1336     gptr * const ap = (gptr *)a;
1337     gptr * const bp = (gptr *)b;
1338     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1339
1340     /* Reverse the default */
1341     if (sense)
1342         return -sense;
1343     /* But don't reverse the stability test.  */
1344     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1345
1346 }
1347
1348 STATIC void
1349 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1350 {
1351     if ((flags & SORTf_STABLE) != 0) {
1352          gptr **pp, *q;
1353          size_t n, j, i;
1354          gptr *small[SMALLSORT], **indir, tmp;
1355          SVCOMPARE_t savecmp;
1356          if (nmemb <= 1) return;     /* sorted trivially */
1357
1358          /* Small arrays can use the stack, big ones must be allocated */
1359          if (nmemb <= SMALLSORT) indir = small;
1360          else { Newx(indir, nmemb, gptr *); }
1361
1362          /* Copy pointers to original array elements into indirect array */
1363          for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++;
1364
1365          savecmp = PL_sort_RealCmp;     /* Save current comparison routine, if any */
1366          PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
1367
1368          /* sort, with indirection */
1369          if (flags & SORTf_DESC)
1370             qsortsvu((gptr *)indir, nmemb, cmpindir_desc);
1371         else
1372             qsortsvu((gptr *)indir, nmemb, cmpindir);
1373
1374          pp = indir;
1375          q = list1;
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.
1383                */
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.
1387                                          */
1388               if (n != j) {             /* all's well if n == j */
1389                    tmp = q[j];          /* save what's in q[j] */
1390                    do {
1391                         q[j] = *pp[j];  /* put *pp[j] where it belongs */
1392                         i = pp[j] - q;  /* the index in q of the element
1393                                          * just moved */
1394                         pp[j] = q + j;  /* this is ok now */
1395                    } while ((j = i) != n);
1396                    /* There are only finitely many (nmemb) addresses
1397                     * in the pp array.
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.
1405                     */
1406                    q[n] = tmp;          /* put what belongs into
1407                                          * the n-th element */
1408               }
1409          }
1410
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 */
1418          cmp = cmp_desc;
1419          qsortsvu(list1, nmemb, cmp);
1420          /* restore prevailing comparison routine */
1421          PL_sort_RealCmp = savecmp;
1422     } else {
1423          qsortsvu(list1, nmemb, cmp);
1424     }
1425 }
1426
1427 /*
1428 =head1 Array Manipulation Functions
1429
1430 =for apidoc sortsv
1431
1432 In-place sort an array of SV pointers with the given comparison routine.
1433
1434 Currently this always uses mergesort.  See C<L</sortsv_flags>> for a more
1435 flexible routine.
1436
1437 =cut
1438 */
1439
1440 void
1441 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1442 {
1443     PERL_ARGS_ASSERT_SORTSV;
1444
1445     sortsv_flags(array, nmemb, cmp, 0);
1446 }
1447
1448 /*
1449 =for apidoc sortsv_flags
1450
1451 In-place sort an array of SV pointers with the given comparison routine,
1452 with various SORTf_* flag options.
1453
1454 =cut
1455 */
1456 void
1457 Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1458 {
1459     PERL_ARGS_ASSERT_SORTSV_FLAGS;
1460
1461     if (flags & SORTf_QSORT)
1462         S_qsortsv(aTHX_ array, nmemb, cmp, flags);
1463     else
1464         S_mergesortsv(aTHX_ array, nmemb, cmp, flags);
1465 }
1466
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) ) )
1470
1471 PP(pp_sort)
1472 {
1473     dSP; dMARK; dORIGMARK;
1474     SV **p1 = ORIGMARK+1, **p2;
1475     SSize_t max, i;
1476     AV* av = NULL;
1477     GV *gv;
1478     CV *cv = NULL;
1479     U8 gimme = GIMME_V;
1480     OP* const nextop = PL_op->op_next;
1481     I32 overloading = 0;
1482     bool hasargs = FALSE;
1483     bool copytmps;
1484     I32 is_xsub = 0;
1485     const U8 priv = PL_op->op_private;
1486     const U8 flags = PL_op->op_flags;
1487     U32 sort_flags = 0;
1488     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1489       = Perl_sortsv_flags;
1490     I32 all_SIVs = 1;
1491
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;
1500
1501     if (gimme != G_ARRAY) {
1502         SP = MARK;
1503         EXTEND(SP,1);
1504         RETPUSHUNDEF;
1505     }
1506
1507     ENTER;
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;
1514         }
1515         else {
1516             GV *autogv = NULL;
1517             HV *stash;
1518             cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
1519           check_cv:
1520             if (cv && SvPOK(cv)) {
1521                 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
1522                 if (proto && strEQ(proto, "$$")) {
1523                     hasargs = TRUE;
1524                 }
1525             }
1526             if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
1527                 is_xsub = 1;
1528             }
1529             else if (!(cv && CvROOT(cv))) {
1530                 if (gv) {
1531                     goto autoload;
1532                 }
1533                 else if (!CvANON(cv) && (gv = CvGV(cv))) {
1534                   if (cv != GvCV(gv)) cv = GvCV(gv);
1535                  autoload:
1536                   if (!autogv && (
1537                         autogv = gv_autoload_pvn(
1538                             GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1539                             GvNAMEUTF8(gv) ? SVf_UTF8 : 0
1540                         )
1541                      )) {
1542                     cv = GvCVu(autogv);
1543                     goto check_cv;
1544                   }
1545                   else {
1546                     SV *tmpstr = sv_newmortal();
1547                     gv_efullname3(tmpstr, gv, NULL);
1548                     DIE(aTHX_ "Undefined sort subroutine \"%" SVf "\" called",
1549                         SVfARG(tmpstr));
1550                   }
1551                 }
1552                 else {
1553                     DIE(aTHX_ "Undefined subroutine in sort");
1554                 }
1555             }
1556
1557             if (is_xsub)
1558                 PL_sortcop = (OP*)cv;
1559             else
1560                 PL_sortcop = CvSTART(cv);
1561         }
1562     }
1563     else {
1564         PL_sortcop = NULL;
1565     }
1566
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
1569      * this function */
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));
1574         if (SvREADONLY(av))
1575             Perl_croak_no_modify();
1576         max = AvFILL(av) + 1;
1577         MEXTEND(SP, max);
1578         if (SvMAGICAL(av)) {
1579             for (i=0; i < max; i++) {
1580                 SV **svp = av_fetch(av, i, FALSE);
1581                 *SP++ = (svp) ? *svp : NULL;
1582             }
1583         }
1584         else {
1585             SV **svp = AvARRAY(av);
1586             assert(svp || max == 0);
1587             for (i = 0; i < max; i++)
1588                 *SP++ = *svp++;
1589         }
1590         SP--;
1591         p1 = p2 = SP - (max-1);
1592     }
1593     else {
1594         p2 = MARK+1;
1595         max = SP - MARK;
1596    }
1597
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);
1606             }
1607             SvTEMP_off(*p1);
1608             if (!PL_sortcop) {
1609                 if (priv & OPpSORT_NUMERIC) {
1610                     if (priv & OPpSORT_INTEGER) {
1611                         if (!SvIOK(*p1))
1612                             (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1613                     }
1614                     else {
1615                         if (!SvNSIOK(*p1))
1616                             (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1617                         if (all_SIVs && !SvSIOK(*p1))
1618                             all_SIVs = 0;
1619                     }
1620                 }
1621                 else {
1622                     if (!SvPOK(*p1))
1623                         (void)sv_2pv_flags(*p1, 0,
1624                             SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
1625                 }
1626                 if (SvAMAGIC(*p1))
1627                     overloading = 1;
1628             }
1629             p1++;
1630         }
1631         else
1632             max--;
1633     }
1634     if (max > 1) {
1635         SV **start;
1636         if (PL_sortcop) {
1637             PERL_CONTEXT *cx;
1638             const bool oldcatch = CATCH_GET;
1639             I32 old_savestack_ix = PL_savestack_ix;
1640
1641             SAVEOP();
1642
1643             CATCH_SET(TRUE);
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)
1650                 ));
1651                 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
1652                     gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
1653                 ));
1654                 /* make sure the GP isn't removed out from under us for
1655                  * the SAVESPTR() */
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));
1663             }
1664
1665             gimme = G_SCALAR;
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);
1670                 if (!is_xsub) {
1671                     PADLIST * const padlist = CvPADLIST(cv);
1672
1673                     if (++CvDEPTH(cv) >= 2)
1674                         pad_push(padlist, CvDEPTH(cv));
1675                     PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1676
1677                     if (hasargs) {
1678                         /* This is mostly copied from pp_entersub */
1679                         AV * const av = MUTABLE_AV(PAD_SVl(0));
1680
1681                         cx->blk_sub.savearray = GvAV(PL_defgv);
1682                         GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1683                     }
1684
1685                 }
1686             }
1687
1688             start = p1 - max;
1689             sortsvp(aTHX_ start, max,
1690                     (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1691                     sort_flags);
1692
1693             /* Reset cx, in case the context stack has been reallocated. */
1694             cx = CX_CUR();
1695
1696             PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1697
1698             CX_LEAVE_SCOPE(cx);
1699             if (!(flags & OPf_SPECIAL)) {
1700                 assert(CxTYPE(cx) == CXt_SUB);
1701                 cx_popsub(cx);
1702             }
1703             else
1704                 assert(CxTYPE(cx) == CXt_NULL);
1705                 /* there isn't a POPNULL ! */
1706
1707             cx_popblock(cx);
1708             CX_POP(cx);
1709             POPSTACK;
1710             CATCH_SET(oldcatch);
1711         }
1712         else {
1713             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
1714             start = ORIGMARK+1;
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 ) )
1720                         : (
1721 #ifdef USE_LOCALE_COLLATE
1722                            IN_LC_RUNTIME(LC_COLLATE)
1723                             ? ( overloading
1724                                 ? (SVCOMPARE_t)S_amagic_cmp_locale
1725                                 : (SVCOMPARE_t)sv_cmp_locale_static)
1726                             :
1727 #endif
1728                               ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1729                     sort_flags);
1730         }
1731         if ((priv & OPpSORT_REVERSE) != 0) {
1732             SV **q = start+max-1;
1733             while (start < q) {
1734                 SV * const tmp = *start;
1735                 *start++ = *q;
1736                 *q-- = tmp;
1737             }
1738         }
1739     }
1740
1741     if (av) {
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]);
1747             av_clear(av);
1748             av_extend(av, max);
1749             for (i=0; i < max; i++) {
1750                 SV * const sv = base[i];
1751                 SV ** const didstore = av_store(av, i, sv);
1752                 if (SvSMAGICAL(sv))
1753                     mg_set(sv);
1754                 if (!didstore)
1755                     sv_2mortal(sv);
1756             }
1757         }
1758         else {
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
1763              * first.
1764              */
1765             for (i = 0; i < max; i++) {
1766                 SV *sv = base[i];
1767                 assert(sv);
1768                 if (SvREFCNT(sv) > 1)
1769                     base[i] = newSVsv(sv);
1770                 else
1771                     SvREFCNT_inc_simple_void_NN(sv);
1772             }
1773             av_clear(av);
1774             if (max > 0) {
1775                 av_extend(av, max);
1776                 Copy(base, AvARRAY(av), max, SV*);
1777             }
1778             AvFILLp(av) = max - 1;
1779             AvREIFY_off(av);
1780             AvREAL_on(av);
1781         }
1782     }
1783     LEAVE;
1784     PL_stack_sp = ORIGMARK +  max;
1785     return nextop;
1786 }
1787
1788 static I32
1789 S_sortcv(pTHX_ SV *const a, SV *const b)
1790 {
1791     const I32 oldsaveix = PL_savestack_ix;
1792     I32 result;
1793     PMOP * const pm = PL_curpm;
1794     COP * const cop = PL_curcop;
1795  
1796     PERL_ARGS_ASSERT_SORTCV;
1797
1798     GvSV(PL_firstgv) = a;
1799     GvSV(PL_secondgv) = b;
1800     PL_stack_sp = PL_stack_base;
1801     PL_op = PL_sortcop;
1802     CALLRUNOPS(aTHX);
1803     PL_curcop = cop;
1804     /* entry zero of a stack is always PL_sv_undef, which
1805      * simplifies converting a '()' return into undef in scalar context */
1806     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1807     result = SvIV(*PL_stack_sp);
1808
1809     LEAVE_SCOPE(oldsaveix);
1810     PL_curpm = pm;
1811     return result;
1812 }
1813
1814 static I32
1815 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1816 {
1817     const I32 oldsaveix = PL_savestack_ix;
1818     I32 result;
1819     AV * const av = GvAV(PL_defgv);
1820     PMOP * const pm = PL_curpm;
1821     COP * const cop = PL_curcop;
1822
1823     PERL_ARGS_ASSERT_SORTCV_STACKED;
1824
1825     if (AvREAL(av)) {
1826         av_clear(av);
1827         AvREAL_off(av);
1828         AvREIFY_on(av);
1829     }
1830     if (AvMAX(av) < 1) {
1831         SV **ary = AvALLOC(av);
1832         if (AvARRAY(av) != ary) {
1833             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1834             AvARRAY(av) = ary;
1835         }
1836         if (AvMAX(av) < 1) {
1837             Renew(ary,2,SV*);
1838             AvMAX(av) = 1;
1839             AvARRAY(av) = ary;
1840             AvALLOC(av) = ary;
1841         }
1842     }
1843     AvFILLp(av) = 1;
1844
1845     AvARRAY(av)[0] = a;
1846     AvARRAY(av)[1] = b;
1847     PL_stack_sp = PL_stack_base;
1848     PL_op = PL_sortcop;
1849     CALLRUNOPS(aTHX);
1850     PL_curcop = cop;
1851     /* entry zero of a stack is always PL_sv_undef, which
1852      * simplifies converting a '()' return into undef in scalar context */
1853     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1854     result = SvIV(*PL_stack_sp);
1855
1856     LEAVE_SCOPE(oldsaveix);
1857     PL_curpm = pm;
1858     return result;
1859 }
1860
1861 static I32
1862 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1863 {
1864     dSP;
1865     const I32 oldsaveix = PL_savestack_ix;
1866     CV * const cv=MUTABLE_CV(PL_sortcop);
1867     I32 result;
1868     PMOP * const pm = PL_curpm;
1869
1870     PERL_ARGS_ASSERT_SORTCV_XSUB;
1871
1872     SP = PL_stack_base;
1873     PUSHMARK(SP);
1874     EXTEND(SP, 2);
1875     *++SP = a;
1876     *++SP = b;
1877     PUTBACK;
1878     (void)(*CvXSUB(cv))(aTHX_ cv);
1879     /* entry zero of a stack is always PL_sv_undef, which
1880      * simplifies converting a '()' return into undef in scalar context */
1881     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1882     result = SvIV(*PL_stack_sp);
1883
1884     LEAVE_SCOPE(oldsaveix);
1885     PL_curpm = pm;
1886     return result;
1887 }
1888
1889
1890 static I32
1891 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1892 {
1893     I32 cmp = do_ncmp(a, b);
1894
1895     PERL_ARGS_ASSERT_SV_NCMP;
1896
1897     if (cmp == 2) {
1898         if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1899         return 0;
1900     }
1901
1902     return cmp;
1903 }
1904
1905 static I32
1906 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1907 {
1908     const IV iv1 = SvIV(a);
1909     const IV iv2 = SvIV(b);
1910
1911     PERL_ARGS_ASSERT_SV_I_NCMP;
1912
1913     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1914 }
1915
1916 #define tryCALL_AMAGICbin(left,right,meth) \
1917     (SvAMAGIC(left)||SvAMAGIC(right)) \
1918         ? amagic_call(left, right, meth, 0) \
1919         : NULL;
1920
1921 #define SORT_NORMAL_RETURN_VALUE(val)  (((val) > 0) ? 1 : ((val) ? -1 : 0))
1922
1923 static I32
1924 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1925 {
1926     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1927
1928     PERL_ARGS_ASSERT_AMAGIC_NCMP;
1929
1930     if (tmpsv) {
1931         if (SvIOK(tmpsv)) {
1932             const I32 i = SvIVX(tmpsv);
1933             return SORT_NORMAL_RETURN_VALUE(i);
1934         }
1935         else {
1936             const NV d = SvNV(tmpsv);
1937             return SORT_NORMAL_RETURN_VALUE(d);
1938         }
1939      }
1940      return S_sv_ncmp(aTHX_ a, b);
1941 }
1942
1943 static I32
1944 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1945 {
1946     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1947
1948     PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1949
1950     if (tmpsv) {
1951         if (SvIOK(tmpsv)) {
1952             const I32 i = SvIVX(tmpsv);
1953             return SORT_NORMAL_RETURN_VALUE(i);
1954         }
1955         else {
1956             const NV d = SvNV(tmpsv);
1957             return SORT_NORMAL_RETURN_VALUE(d);
1958         }
1959     }
1960     return S_sv_i_ncmp(aTHX_ a, b);
1961 }
1962
1963 static I32
1964 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1965 {
1966     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1967
1968     PERL_ARGS_ASSERT_AMAGIC_CMP;
1969
1970     if (tmpsv) {
1971         if (SvIOK(tmpsv)) {
1972             const I32 i = SvIVX(tmpsv);
1973             return SORT_NORMAL_RETURN_VALUE(i);
1974         }
1975         else {
1976             const NV d = SvNV(tmpsv);
1977             return SORT_NORMAL_RETURN_VALUE(d);
1978         }
1979     }
1980     return sv_cmp(str1, str2);
1981 }
1982
1983 #ifdef USE_LOCALE_COLLATE
1984
1985 static I32
1986 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1987 {
1988     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1989
1990     PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1991
1992     if (tmpsv) {
1993         if (SvIOK(tmpsv)) {
1994             const I32 i = SvIVX(tmpsv);
1995             return SORT_NORMAL_RETURN_VALUE(i);
1996         }
1997         else {
1998             const NV d = SvNV(tmpsv);
1999             return SORT_NORMAL_RETURN_VALUE(d);
2000         }
2001     }
2002     return sv_cmp_locale(str1, str2);
2003 }
2004
2005 #endif
2006
2007 /*
2008  * ex: set ts=8 sts=4 sw=4 et:
2009  */