This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2bd2c806a38fd64d6e1d3043523b835dde1ba7c6
[perl5.git] / pp_sort.c
1 /*    pp_sort.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 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
16 /* This file contains pp ("push/pop") functions that
17  * execute the opcodes that make up a perl program. A typical pp function
18  * expects to find its arguments on the stack, and usually pushes its
19  * results onto the stack, hence the 'pp' terminology. Each OP structure
20  * contains a pointer to the relevant pp_foo() function.
21  *
22  * This particular file just contains pp_sort(), which is complex
23  * enough to merit its own file! See the other pp*.c files for the rest of
24  * the pp_ functions.
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_PP_SORT_C
29 #include "perl.h"
30
31 #if defined(UNDER_CE)
32 /* looks like 'small' is reserved word for WINCE (or somesuch)*/
33 #define small xsmall
34 #endif
35
36 static I32 sortcv(pTHX_ SV *a, SV *b);
37 static I32 sortcv_stacked(pTHX_ SV *a, SV *b);
38 static I32 sortcv_xsub(pTHX_ SV *a, SV *b);
39 static I32 sv_ncmp(pTHX_ SV *a, SV *b);
40 static I32 sv_i_ncmp(pTHX_ SV *a, SV *b);
41 static I32 amagic_ncmp(pTHX_ SV *a, SV *b);
42 static I32 amagic_i_ncmp(pTHX_ SV *a, SV *b);
43 static I32 amagic_cmp(pTHX_ SV *a, SV *b);
44 static I32 amagic_cmp_locale(pTHX_ SV *a, SV *b);
45
46 #define sv_cmp_static Perl_sv_cmp
47 #define sv_cmp_locale_static Perl_sv_cmp_locale
48
49 #define dSORTHINTS   SV *hintsv = GvSV(gv_fetchpv("sort::hints", GV_ADDMULTI, SVt_IV))
50 #define SORTHINTS    (SvIOK(hintsv) ? ((I32)SvIV(hintsv)) : 0)
51
52 #ifndef SMALLSORT
53 #define SMALLSORT (200)
54 #endif
55
56 /*
57  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
58  *
59  * The original code was written in conjunction with BSD Computer Software
60  * Research Group at University of California, Berkeley.
61  *
62  * See also: "Optimistic Merge Sort" (SODA '92)
63  *
64  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
65  *
66  * The code can be distributed under the same terms as Perl itself.
67  *
68  */
69
70
71 typedef char * aptr;            /* pointer for arithmetic on sizes */
72 typedef SV * gptr;              /* pointers in our lists */
73
74 /* Binary merge internal sort, with a few special mods
75 ** for the special perl environment it now finds itself in.
76 **
77 ** Things that were once options have been hotwired
78 ** to values suitable for this use.  In particular, we'll always
79 ** initialize looking for natural runs, we'll always produce stable
80 ** output, and we'll always do Peter McIlroy's binary merge.
81 */
82
83 /* Pointer types for arithmetic and storage and convenience casts */
84
85 #define APTR(P) ((aptr)(P))
86 #define GPTP(P) ((gptr *)(P))
87 #define GPPP(P) ((gptr **)(P))
88
89
90 /* byte offset from pointer P to (larger) pointer Q */
91 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
92
93 #define PSIZE sizeof(gptr)
94
95 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
96
97 #ifdef  PSHIFT
98 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
99 #define PNBYTE(N)       ((N) << (PSHIFT))
100 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
101 #else
102 /* Leave optimization to compiler */
103 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
104 #define PNBYTE(N)       ((N) * (PSIZE))
105 #define PINDEX(P, N)    (GPTP(P) + (N))
106 #endif
107
108 /* Pointer into other corresponding to pointer into this */
109 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
110
111 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
112
113
114 /* Runs are identified by a pointer in the auxilliary list.
115 ** The pointer is at the start of the list,
116 ** and it points to the start of the next list.
117 ** NEXT is used as an lvalue, too.
118 */
119
120 #define NEXT(P)         (*GPPP(P))
121
122
123 /* PTHRESH is the minimum number of pairs with the same sense to justify
124 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
125 ** not just elements, so PTHRESH == 8 means a run of 16.
126 */
127
128 #define PTHRESH (8)
129
130 /* RTHRESH is the number of elements in a run that must compare low
131 ** to the low element from the opposing run before we justify
132 ** doing a binary rampup instead of single stepping.
133 ** In random input, N in a row low should only happen with
134 ** probability 2^(1-N), so we can risk that we are dealing
135 ** with orderly input without paying much when we aren't.
136 */
137
138 #define RTHRESH (6)
139
140
141 /*
142 ** Overview of algorithm and variables.
143 ** The array of elements at list1 will be organized into runs of length 2,
144 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
145 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
146 **
147 ** Unless otherwise specified, pair pointers address the first of two elements.
148 **
149 ** b and b+1 are a pair that compare with sense "sense".
150 ** b is the "bottom" of adjacent pairs that might form a longer run.
151 **
152 ** p2 parallels b in the list2 array, where runs are defined by
153 ** a pointer chain.
154 **
155 ** t represents the "top" of the adjacent pairs that might extend
156 ** the run beginning at b.  Usually, t addresses a pair
157 ** that compares with opposite sense from (b,b+1).
158 ** However, it may also address a singleton element at the end of list1,
159 ** or it may be equal to "last", the first element beyond list1.
160 **
161 ** r addresses the Nth pair following b.  If this would be beyond t,
162 ** we back it off to t.  Only when r is less than t do we consider the
163 ** run long enough to consider checking.
164 **
165 ** q addresses a pair such that the pairs at b through q already form a run.
166 ** Often, q will equal b, indicating we only are sure of the pair itself.
167 ** However, a search on the previous cycle may have revealed a longer run,
168 ** so q may be greater than b.
169 **
170 ** p is used to work back from a candidate r, trying to reach q,
171 ** which would mean b through r would be a run.  If we discover such a run,
172 ** we start q at r and try to push it further towards t.
173 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
174 ** In any event, after the check (if any), we have two main cases.
175 **
176 ** 1) Short run.  b <= q < p <= r <= t.
177 **      b through q is a run (perhaps trivial)
178 **      q through p are uninteresting pairs
179 **      p through r is a run
180 **
181 ** 2) Long run.  b < r <= q < t.
182 **      b through q is a run (of length >= 2 * PTHRESH)
183 **
184 ** Note that degenerate cases are not only possible, but likely.
185 ** For example, if the pair following b compares with opposite sense,
186 ** then b == q < p == r == t.
187 */
188
189
190 static IV
191 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
192 {
193     I32 sense;
194     register gptr *b, *p, *q, *t, *p2;
195     register gptr c, *last, *r;
196     gptr *savep;
197     IV runs = 0;
198
199     b = list1;
200     last = PINDEX(b, nmemb);
201     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
202     for (p2 = list2; b < last; ) {
203         /* We just started, or just reversed sense.
204         ** Set t at end of pairs with the prevailing sense.
205         */
206         for (p = b+2, t = p; ++p < last; t = ++p) {
207             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
208         }
209         q = b;
210         /* Having laid out the playing field, look for long runs */
211         do {
212             p = r = b + (2 * PTHRESH);
213             if (r >= t) p = r = t;      /* too short to care about */
214             else {
215                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
216                        ((p -= 2) > q));
217                 if (p <= q) {
218                     /* b through r is a (long) run.
219                     ** Extend it as far as possible.
220                     */
221                     p = q = r;
222                     while (((p += 2) < t) &&
223                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
224                     r = p = q + 2;      /* no simple pairs, no after-run */
225                 }
226             }
227             if (q > b) {                /* run of greater than 2 at b */
228                 savep = p;
229                 p = q += 2;
230                 /* pick up singleton, if possible */
231                 if ((p == t) &&
232                     ((t + 1) == last) &&
233                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
234                     savep = r = p = q = last;
235                 p2 = NEXT(p2) = p2 + (p - b); ++runs;
236                 if (sense) while (b < --p) {
237                     c = *b;
238                     *b++ = *p;
239                     *p = c;
240                 }
241                 p = savep;
242             }
243             while (q < p) {             /* simple pairs */
244                 p2 = NEXT(p2) = p2 + 2; ++runs;
245                 if (sense) {
246                     c = *q++;
247                     *(q-1) = *q;
248                     *q++ = c;
249                 } else q += 2;
250             }
251             if (((b = p) == t) && ((t+1) == last)) {
252                 NEXT(p2) = p2 + 1; ++runs;
253                 b++;
254             }
255             q = r;
256         } while (b < t);
257         sense = !sense;
258     }
259     return runs;
260 }
261
262
263 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
264  * qsort on many platforms, but slower than qsort, conspicuously so,
265  * on others.  The most likely explanation was platform-specific
266  * differences in cache sizes and relative speeds.
267  *
268  * The quicksort divide-and-conquer algorithm guarantees that, as the
269  * problem is subdivided into smaller and smaller parts, the parts
270  * fit into smaller (and faster) caches.  So it doesn't matter how
271  * many levels of cache exist, quicksort will "find" them, and,
272  * as long as smaller is faster, take advantage of them.
273  *
274  * By contrast, consider how the original mergesort algorithm worked.
275  * Suppose we have five runs (each typically of length 2 after dynprep).
276  * 
277  * pass               base                        aux
278  *  0              1 2 3 4 5
279  *  1                                           12 34 5
280  *  2                1234 5
281  *  3                                            12345
282  *  4                 12345
283  *
284  * Adjacent pairs are merged in "grand sweeps" through the input.
285  * This means, on pass 1, the records in runs 1 and 2 aren't revisited until
286  * runs 3 and 4 are merged and the runs from run 5 have been copied.
287  * The only cache that matters is one large enough to hold *all* the input.
288  * On some platforms, this may be many times slower than smaller caches.
289  *
290  * The following pseudo-code uses the same basic merge algorithm,
291  * but in a divide-and-conquer way.
292  *
293  * # merge $runs runs at offset $offset of list $list1 into $list2.
294  * # all unmerged runs ($runs == 1) originate in list $base.
295  * sub mgsort2 {
296  *     my ($offset, $runs, $base, $list1, $list2) = @_;
297  *
298  *     if ($runs == 1) {
299  *         if ($list1 is $base) copy run to $list2
300  *         return offset of end of list (or copy)
301  *     } else {
302  *         $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1)
303  *         mgsort2($off2, $runs/2, $base, $list2, $list1)
304  *         merge the adjacent runs at $offset of $list1 into $list2
305  *         return the offset of the end of the merged runs
306  *     }
307  * }
308  * mgsort2(0, $runs, $base, $aux, $base);
309  *
310  * For our 5 runs, the tree of calls looks like 
311  *
312  *           5
313  *      3        2
314  *   2     1   1   1
315  * 1   1
316  *
317  * 1   2   3   4   5
318  *
319  * and the corresponding activity looks like
320  *
321  * copy runs 1 and 2 from base to aux
322  * merge runs 1 and 2 from aux to base
323  * (run 3 is where it belongs, no copy needed)
324  * merge runs 12 and 3 from base to aux
325  * (runs 4 and 5 are where they belong, no copy needed)
326  * merge runs 4 and 5 from base to aux
327  * merge runs 123 and 45 from aux to base
328  *
329  * Note that we merge runs 1 and 2 immediately after copying them,
330  * while they are still likely to be in fast cache.  Similarly,
331  * run 3 is merged with run 12 while it still may be lingering in cache.
332  * This implementation should therefore enjoy much of the cache-friendly
333  * behavior that quicksort does.  In addition, it does less copying
334  * than the original mergesort implementation (only runs 1 and 2 are copied)
335  * and the "balancing" of merges is better (merged runs comprise more nearly
336  * equal numbers of original runs).
337  *
338  * The actual cache-friendly implementation will use a pseudo-stack
339  * to avoid recursion, and will unroll processing of runs of length 2,
340  * but it is otherwise similar to the recursive implementation.
341  */
342
343 typedef struct {
344     IV  offset;         /* offset of 1st of 2 runs at this level */
345     IV  runs;           /* how many runs must be combined into 1 */
346 } off_runs;             /* pseudo-stack element */
347
348
349 static I32
350 cmp_desc(pTHX_ gptr a, gptr b)
351 {
352     return -PL_sort_RealCmp(aTHX_ a, b);
353 }
354
355 STATIC void
356 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
357 {
358     IV i, run, runs, offset;
359     I32 sense, level;
360     int iwhich;
361     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
362     gptr *aux, *list1, *list2;
363     gptr *p1;
364     gptr small[SMALLSORT];
365     gptr *which[3];
366     off_runs stack[60], *stackp;
367     SVCOMPARE_t savecmp = 0;
368
369     if (nmemb <= 1) return;                     /* sorted trivially */
370
371     if (flags) {
372         savecmp = PL_sort_RealCmp;      /* Save current comparison routine, if any */
373         PL_sort_RealCmp = cmp;  /* Put comparison routine where cmp_desc can find it */
374         cmp = cmp_desc;
375     }
376
377     if (nmemb <= SMALLSORT) aux = small;        /* use stack for aux array */
378     else { Newx(aux,nmemb,gptr); }              /* allocate auxilliary array */
379     level = 0;
380     stackp = stack;
381     stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
382     stackp->offset = offset = 0;
383     which[0] = which[2] = base;
384     which[1] = aux;
385     for (;;) {
386         /* On levels where both runs have be constructed (stackp->runs == 0),
387          * merge them, and note the offset of their end, in case the offset
388          * is needed at the next level up.  Hop up a level, and,
389          * as long as stackp->runs is 0, keep merging.
390          */
391         if ((runs = stackp->runs) == 0) {
392             iwhich = level & 1;
393             list1 = which[iwhich];              /* area where runs are now */
394             list2 = which[++iwhich];            /* area for merged runs */
395             do {
396                 offset = stackp->offset;
397                 f1 = p1 = list1 + offset;               /* start of first run */
398                 p = tp2 = list2 + offset;       /* where merged run will go */
399                 t = NEXT(p);                    /* where first run ends */
400                 f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */
401                 t = NEXT(t);                    /* where second runs ends */
402                 l2 = POTHER(t, list2, list1);   /* ... on the other side */
403                 offset = PNELEM(list2, t);
404                 while (f1 < l1 && f2 < l2) {
405                     /* If head 1 is larger than head 2, find ALL the elements
406                     ** in list 2 strictly less than head1, write them all,
407                     ** then head 1.  Then compare the new heads, and repeat,
408                     ** until one or both lists are exhausted.
409                     **
410                     ** In all comparisons (after establishing
411                     ** which head to merge) the item to merge
412                     ** (at pointer q) is the first operand of
413                     ** the comparison.  When we want to know
414                     ** if "q is strictly less than the other",
415                     ** we can't just do
416                     **    cmp(q, other) < 0
417                     ** because stability demands that we treat equality
418                     ** as high when q comes from l2, and as low when
419                     ** q was from l1.  So we ask the question by doing
420                     **    cmp(q, other) <= sense
421                     ** and make sense == 0 when equality should look low,
422                     ** and -1 when equality should look high.
423                     */
424
425
426                     if (cmp(aTHX_ *f1, *f2) <= 0) {
427                         q = f2; b = f1; t = l1;
428                         sense = -1;
429                     } else {
430                         q = f1; b = f2; t = l2;
431                         sense = 0;
432                     }
433
434
435                     /* ramp up
436                     **
437                     ** Leave t at something strictly
438                     ** greater than q (or at the end of the list),
439                     ** and b at something strictly less than q.
440                     */
441                     for (i = 1, run = 0 ;;) {
442                         if ((p = PINDEX(b, i)) >= t) {
443                             /* off the end */
444                             if (((p = PINDEX(t, -1)) > b) &&
445                                 (cmp(aTHX_ *q, *p) <= sense))
446                                  t = p;
447                             else b = p;
448                             break;
449                         } else if (cmp(aTHX_ *q, *p) <= sense) {
450                             t = p;
451                             break;
452                         } else b = p;
453                         if (++run >= RTHRESH) i += i;
454                     }
455
456
457                     /* q is known to follow b and must be inserted before t.
458                     ** Increment b, so the range of possibilities is [b,t).
459                     ** Round binary split down, to favor early appearance.
460                     ** Adjust b and t until q belongs just before t.
461                     */
462
463                     b++;
464                     while (b < t) {
465                         p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
466                         if (cmp(aTHX_ *q, *p) <= sense) {
467                             t = p;
468                         } else b = p + 1;
469                     }
470
471
472                     /* Copy all the strictly low elements */
473
474                     if (q == f1) {
475                         FROMTOUPTO(f2, tp2, t);
476                         *tp2++ = *f1++;
477                     } else {
478                         FROMTOUPTO(f1, tp2, t);
479                         *tp2++ = *f2++;
480                     }
481                 }
482
483
484                 /* Run out remaining list */
485                 if (f1 == l1) {
486                        if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
487                 } else              FROMTOUPTO(f1, tp2, l1);
488                 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
489
490                 if (--level == 0) goto done;
491                 --stackp;
492                 t = list1; list1 = list2; list2 = t;    /* swap lists */
493             } while ((runs = stackp->runs) == 0);
494         }
495
496
497         stackp->runs = 0;               /* current run will finish level */
498         /* While there are more than 2 runs remaining,
499          * turn them into exactly 2 runs (at the "other" level),
500          * each made up of approximately half the runs.
501          * Stack the second half for later processing,
502          * and set about producing the first half now.
503          */
504         while (runs > 2) {
505             ++level;
506             ++stackp;
507             stackp->offset = offset;
508             runs -= stackp->runs = runs / 2;
509         }
510         /* We must construct a single run from 1 or 2 runs.
511          * All the original runs are in which[0] == base.
512          * The run we construct must end up in which[level&1].
513          */
514         iwhich = level & 1;
515         if (runs == 1) {
516             /* Constructing a single run from a single run.
517              * If it's where it belongs already, there's nothing to do.
518              * Otherwise, copy it to where it belongs.
519              * A run of 1 is either a singleton at level 0,
520              * or the second half of a split 3.  In neither event
521              * is it necessary to set offset.  It will be set by the merge
522              * that immediately follows.
523              */
524             if (iwhich) {       /* Belongs in aux, currently in base */
525                 f1 = b = PINDEX(base, offset);  /* where list starts */
526                 f2 = PINDEX(aux, offset);       /* where list goes */
527                 t = NEXT(f2);                   /* where list will end */
528                 offset = PNELEM(aux, t);        /* offset thereof */
529                 t = PINDEX(base, offset);       /* where it currently ends */
530                 FROMTOUPTO(f1, f2, t);          /* copy */
531                 NEXT(b) = t;                    /* set up parallel pointer */
532             } else if (level == 0) goto done;   /* single run at level 0 */
533         } else {
534             /* Constructing a single run from two runs.
535              * The merge code at the top will do that.
536              * We need only make sure the two runs are in the "other" array,
537              * so they'll end up in the correct array after the merge.
538              */
539             ++level;
540             ++stackp;
541             stackp->offset = offset;
542             stackp->runs = 0;   /* take care of both runs, trigger merge */
543             if (!iwhich) {      /* Merged runs belong in aux, copy 1st */
544                 f1 = b = PINDEX(base, offset);  /* where first run starts */
545                 f2 = PINDEX(aux, offset);       /* where it will be copied */
546                 t = NEXT(f2);                   /* where first run will end */
547                 offset = PNELEM(aux, t);        /* offset thereof */
548                 p = PINDEX(base, offset);       /* end of first run */
549                 t = NEXT(t);                    /* where second run will end */
550                 t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
551                 FROMTOUPTO(f1, f2, t);          /* copy both runs */
552                 NEXT(b) = p;                    /* paralled pointer for 1st */
553                 NEXT(p) = t;                    /* ... and for second */
554             }
555         }
556     }
557 done:
558     if (aux != small) Safefree(aux);    /* free iff allocated */
559     if (flags) {
560          PL_sort_RealCmp = savecmp;     /* Restore current comparison routine, if any */
561     }
562     return;
563 }
564
565 /*
566  * The quicksort implementation was derived from source code contributed
567  * by Tom Horsley.
568  *
569  * NOTE: this code was derived from Tom Horsley's qsort replacement
570  * and should not be confused with the original code.
571  */
572
573 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
574
575    Permission granted to distribute under the same terms as perl which are
576    (briefly):
577
578     This program is free software; you can redistribute it and/or modify
579     it under the terms of either:
580
581         a) the GNU General Public License as published by the Free
582         Software Foundation; either version 1, or (at your option) any
583         later version, or
584
585         b) the "Artistic License" which comes with this Kit.
586
587    Details on the perl license can be found in the perl source code which
588    may be located via the www.perl.com web page.
589
590    This is the most wonderfulest possible qsort I can come up with (and
591    still be mostly portable) My (limited) tests indicate it consistently
592    does about 20% fewer calls to compare than does the qsort in the Visual
593    C++ library, other vendors may vary.
594
595    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
596    others I invented myself (or more likely re-invented since they seemed
597    pretty obvious once I watched the algorithm operate for a while).
598
599    Most of this code was written while watching the Marlins sweep the Giants
600    in the 1997 National League Playoffs - no Braves fans allowed to use this
601    code (just kidding :-).
602
603    I realize that if I wanted to be true to the perl tradition, the only
604    comment in this file would be something like:
605
606    ...they shuffled back towards the rear of the line. 'No, not at the
607    rear!'  the slave-driver shouted. 'Three files up. And stay there...
608
609    However, I really needed to violate that tradition just so I could keep
610    track of what happens myself, not to mention some poor fool trying to
611    understand this years from now :-).
612 */
613
614 /* ********************************************************** Configuration */
615
616 #ifndef QSORT_ORDER_GUESS
617 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
618 #endif
619
620 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
621    future processing - a good max upper bound is log base 2 of memory size
622    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
623    safely be smaller than that since the program is taking up some space and
624    most operating systems only let you grab some subset of contiguous
625    memory (not to mention that you are normally sorting data larger than
626    1 byte element size :-).
627 */
628 #ifndef QSORT_MAX_STACK
629 #define QSORT_MAX_STACK 32
630 #endif
631
632 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
633    Anything bigger and we use qsort. If you make this too small, the qsort
634    will probably break (or become less efficient), because it doesn't expect
635    the middle element of a partition to be the same as the right or left -
636    you have been warned).
637 */
638 #ifndef QSORT_BREAK_EVEN
639 #define QSORT_BREAK_EVEN 6
640 #endif
641
642 /* QSORT_PLAY_SAFE is the size of the largest partition we're willing
643    to go quadratic on.  We innoculate larger partitions against
644    quadratic behavior by shuffling them before sorting.  This is not
645    an absolute guarantee of non-quadratic behavior, but it would take
646    staggeringly bad luck to pick extreme elements as the pivot
647    from randomized data.
648 */
649 #ifndef QSORT_PLAY_SAFE
650 #define QSORT_PLAY_SAFE 255
651 #endif
652
653 /* ************************************************************* Data Types */
654
655 /* hold left and right index values of a partition waiting to be sorted (the
656    partition includes both left and right - right is NOT one past the end or
657    anything like that).
658 */
659 struct partition_stack_entry {
660    int left;
661    int right;
662 #ifdef QSORT_ORDER_GUESS
663    int qsort_break_even;
664 #endif
665 };
666
667 /* ******************************************************* Shorthand Macros */
668
669 /* Note that these macros will be used from inside the qsort function where
670    we happen to know that the variable 'elt_size' contains the size of an
671    array element and the variable 'temp' points to enough space to hold a
672    temp element and the variable 'array' points to the array being sorted
673    and 'compare' is the pointer to the compare routine.
674
675    Also note that there are very many highly architecture specific ways
676    these might be sped up, but this is simply the most generally portable
677    code I could think of.
678 */
679
680 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
681 */
682 #define qsort_cmp(elt1, elt2) \
683    ((*compare)(aTHX_ array[elt1], array[elt2]))
684
685 #ifdef QSORT_ORDER_GUESS
686 #define QSORT_NOTICE_SWAP swapped++;
687 #else
688 #define QSORT_NOTICE_SWAP
689 #endif
690
691 /* swaps contents of array elements elt1, elt2.
692 */
693 #define qsort_swap(elt1, elt2) \
694    STMT_START { \
695       QSORT_NOTICE_SWAP \
696       temp = array[elt1]; \
697       array[elt1] = array[elt2]; \
698       array[elt2] = temp; \
699    } STMT_END
700
701 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
702    elt3 and elt3 gets elt1.
703 */
704 #define qsort_rotate(elt1, elt2, elt3) \
705    STMT_START { \
706       QSORT_NOTICE_SWAP \
707       temp = array[elt1]; \
708       array[elt1] = array[elt2]; \
709       array[elt2] = array[elt3]; \
710       array[elt3] = temp; \
711    } STMT_END
712
713 /* ************************************************************ Debug stuff */
714
715 #ifdef QSORT_DEBUG
716
717 static void
718 break_here()
719 {
720    return; /* good place to set a breakpoint */
721 }
722
723 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
724
725 static void
726 doqsort_all_asserts(
727    void * array,
728    size_t num_elts,
729    size_t elt_size,
730    int (*compare)(const void * elt1, const void * elt2),
731    int pc_left, int pc_right, int u_left, int u_right)
732 {
733    int i;
734
735    qsort_assert(pc_left <= pc_right);
736    qsort_assert(u_right < pc_left);
737    qsort_assert(pc_right < u_left);
738    for (i = u_right + 1; i < pc_left; ++i) {
739       qsort_assert(qsort_cmp(i, pc_left) < 0);
740    }
741    for (i = pc_left; i < pc_right; ++i) {
742       qsort_assert(qsort_cmp(i, pc_right) == 0);
743    }
744    for (i = pc_right + 1; i < u_left; ++i) {
745       qsort_assert(qsort_cmp(pc_right, i) < 0);
746    }
747 }
748
749 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
750    doqsort_all_asserts(array, num_elts, elt_size, compare, \
751                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
752
753 #else
754
755 #define qsort_assert(t) ((void)0)
756
757 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
758
759 #endif
760
761 /* ****************************************************************** qsort */
762
763 STATIC void /* the standard unstable (u) quicksort (qsort) */
764 S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
765 {
766    register SV * temp;
767
768    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
769    int next_stack_entry = 0;
770
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    /* Make sure we actually have work to do.
779    */
780    if (num_elts <= 1) {
781       return;
782    }
783
784    /* Innoculate large partitions against quadratic behavior */
785    if (num_elts > QSORT_PLAY_SAFE) {
786       register size_t n;
787       register SV ** const q = array;
788       for (n = num_elts; n > 1; ) {
789          register const size_t j = (size_t)(n-- * Drand01());
790          temp = q[j];
791          q[j] = q[n];
792          q[n] = temp;
793       }
794    }
795
796    /* Setup the initial partition definition and fall into the sorting loop
797    */
798    part_left = 0;
799    part_right = (int)(num_elts - 1);
800 #ifdef QSORT_ORDER_GUESS
801    qsort_break_even = QSORT_BREAK_EVEN;
802 #else
803 #define qsort_break_even QSORT_BREAK_EVEN
804 #endif
805    for ( ; ; ) {
806       if ((part_right - part_left) >= qsort_break_even) {
807          /* OK, this is gonna get hairy, so lets try to document all the
808             concepts and abbreviations and variables and what they keep
809             track of:
810
811             pc: pivot chunk - the set of array elements we accumulate in the
812                 middle of the partition, all equal in value to the original
813                 pivot element selected. The pc is defined by:
814
815                 pc_left - the leftmost array index of the pc
816                 pc_right - the rightmost array index of the pc
817
818                 we start with pc_left == pc_right and only one element
819                 in the pivot chunk (but it can grow during the scan).
820
821             u:  uncompared elements - the set of elements in the partition
822                 we have not yet compared to the pivot value. There are two
823                 uncompared sets during the scan - one to the left of the pc
824                 and one to the right.
825
826                 u_right - the rightmost index of the left side's uncompared set
827                 u_left - the leftmost index of the right side's uncompared set
828
829                 The leftmost index of the left sides's uncompared set
830                 doesn't need its own variable because it is always defined
831                 by the leftmost edge of the whole partition (part_left). The
832                 same goes for the rightmost edge of the right partition
833                 (part_right).
834
835                 We know there are no uncompared elements on the left once we
836                 get u_right < part_left and no uncompared elements on the
837                 right once u_left > part_right. When both these conditions
838                 are met, we have completed the scan of the partition.
839
840                 Any elements which are between the pivot chunk and the
841                 uncompared elements should be less than the pivot value on
842                 the left side and greater than the pivot value on the right
843                 side (in fact, the goal of the whole algorithm is to arrange
844                 for that to be true and make the groups of less-than and
845                 greater-then elements into new partitions to sort again).
846
847             As you marvel at the complexity of the code and wonder why it
848             has to be so confusing. Consider some of the things this level
849             of confusion brings:
850
851             Once I do a compare, I squeeze every ounce of juice out of it. I
852             never do compare calls I don't have to do, and I certainly never
853             do redundant calls.
854
855             I also never swap any elements unless I can prove there is a
856             good reason. Many sort algorithms will swap a known value with
857             an uncompared value just to get things in the right place (or
858             avoid complexity :-), but that uncompared value, once it gets
859             compared, may then have to be swapped again. A lot of the
860             complexity of this code is due to the fact that it never swaps
861             anything except compared values, and it only swaps them when the
862             compare shows they are out of position.
863          */
864          int pc_left, pc_right;
865          int u_right, u_left;
866
867          int s;
868
869          pc_left = ((part_left + part_right) / 2);
870          pc_right = pc_left;
871          u_right = pc_left - 1;
872          u_left = pc_right + 1;
873
874          /* Qsort works best when the pivot value is also the median value
875             in the partition (unfortunately you can't find the median value
876             without first sorting :-), so to give the algorithm a helping
877             hand, we pick 3 elements and sort them and use the median value
878             of that tiny set as the pivot value.
879
880             Some versions of qsort like to use the left middle and right as
881             the 3 elements to sort so they can insure the ends of the
882             partition will contain values which will stop the scan in the
883             compare loop, but when you have to call an arbitrarily complex
884             routine to do a compare, its really better to just keep track of
885             array index values to know when you hit the edge of the
886             partition and avoid the extra compare. An even better reason to
887             avoid using a compare call is the fact that you can drop off the
888             edge of the array if someone foolishly provides you with an
889             unstable compare function that doesn't always provide consistent
890             results.
891
892             So, since it is simpler for us to compare the three adjacent
893             elements in the middle of the partition, those are the ones we
894             pick here (conveniently pointed at by u_right, pc_left, and
895             u_left). The values of the left, center, and right elements
896             are refered to as l c and r in the following comments.
897          */
898
899 #ifdef QSORT_ORDER_GUESS
900          swapped = 0;
901 #endif
902          s = qsort_cmp(u_right, pc_left);
903          if (s < 0) {
904             /* l < c */
905             s = qsort_cmp(pc_left, u_left);
906             /* if l < c, c < r - already in order - nothing to do */
907             if (s == 0) {
908                /* l < c, c == r - already in order, pc grows */
909                ++pc_right;
910                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
911             } else if (s > 0) {
912                /* l < c, c > r - need to know more */
913                s = qsort_cmp(u_right, u_left);
914                if (s < 0) {
915                   /* l < c, c > r, l < r - swap c & r to get ordered */
916                   qsort_swap(pc_left, u_left);
917                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
918                } else if (s == 0) {
919                   /* l < c, c > r, l == r - swap c&r, grow pc */
920                   qsort_swap(pc_left, u_left);
921                   --pc_left;
922                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
923                } else {
924                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
925                   qsort_rotate(pc_left, u_right, u_left);
926                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
927                }
928             }
929          } else if (s == 0) {
930             /* l == c */
931             s = qsort_cmp(pc_left, u_left);
932             if (s < 0) {
933                /* l == c, c < r - already in order, grow pc */
934                --pc_left;
935                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
936             } else if (s == 0) {
937                /* l == c, c == r - already in order, grow pc both ways */
938                --pc_left;
939                ++pc_right;
940                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
941             } else {
942                /* l == c, c > r - swap l & r, grow pc */
943                qsort_swap(u_right, u_left);
944                ++pc_right;
945                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
946             }
947          } else {
948             /* l > c */
949             s = qsort_cmp(pc_left, u_left);
950             if (s < 0) {
951                /* l > c, c < r - need to know more */
952                s = qsort_cmp(u_right, u_left);
953                if (s < 0) {
954                   /* l > c, c < r, l < r - swap l & c to get ordered */
955                   qsort_swap(u_right, pc_left);
956                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
957                } else if (s == 0) {
958                   /* l > c, c < r, l == r - swap l & c, grow pc */
959                   qsort_swap(u_right, pc_left);
960                   ++pc_right;
961                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
962                } else {
963                   /* l > c, c < r, l > r - rotate lcr into crl to order */
964                   qsort_rotate(u_right, pc_left, u_left);
965                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
966                }
967             } else if (s == 0) {
968                /* l > c, c == r - swap ends, grow pc */
969                qsort_swap(u_right, u_left);
970                --pc_left;
971                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
972             } else {
973                /* l > c, c > r - swap ends to get in order */
974                qsort_swap(u_right, u_left);
975                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
976             }
977          }
978          /* We now know the 3 middle elements have been compared and
979             arranged in the desired order, so we can shrink the uncompared
980             sets on both sides
981          */
982          --u_right;
983          ++u_left;
984          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
985
986          /* The above massive nested if was the simple part :-). We now have
987             the middle 3 elements ordered and we need to scan through the
988             uncompared sets on either side, swapping elements that are on
989             the wrong side or simply shuffling equal elements around to get
990             all equal elements into the pivot chunk.
991          */
992
993          for ( ; ; ) {
994             int still_work_on_left;
995             int still_work_on_right;
996
997             /* Scan the uncompared values on the left. If I find a value
998                equal to the pivot value, move it over so it is adjacent to
999                the pivot chunk and expand the pivot chunk. If I find a value
1000                less than the pivot value, then just leave it - its already
1001                on the correct side of the partition. If I find a greater
1002                value, then stop the scan.
1003             */
1004             while ((still_work_on_left = (u_right >= part_left))) {
1005                s = qsort_cmp(u_right, pc_left);
1006                if (s < 0) {
1007                   --u_right;
1008                } else if (s == 0) {
1009                   --pc_left;
1010                   if (pc_left != u_right) {
1011                      qsort_swap(u_right, pc_left);
1012                   }
1013                   --u_right;
1014                } else {
1015                   break;
1016                }
1017                qsort_assert(u_right < pc_left);
1018                qsort_assert(pc_left <= pc_right);
1019                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
1020                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1021             }
1022
1023             /* Do a mirror image scan of uncompared values on the right
1024             */
1025             while ((still_work_on_right = (u_left <= part_right))) {
1026                s = qsort_cmp(pc_right, u_left);
1027                if (s < 0) {
1028                   ++u_left;
1029                } else if (s == 0) {
1030                   ++pc_right;
1031                   if (pc_right != u_left) {
1032                      qsort_swap(pc_right, u_left);
1033                   }
1034                   ++u_left;
1035                } else {
1036                   break;
1037                }
1038                qsort_assert(u_left > pc_right);
1039                qsort_assert(pc_left <= pc_right);
1040                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
1041                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
1042             }
1043
1044             if (still_work_on_left) {
1045                /* I know I have a value on the left side which needs to be
1046                   on the right side, but I need to know more to decide
1047                   exactly the best thing to do with it.
1048                */
1049                if (still_work_on_right) {
1050                   /* I know I have values on both side which are out of
1051                      position. This is a big win because I kill two birds
1052                      with one swap (so to speak). I can advance the
1053                      uncompared pointers on both sides after swapping both
1054                      of them into the right place.
1055                   */
1056                   qsort_swap(u_right, u_left);
1057                   --u_right;
1058                   ++u_left;
1059                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
1060                } else {
1061                   /* I have an out of position value on the left, but the
1062                      right is fully scanned, so I "slide" the pivot chunk
1063                      and any less-than values left one to make room for the
1064                      greater value over on the right. If the out of position
1065                      value is immediately adjacent to the pivot chunk (there
1066                      are no less-than values), I can do that with a swap,
1067                      otherwise, I have to rotate one of the less than values
1068                      into the former position of the out of position value
1069                      and the right end of the pivot chunk into the left end
1070                      (got all that?).
1071                   */
1072                   --pc_left;
1073                   if (pc_left == u_right) {
1074                      qsort_swap(u_right, pc_right);
1075                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1076                   } else {
1077                      qsort_rotate(u_right, pc_left, pc_right);
1078                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
1079                   }
1080                   --pc_right;
1081                   --u_right;
1082                }
1083             } else if (still_work_on_right) {
1084                /* Mirror image of complex case above: I have an out of
1085                   position value on the right, but the left is fully
1086                   scanned, so I need to shuffle things around to make room
1087                   for the right value on the left.
1088                */
1089                ++pc_right;
1090                if (pc_right == u_left) {
1091                   qsort_swap(u_left, pc_left);
1092                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1093                } else {
1094                   qsort_rotate(pc_right, pc_left, u_left);
1095                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
1096                }
1097                ++pc_left;
1098                ++u_left;
1099             } else {
1100                /* No more scanning required on either side of partition,
1101                   break out of loop and figure out next set of partitions
1102                */
1103                break;
1104             }
1105          }
1106
1107          /* The elements in the pivot chunk are now in the right place. They
1108             will never move or be compared again. All I have to do is decide
1109             what to do with the stuff to the left and right of the pivot
1110             chunk.
1111
1112             Notes on the QSORT_ORDER_GUESS ifdef code:
1113
1114             1. If I just built these partitions without swapping any (or
1115                very many) elements, there is a chance that the elements are
1116                already ordered properly (being properly ordered will
1117                certainly result in no swapping, but the converse can't be
1118                proved :-).
1119
1120             2. A (properly written) insertion sort will run faster on
1121                already ordered data than qsort will.
1122
1123             3. Perhaps there is some way to make a good guess about
1124                switching to an insertion sort earlier than partition size 6
1125                (for instance - we could save the partition size on the stack
1126                and increase the size each time we find we didn't swap, thus
1127                switching to insertion sort earlier for partitions with a
1128                history of not swapping).
1129
1130             4. Naturally, if I just switch right away, it will make
1131                artificial benchmarks with pure ascending (or descending)
1132                data look really good, but is that a good reason in general?
1133                Hard to say...
1134          */
1135
1136 #ifdef QSORT_ORDER_GUESS
1137          if (swapped < 3) {
1138 #if QSORT_ORDER_GUESS == 1
1139             qsort_break_even = (part_right - part_left) + 1;
1140 #endif
1141 #if QSORT_ORDER_GUESS == 2
1142             qsort_break_even *= 2;
1143 #endif
1144 #if QSORT_ORDER_GUESS == 3
1145             const int prev_break = qsort_break_even;
1146             qsort_break_even *= qsort_break_even;
1147             if (qsort_break_even < prev_break) {
1148                qsort_break_even = (part_right - part_left) + 1;
1149             }
1150 #endif
1151          } else {
1152             qsort_break_even = QSORT_BREAK_EVEN;
1153          }
1154 #endif
1155
1156          if (part_left < pc_left) {
1157             /* There are elements on the left which need more processing.
1158                Check the right as well before deciding what to do.
1159             */
1160             if (pc_right < part_right) {
1161                /* We have two partitions to be sorted. Stack the biggest one
1162                   and process the smallest one on the next iteration. This
1163                   minimizes the stack height by insuring that any additional
1164                   stack entries must come from the smallest partition which
1165                   (because it is smallest) will have the fewest
1166                   opportunities to generate additional stack entries.
1167                */
1168                if ((part_right - pc_right) > (pc_left - part_left)) {
1169                   /* stack the right partition, process the left */
1170                   partition_stack[next_stack_entry].left = pc_right + 1;
1171                   partition_stack[next_stack_entry].right = part_right;
1172 #ifdef QSORT_ORDER_GUESS
1173                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1174 #endif
1175                   part_right = pc_left - 1;
1176                } else {
1177                   /* stack the left partition, process the right */
1178                   partition_stack[next_stack_entry].left = part_left;
1179                   partition_stack[next_stack_entry].right = pc_left - 1;
1180 #ifdef QSORT_ORDER_GUESS
1181                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
1182 #endif
1183                   part_left = pc_right + 1;
1184                }
1185                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
1186                ++next_stack_entry;
1187             } else {
1188                /* The elements on the left are the only remaining elements
1189                   that need sorting, arrange for them to be processed as the
1190                   next partition.
1191                */
1192                part_right = pc_left - 1;
1193             }
1194          } else if (pc_right < part_right) {
1195             /* There is only one chunk on the right to be sorted, make it
1196                the new partition and loop back around.
1197             */
1198             part_left = pc_right + 1;
1199          } else {
1200             /* This whole partition wound up in the pivot chunk, so
1201                we need to get a new partition off the stack.
1202             */
1203             if (next_stack_entry == 0) {
1204                /* the stack is empty - we are done */
1205                break;
1206             }
1207             --next_stack_entry;
1208             part_left = partition_stack[next_stack_entry].left;
1209             part_right = partition_stack[next_stack_entry].right;
1210 #ifdef QSORT_ORDER_GUESS
1211             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1212 #endif
1213          }
1214       } else {
1215          /* This partition is too small to fool with qsort complexity, just
1216             do an ordinary insertion sort to minimize overhead.
1217          */
1218          int i;
1219          /* Assume 1st element is in right place already, and start checking
1220             at 2nd element to see where it should be inserted.
1221          */
1222          for (i = part_left + 1; i <= part_right; ++i) {
1223             int j;
1224             /* Scan (backwards - just in case 'i' is already in right place)
1225                through the elements already sorted to see if the ith element
1226                belongs ahead of one of them.
1227             */
1228             for (j = i - 1; j >= part_left; --j) {
1229                if (qsort_cmp(i, j) >= 0) {
1230                   /* i belongs right after j
1231                   */
1232                   break;
1233                }
1234             }
1235             ++j;
1236             if (j != i) {
1237                /* Looks like we really need to move some things
1238                */
1239                int k;
1240                temp = array[i];
1241                for (k = i - 1; k >= j; --k)
1242                   array[k + 1] = array[k];
1243                array[j] = temp;
1244             }
1245          }
1246
1247          /* That partition is now sorted, grab the next one, or get out
1248             of the loop if there aren't any more.
1249          */
1250
1251          if (next_stack_entry == 0) {
1252             /* the stack is empty - we are done */
1253             break;
1254          }
1255          --next_stack_entry;
1256          part_left = partition_stack[next_stack_entry].left;
1257          part_right = partition_stack[next_stack_entry].right;
1258 #ifdef QSORT_ORDER_GUESS
1259          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
1260 #endif
1261       }
1262    }
1263
1264    /* Believe it or not, the array is sorted at this point! */
1265 }
1266
1267 /* Stabilize what is, presumably, an otherwise unstable sort method.
1268  * We do that by allocating (or having on hand) an array of pointers
1269  * that is the same size as the original array of elements to be sorted.
1270  * We initialize this parallel array with the addresses of the original
1271  * array elements.  This indirection can make you crazy.
1272  * Some pictures can help.  After initializing, we have
1273  *
1274  *  indir                  list1
1275  * +----+                 +----+
1276  * |    | --------------> |    | ------> first element to be sorted
1277  * +----+                 +----+
1278  * |    | --------------> |    | ------> second element to be sorted
1279  * +----+                 +----+
1280  * |    | --------------> |    | ------> third element to be sorted
1281  * +----+                 +----+
1282  *  ...
1283  * +----+                 +----+
1284  * |    | --------------> |    | ------> n-1st element to be sorted
1285  * +----+                 +----+
1286  * |    | --------------> |    | ------> n-th element to be sorted
1287  * +----+                 +----+
1288  *
1289  * During the sort phase, we leave the elements of list1 where they are,
1290  * and sort the pointers in the indirect array in the same order determined
1291  * by the original comparison routine on the elements pointed to.
1292  * Because we don't move the elements of list1 around through
1293  * this phase, we can break ties on elements that compare equal
1294  * using their address in the list1 array, ensuring stabilty.
1295  * This leaves us with something looking like
1296  *
1297  *  indir                  list1
1298  * +----+                 +----+
1299  * |    | --+       +---> |    | ------> first element to be sorted
1300  * +----+   |       |     +----+
1301  * |    | --|-------|---> |    | ------> second element to be sorted
1302  * +----+   |       |     +----+
1303  * |    | --|-------+ +-> |    | ------> third element to be sorted
1304  * +----+   |         |   +----+
1305  *  ...
1306  * +----+    | |   | |    +----+
1307  * |    | ---|-+   | +--> |    | ------> n-1st element to be sorted
1308  * +----+    |     |      +----+
1309  * |    | ---+     +----> |    | ------> n-th element to be sorted
1310  * +----+                 +----+
1311  *
1312  * where the i-th element of the indirect array points to the element
1313  * that should be i-th in the sorted array.  After the sort phase,
1314  * we have to put the elements of list1 into the places
1315  * dictated by the indirect array.
1316  */
1317
1318
1319 static I32
1320 cmpindir(pTHX_ gptr a, gptr b)
1321 {
1322     I32 sense;
1323     gptr * const ap = (gptr *)a;
1324     gptr * const bp = (gptr *)b;
1325
1326     if ((sense = PL_sort_RealCmp(aTHX_ *ap, *bp)) == 0)
1327          sense = (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1328     return sense;
1329 }
1330
1331 static I32
1332 cmpindir_desc(pTHX_ gptr a, gptr b)
1333 {
1334     I32 sense;
1335     gptr * const ap = (gptr *)a;
1336     gptr * const bp = (gptr *)b;
1337
1338     /* Reverse the default */
1339     if ((sense = PL_sort_RealCmp(aTHX_ *ap, *bp)))
1340         return -sense;
1341     /* But don't reverse the stability test.  */
1342     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1343
1344 }
1345
1346 STATIC void
1347 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1348 {
1349
1350     dSORTHINTS;
1351
1352     if (SORTHINTS & HINT_SORT_STABLE) {
1353          register gptr **pp, *q;
1354          register size_t n, j, i;
1355          gptr *small[SMALLSORT], **indir, tmp;
1356          SVCOMPARE_t savecmp;
1357          if (nmemb <= 1) return;     /* sorted trivially */
1358
1359          /* Small arrays can use the stack, big ones must be allocated */
1360          if (nmemb <= SMALLSORT) indir = small;
1361          else { Newx(indir, nmemb, gptr *); }
1362
1363          /* Copy pointers to original array elements into indirect array */
1364          for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++;
1365
1366          savecmp = PL_sort_RealCmp;     /* Save current comparison routine, if any */
1367          PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
1368
1369          /* sort, with indirection */
1370          S_qsortsvu(aTHX_ (gptr *)indir, nmemb,
1371                     flags ? cmpindir_desc : cmpindir);
1372
1373          pp = indir;
1374          q = list1;
1375          for (n = nmemb; n--; ) {
1376               /* Assert A: all elements of q with index > n are already
1377                * in place.  This is vacuosly 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.
1382                */
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.
1386                                          */
1387               if (n != j) {             /* all's well if n == j */
1388                    tmp = q[j];          /* save what's in q[j] */
1389                    do {
1390                         q[j] = *pp[j];  /* put *pp[j] where it belongs */
1391                         i = pp[j] - q;  /* the index in q of the element
1392                                          * just moved */
1393                         pp[j] = q + j;  /* this is ok now */
1394                    } while ((j = i) != n);
1395                    /* There are only finitely many (nmemb) addresses
1396                     * in the pp array.
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.
1404                     */
1405                    q[n] = tmp;          /* put what belongs into
1406                                          * the n-th element */
1407               }
1408          }
1409
1410         /* free iff allocated */
1411          if (indir != small) { Safefree(indir); }
1412          /* restore prevailing comparison routine */
1413          PL_sort_RealCmp = savecmp;
1414     } else if (flags) {
1415          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 */
1417          cmp = cmp_desc;
1418          S_qsortsvu(aTHX_ list1, nmemb, cmp);
1419          /* restore prevailing comparison routine */
1420          PL_sort_RealCmp = savecmp;
1421     } else {
1422          S_qsortsvu(aTHX_ list1, nmemb, cmp);
1423     }
1424 }
1425
1426 /*
1427 =head1 Array Manipulation Functions
1428
1429 =for apidoc sortsv
1430
1431 Sort an array. Here is an example:
1432
1433     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
1434
1435 See lib/sort.pm for details about controlling the sorting algorithm.
1436
1437 =cut
1438 */
1439
1440 void
1441 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1442 {
1443     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1444       = S_mergesortsv;
1445     dSORTHINTS;
1446     const I32 hints = SORTHINTS;
1447     if (hints & HINT_SORT_QUICKSORT) {
1448         sortsvp = S_qsortsv;
1449     }
1450     else {
1451         /* The default as of 5.8.0 is mergesort */
1452         sortsvp = S_mergesortsv;
1453     }
1454
1455     sortsvp(aTHX_ array, nmemb, cmp, 0);
1456 }
1457
1458
1459 static void
1460 S_sortsv_desc(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1461 {
1462     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1463       = S_mergesortsv;
1464     dSORTHINTS;
1465     const I32 hints = SORTHINTS;
1466     if (hints & HINT_SORT_QUICKSORT) {
1467         sortsvp = S_qsortsv;
1468     }
1469     else {
1470         /* The default as of 5.8.0 is mergesort */
1471         sortsvp = S_mergesortsv;
1472     }
1473
1474     sortsvp(aTHX_ array, nmemb, cmp, 1);
1475 }
1476
1477 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
1478 #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
1479 #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
1480
1481 PP(pp_sort)
1482 {
1483     dVAR; dSP; dMARK; dORIGMARK;
1484     register SV **p1 = ORIGMARK+1, **p2;
1485     register I32 max, i;
1486     AV* av = Nullav;
1487     HV *stash;
1488     GV *gv;
1489     CV *cv = 0;
1490     I32 gimme = GIMME;
1491     OP* nextop = PL_op->op_next;
1492     I32 overloading = 0;
1493     bool hasargs = FALSE;
1494     I32 is_xsub = 0;
1495     I32 sorting_av = 0;
1496     const U8 priv = PL_op->op_private;
1497     const U8 flags = PL_op->op_flags;
1498     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1499       = Perl_sortsv;
1500     I32 all_SIVs = 1;
1501
1502     if (gimme != G_ARRAY) {
1503         SP = MARK;
1504         RETPUSHUNDEF;
1505     }
1506
1507     ENTER;
1508     SAVEVPTR(PL_sortcop);
1509     if (flags & OPf_STACKED) {
1510         if (flags & OPf_SPECIAL) {
1511             OP *kid = cLISTOP->op_first->op_sibling;    /* pass pushmark */
1512             kid = kUNOP->op_first;                      /* pass rv2gv */
1513             kid = kUNOP->op_first;                      /* pass leave */
1514             PL_sortcop = kid->op_next;
1515             stash = CopSTASH(PL_curcop);
1516         }
1517         else {
1518             cv = sv_2cv(*++MARK, &stash, &gv, 0);
1519             if (cv && SvPOK(cv)) {
1520                 const char *proto = SvPV_nolen_const((SV*)cv);
1521                 if (proto && strEQ(proto, "$$")) {
1522                     hasargs = TRUE;
1523                 }
1524             }
1525             if (!(cv && CvROOT(cv))) {
1526                 if (cv && CvXSUB(cv)) {
1527                     is_xsub = 1;
1528                 }
1529                 else if (gv) {
1530                     SV *tmpstr = sv_newmortal();
1531                     gv_efullname3(tmpstr, gv, Nullch);
1532                     DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
1533                         tmpstr);
1534                 }
1535                 else {
1536                     DIE(aTHX_ "Undefined subroutine in sort");
1537                 }
1538             }
1539
1540             if (is_xsub)
1541                 PL_sortcop = (OP*)cv;
1542             else {
1543                 PL_sortcop = CvSTART(cv);
1544                 SAVEVPTR(CvROOT(cv)->op_ppaddr);
1545                 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
1546
1547                 SAVECOMPPAD();
1548                 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1549             }
1550         }
1551     }
1552     else {
1553         PL_sortcop = Nullop;
1554         stash = CopSTASH(PL_curcop);
1555     }
1556
1557     /* optimiser converts "@a = sort @a" to "sort \@a";
1558      * in case of tied @a, pessimise: push (@a) onto stack, then assign
1559      * result back to @a at the end of this function */
1560     if (priv & OPpSORT_INPLACE) {
1561         assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
1562         (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
1563         av = (AV*)(*SP);
1564         max = AvFILL(av) + 1;
1565         if (SvMAGICAL(av)) {
1566             MEXTEND(SP, max);
1567             p2 = SP;
1568             for (i=0; i < max; i++) {
1569                 SV **svp = av_fetch(av, i, FALSE);
1570                 *SP++ = (svp) ? *svp : Nullsv;
1571             }
1572         }
1573         else {
1574             p1 = p2 = AvARRAY(av);
1575             sorting_av = 1;
1576         }
1577     }
1578     else {
1579         p2 = MARK+1;
1580         max = SP - MARK;
1581    }
1582
1583     if (priv & OPpSORT_DESCEND) {
1584         sortsvp = S_sortsv_desc;
1585     }
1586
1587     /* shuffle stack down, removing optional initial cv (p1!=p2), plus
1588      * any nulls; also stringify or converting to integer or number as
1589      * required any args */
1590     for (i=max; i > 0 ; i--) {
1591         if ((*p1 = *p2++)) {                    /* Weed out nulls. */
1592             SvTEMP_off(*p1);
1593             if (!PL_sortcop) {
1594                 if (priv & OPpSORT_NUMERIC) {
1595                     if (priv & OPpSORT_INTEGER) {
1596                         if (!SvIOK(*p1)) {
1597                             if (SvAMAGIC(*p1))
1598                                 overloading = 1;
1599                             else
1600                                 (void)sv_2iv(*p1);
1601                         }
1602                     }
1603                     else {
1604                         if (!SvNSIOK(*p1)) {
1605                             if (SvAMAGIC(*p1))
1606                                 overloading = 1;
1607                             else
1608                                 (void)sv_2nv(*p1);
1609                         }
1610                         if (all_SIVs && !SvSIOK(*p1))
1611                             all_SIVs = 0;
1612                     }
1613                 }
1614                 else {
1615                     if (!SvPOK(*p1)) {
1616                         if (SvAMAGIC(*p1))
1617                             overloading = 1;
1618                         else
1619                             (void)sv_2pv_flags(*p1, 0,
1620                                                SV_GMAGIC|SV_CONST_RETURN);
1621                     }
1622                 }
1623             }
1624             p1++;
1625         }
1626         else
1627             max--;
1628     }
1629     if (sorting_av)
1630         AvFILLp(av) = max-1;
1631
1632     if (max > 1) {
1633         SV **start;
1634         if (PL_sortcop) {
1635             PERL_CONTEXT *cx;
1636             SV** newsp;
1637             const bool oldcatch = CATCH_GET;
1638
1639             SAVETMPS;
1640             SAVEOP();
1641
1642             CATCH_SET(TRUE);
1643             PUSHSTACKi(PERLSI_SORT);
1644             if (!hasargs && !is_xsub) {
1645                 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
1646                     SAVESPTR(PL_firstgv);
1647                     SAVESPTR(PL_secondgv);
1648                     PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
1649                     PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
1650                     PL_sortstash = stash;
1651                 }
1652                 SAVESPTR(GvSV(PL_firstgv));
1653                 SAVESPTR(GvSV(PL_secondgv));
1654             }
1655
1656             PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1657             if (!(flags & OPf_SPECIAL)) {
1658                 cx->cx_type = CXt_SUB;
1659                 cx->blk_gimme = G_SCALAR;
1660                 PUSHSUB(cx);
1661             }
1662             PL_sortcxix = cxstack_ix;
1663
1664             if (hasargs && !is_xsub) {
1665                 /* This is mostly copied from pp_entersub */
1666                 AV *av = (AV*)PAD_SVl(0);
1667
1668                 cx->blk_sub.savearray = GvAV(PL_defgv);
1669                 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1670                 CX_CURPAD_SAVE(cx->blk_sub);
1671                 cx->blk_sub.argarray = av;
1672             }
1673             
1674             start = p1 - max;
1675             sortsvp(aTHX_ start, max,
1676                     is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1677
1678             POPBLOCK(cx,PL_curpm);
1679             PL_stack_sp = newsp;
1680             POPSTACK;
1681             CATCH_SET(oldcatch);
1682         }
1683         else {
1684             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
1685             start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
1686             sortsvp(aTHX_ start, max,
1687                     (priv & OPpSORT_NUMERIC)
1688                         ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1689                             ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1690                             : ( overloading ? amagic_ncmp : sv_ncmp ) )
1691                         : ( IN_LOCALE_RUNTIME
1692                             ? ( overloading
1693                                 ? amagic_cmp_locale
1694                                 : sv_cmp_locale_static)
1695                             : ( overloading ? amagic_cmp : sv_cmp_static)));
1696         }
1697         if (priv & OPpSORT_REVERSE) {
1698             SV **q = start+max-1;
1699             while (start < q) {
1700                 SV *tmp = *start;
1701                 *start++ = *q;
1702                 *q-- = tmp;
1703             }
1704         }
1705     }
1706     if (av && !sorting_av) {
1707         /* simulate pp_aassign of tied AV */
1708         SV** const base = ORIGMARK+1;
1709         for (i=0; i < max; i++) {
1710             base[i] = newSVsv(base[i]);
1711         }
1712         av_clear(av);
1713         av_extend(av, max);
1714         for (i=0; i < max; i++) {
1715             SV * const sv = base[i];
1716             SV **didstore = av_store(av, i, sv);
1717             if (SvSMAGICAL(sv))
1718                 mg_set(sv);
1719             if (!didstore)
1720                 sv_2mortal(sv);
1721         }
1722     }
1723     LEAVE;
1724     PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
1725     return nextop;
1726 }
1727
1728 static I32
1729 sortcv(pTHX_ SV *a, SV *b)
1730 {
1731     dVAR;
1732     const I32 oldsaveix = PL_savestack_ix;
1733     const I32 oldscopeix = PL_scopestack_ix;
1734     I32 result;
1735     GvSV(PL_firstgv) = a;
1736     GvSV(PL_secondgv) = b;
1737     PL_stack_sp = PL_stack_base;
1738     PL_op = PL_sortcop;
1739     CALLRUNOPS(aTHX);
1740     if (PL_stack_sp != PL_stack_base + 1)
1741         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1742     if (!SvNIOKp(*PL_stack_sp))
1743         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1744     result = SvIV(*PL_stack_sp);
1745     while (PL_scopestack_ix > oldscopeix) {
1746         LEAVE;
1747     }
1748     leave_scope(oldsaveix);
1749     return result;
1750 }
1751
1752 static I32
1753 sortcv_stacked(pTHX_ SV *a, SV *b)
1754 {
1755     dVAR;
1756     const I32 oldsaveix = PL_savestack_ix;
1757     const I32 oldscopeix = PL_scopestack_ix;
1758     I32 result;
1759     AV * const av = GvAV(PL_defgv);
1760
1761     if (AvMAX(av) < 1) {
1762         SV** ary = AvALLOC(av);
1763         if (AvARRAY(av) != ary) {
1764             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1765             SvPV_set(av, (char*)ary);
1766         }
1767         if (AvMAX(av) < 1) {
1768             AvMAX(av) = 1;
1769             Renew(ary,2,SV*);
1770             SvPV_set(av, (char*)ary);
1771         }
1772     }
1773     AvFILLp(av) = 1;
1774
1775     AvARRAY(av)[0] = a;
1776     AvARRAY(av)[1] = b;
1777     PL_stack_sp = PL_stack_base;
1778     PL_op = PL_sortcop;
1779     CALLRUNOPS(aTHX);
1780     if (PL_stack_sp != PL_stack_base + 1)
1781         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1782     if (!SvNIOKp(*PL_stack_sp))
1783         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1784     result = SvIV(*PL_stack_sp);
1785     while (PL_scopestack_ix > oldscopeix) {
1786         LEAVE;
1787     }
1788     leave_scope(oldsaveix);
1789     return result;
1790 }
1791
1792 static I32
1793 sortcv_xsub(pTHX_ SV *a, SV *b)
1794 {
1795     dVAR; dSP;
1796     const I32 oldsaveix = PL_savestack_ix;
1797     const I32 oldscopeix = PL_scopestack_ix;
1798     CV * const cv=(CV*)PL_sortcop;
1799     I32 result;
1800
1801     SP = PL_stack_base;
1802     PUSHMARK(SP);
1803     EXTEND(SP, 2);
1804     *++SP = a;
1805     *++SP = b;
1806     PUTBACK;
1807     (void)(*CvXSUB(cv))(aTHX_ cv);
1808     if (PL_stack_sp != PL_stack_base + 1)
1809         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1810     if (!SvNIOKp(*PL_stack_sp))
1811         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1812     result = SvIV(*PL_stack_sp);
1813     while (PL_scopestack_ix > oldscopeix) {
1814         LEAVE;
1815     }
1816     leave_scope(oldsaveix);
1817     return result;
1818 }
1819
1820
1821 static I32
1822 sv_ncmp(pTHX_ SV *a, SV *b)
1823 {
1824     const NV nv1 = SvNSIV(a);
1825     const NV nv2 = SvNSIV(b);
1826     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
1827 }
1828
1829 static I32
1830 sv_i_ncmp(pTHX_ SV *a, SV *b)
1831 {
1832     const IV iv1 = SvIV(a);
1833     const IV iv2 = SvIV(b);
1834     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1835 }
1836
1837 #define tryCALL_AMAGICbin(left,right,meth) \
1838     (PL_amagic_generation && (SvAMAGIC(left)||SvAMAGIC(right))) \
1839         ? amagic_call(left, right, CAT2(meth,_amg), 0) \
1840         : Nullsv;
1841
1842 static I32
1843 amagic_ncmp(pTHX_ register SV *a, register SV *b)
1844 {
1845     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
1846     if (tmpsv) {
1847         if (SvIOK(tmpsv)) {
1848             const I32 i = SvIVX(tmpsv);
1849             if (i > 0)
1850                return 1;
1851             return i? -1 : 0;
1852         }
1853         else {
1854             const NV d = SvNV(tmpsv);
1855             if (d > 0)
1856                return 1;
1857             return d ? -1 : 0;
1858         }
1859      }
1860      return sv_ncmp(aTHX_ a, b);
1861 }
1862
1863 static I32
1864 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
1865 {
1866     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
1867     if (tmpsv) {
1868         if (SvIOK(tmpsv)) {
1869             const I32 i = SvIVX(tmpsv);
1870             if (i > 0)
1871                return 1;
1872             return i? -1 : 0;
1873         }
1874         else {
1875             const NV d = SvNV(tmpsv);
1876             if (d > 0)
1877                return 1;
1878             return d ? -1 : 0;
1879         }
1880     }
1881     return sv_i_ncmp(aTHX_ a, b);
1882 }
1883
1884 static I32
1885 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
1886 {
1887     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
1888     if (tmpsv) {
1889         if (SvIOK(tmpsv)) {
1890             const I32 i = SvIVX(tmpsv);
1891             if (i > 0)
1892                return 1;
1893             return i? -1 : 0;
1894         }
1895         else {
1896             const NV d = SvNV(tmpsv);
1897             if (d > 0)
1898                return 1;
1899             return d? -1 : 0;
1900         }
1901     }
1902     return sv_cmp(str1, str2);
1903 }
1904
1905 static I32
1906 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
1907 {
1908     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
1909     if (tmpsv) {
1910         if (SvIOK(tmpsv)) {
1911             const I32 i = SvIVX(tmpsv);
1912             if (i > 0)
1913                return 1;
1914             return i? -1 : 0;
1915         }
1916         else {
1917             const NV d = SvNV(tmpsv);
1918             if (d > 0)
1919                return 1;
1920             return d? -1 : 0;
1921         }
1922     }
1923     return sv_cmp_locale(str1, str2);
1924 }
1925
1926 /*
1927  * Local variables:
1928  * c-indentation-style: bsd
1929  * c-basic-offset: 4
1930  * indent-tabs-mode: t
1931  * End:
1932  *
1933  * ex: set ts=8 sts=4 sw=4 noet:
1934  */