This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.30.2-RC1 today
[perl5.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 #define sv_cmp_static Perl_sv_cmp
34 #define sv_cmp_locale_static Perl_sv_cmp_locale
35
36 #ifndef SMALLSORT
37 #define SMALLSORT (200)
38 #endif
39
40 /* Flags for qsortsv and mergesortsv */
41 #define SORTf_DESC   1
42 #define SORTf_STABLE 2
43 #define SORTf_UNSTABLE 8
44
45 /*
46  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
47  *
48  * The original code was written in conjunction with BSD Computer Software
49  * Research Group at University of California, Berkeley.
50  *
51  * See also: "Optimistic Sorting and Information Theoretic Complexity"
52  *           Peter McIlroy
53  *           SODA (Fourth Annual ACM-SIAM Symposium on Discrete Algorithms),
54  *           pp 467-474, Austin, Texas, 25-27 January 1993.
55  *
56  * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
57  *
58  * The code can be distributed under the same terms as Perl itself.
59  *
60  */
61
62
63 typedef char * aptr;            /* pointer for arithmetic on sizes */
64 typedef SV * gptr;              /* pointers in our lists */
65
66 /* Binary merge internal sort, with a few special mods
67 ** for the special perl environment it now finds itself in.
68 **
69 ** Things that were once options have been hotwired
70 ** to values suitable for this use.  In particular, we'll always
71 ** initialize looking for natural runs, we'll always produce stable
72 ** output, and we'll always do Peter McIlroy's binary merge.
73 */
74
75 /* Pointer types for arithmetic and storage and convenience casts */
76
77 #define APTR(P) ((aptr)(P))
78 #define GPTP(P) ((gptr *)(P))
79 #define GPPP(P) ((gptr **)(P))
80
81
82 /* byte offset from pointer P to (larger) pointer Q */
83 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
84
85 #define PSIZE sizeof(gptr)
86
87 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
88
89 #ifdef  PSHIFT
90 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
91 #define PNBYTE(N)       ((N) << (PSHIFT))
92 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
93 #else
94 /* Leave optimization to compiler */
95 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
96 #define PNBYTE(N)       ((N) * (PSIZE))
97 #define PINDEX(P, N)    (GPTP(P) + (N))
98 #endif
99
100 /* Pointer into other corresponding to pointer into this */
101 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
102
103 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
104
105
106 /* Runs are identified by a pointer in the auxiliary list.
107 ** The pointer is at the start of the list,
108 ** and it points to the start of the next list.
109 ** NEXT is used as an lvalue, too.
110 */
111
112 #define NEXT(P)         (*GPPP(P))
113
114
115 /* PTHRESH is the minimum number of pairs with the same sense to justify
116 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
117 ** not just elements, so PTHRESH == 8 means a run of 16.
118 */
119
120 #define PTHRESH (8)
121
122 /* RTHRESH is the number of elements in a run that must compare low
123 ** to the low element from the opposing run before we justify
124 ** doing a binary rampup instead of single stepping.
125 ** In random input, N in a row low should only happen with
126 ** probability 2^(1-N), so we can risk that we are dealing
127 ** with orderly input without paying much when we aren't.
128 */
129
130 #define RTHRESH (6)
131
132
133 /*
134 ** Overview of algorithm and variables.
135 ** The array of elements at list1 will be organized into runs of length 2,
136 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
137 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
138 **
139 ** Unless otherwise specified, pair pointers address the first of two elements.
140 **
141 ** b and b+1 are a pair that compare with sense "sense".
142 ** b is the "bottom" of adjacent pairs that might form a longer run.
143 **
144 ** p2 parallels b in the list2 array, where runs are defined by
145 ** a pointer chain.
146 **
147 ** t represents the "top" of the adjacent pairs that might extend
148 ** the run beginning at b.  Usually, t addresses a pair
149 ** that compares with opposite sense from (b,b+1).
150 ** However, it may also address a singleton element at the end of list1,
151 ** or it may be equal to "last", the first element beyond list1.
152 **
153 ** r addresses the Nth pair following b.  If this would be beyond t,
154 ** we back it off to t.  Only when r is less than t do we consider the
155 ** run long enough to consider checking.
156 **
157 ** q addresses a pair such that the pairs at b through q already form a run.
158 ** Often, q will equal b, indicating we only are sure of the pair itself.
159 ** However, a search on the previous cycle may have revealed a longer run,
160 ** so q may be greater than b.
161 **
162 ** p is used to work back from a candidate r, trying to reach q,
163 ** which would mean b through r would be a run.  If we discover such a run,
164 ** we start q at r and try to push it further towards t.
165 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
166 ** In any event, after the check (if any), we have two main cases.
167 **
168 ** 1) Short run.  b <= q < p <= r <= t.
169 **      b through q is a run (perhaps trivial)
170 **      q through p are uninteresting pairs
171 **      p through r is a run
172 **
173 ** 2) Long run.  b < r <= q < t.
174 **      b through q is a run (of length >= 2 * PTHRESH)
175 **
176 ** Note that degenerate cases are not only possible, but likely.
177 ** For example, if the pair following b compares with opposite sense,
178 ** then b == q < p == r == t.
179 */
180
181
182 static IV
183 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
184 {
185     I32 sense;
186     gptr *b, *p, *q, *t, *p2;
187     gptr *last, *r;
188     IV runs = 0;
189
190     b = list1;
191     last = PINDEX(b, nmemb);
192     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
193     for (p2 = list2; b < last; ) {
194         /* We just started, or just reversed sense.
195         ** Set t at end of pairs with the prevailing sense.
196         */
197         for (p = b+2, t = p; ++p < last; t = ++p) {
198             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
199         }
200         q = b;
201         /* Having laid out the playing field, look for long runs */
202         do {
203             p = r = b + (2 * PTHRESH);
204             if (r >= t) p = r = t;      /* too short to care about */
205             else {
206                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
207                        ((p -= 2) > q)) {}
208                 if (p <= q) {
209                     /* b through r is a (long) run.
210                     ** Extend it as far as possible.
211                     */
212                     p = q = r;
213                     while (((p += 2) < t) &&
214                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
215                     r = p = q + 2;      /* no simple pairs, no after-run */
216                 }
217             }
218             if (q > b) {                /* run of greater than 2 at b */
219                 gptr *savep = p;
220
221                 p = q += 2;
222                 /* pick up singleton, if possible */
223                 if ((p == t) &&
224                     ((t + 1) == last) &&
225                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
226                     savep = r = p = q = last;
227                 p2 = NEXT(p2) = p2 + (p - b); ++runs;
228                 if (sense)
229                     while (b < --p) {
230                         const gptr c = *b;
231                         *b++ = *p;
232                         *p = c;
233                     }
234                 p = savep;
235             }
236             while (q < p) {             /* simple pairs */
237                 p2 = NEXT(p2) = p2 + 2; ++runs;
238                 if (sense) {
239                     const gptr c = *q++;
240                     *(q-1) = *q;
241                     *q++ = c;
242                 } else q += 2;
243             }
244             if (((b = p) == t) && ((t+1) == last)) {
245                 NEXT(p2) = p2 + 1; ++runs;
246                 b++;
247             }
248             q = r;
249         } while (b < t);
250         sense = !sense;
251     }
252     return runs;
253 }
254
255
256 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
257  * qsort on many platforms, but slower than qsort, conspicuously so,
258  * on others.  The most likely explanation was platform-specific
259  * differences in cache sizes and relative speeds.
260  *
261  * The quicksort divide-and-conquer algorithm guarantees that, as the
262  * problem is subdivided into smaller and smaller parts, the parts
263  * fit into smaller (and faster) caches.  So it doesn't matter how
264  * many levels of cache exist, quicksort will "find" them, and,
265  * as long as smaller is faster, take advantage of them.
266  *
267  * By contrast, consider how the original mergesort algorithm worked.
268  * Suppose we have five runs (each typically of length 2 after dynprep).
269  * 
270  * pass               base                        aux
271  *  0              1 2 3 4 5
272  *  1                                           12 34 5
273  *  2                1234 5
274  *  3                                            12345
275  *  4                 12345
276  *
277  * Adjacent pairs are merged in "grand sweeps" through the input.
278  * This means, on pass 1, the records in runs 1 and 2 aren't revisited until
279  * runs 3 and 4 are merged and the runs from run 5 have been copied.
280  * The only cache that matters is one large enough to hold *all* the input.
281  * On some platforms, this may be many times slower than smaller caches.
282  *
283  * The following pseudo-code uses the same basic merge algorithm,
284  * but in a divide-and-conquer way.
285  *
286  * # merge $runs runs at offset $offset of list $list1 into $list2.
287  * # all unmerged runs ($runs == 1) originate in list $base.
288  * sub mgsort2 {
289  *     my ($offset, $runs, $base, $list1, $list2) = @_;
290  *
291  *     if ($runs == 1) {
292  *         if ($list1 is $base) copy run to $list2
293  *         return offset of end of list (or copy)
294  *     } else {
295  *         $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1)
296  *         mgsort2($off2, $runs/2, $base, $list2, $list1)
297  *         merge the adjacent runs at $offset of $list1 into $list2
298  *         return the offset of the end of the merged runs
299  *     }
300  * }
301  * mgsort2(0, $runs, $base, $aux, $base);
302  *
303  * For our 5 runs, the tree of calls looks like 
304  *
305  *           5
306  *      3        2
307  *   2     1   1   1
308  * 1   1
309  *
310  * 1   2   3   4   5
311  *
312  * and the corresponding activity looks like
313  *
314  * copy runs 1 and 2 from base to aux
315  * merge runs 1 and 2 from aux to base
316  * (run 3 is where it belongs, no copy needed)
317  * merge runs 12 and 3 from base to aux
318  * (runs 4 and 5 are where they belong, no copy needed)
319  * merge runs 4 and 5 from base to aux
320  * merge runs 123 and 45 from aux to base
321  *
322  * Note that we merge runs 1 and 2 immediately after copying them,
323  * while they are still likely to be in fast cache.  Similarly,
324  * run 3 is merged with run 12 while it still may be lingering in cache.
325  * This implementation should therefore enjoy much of the cache-friendly
326  * behavior that quicksort does.  In addition, it does less copying
327  * than the original mergesort implementation (only runs 1 and 2 are copied)
328  * and the "balancing" of merges is better (merged runs comprise more nearly
329  * equal numbers of original runs).
330  *
331  * The actual cache-friendly implementation will use a pseudo-stack
332  * to avoid recursion, and will unroll processing of runs of length 2,
333  * but it is otherwise similar to the recursive implementation.
334  */
335
336 typedef struct {
337     IV  offset;         /* offset of 1st of 2 runs at this level */
338     IV  runs;           /* how many runs must be combined into 1 */
339 } off_runs;             /* pseudo-stack element */
340
341
342 static I32
343 cmp_desc(pTHX_ gptr const a, gptr const b)
344 {
345     return -PL_sort_RealCmp(aTHX_ a, b);
346 }
347
348 /*
349 =head1 SV Manipulation Functions
350
351 =for apidoc sortsv_flags
352
353 In-place sort an array of SV pointers with the given comparison routine,
354 with various SORTf_* flag options.
355
356 =cut
357 */
358 void
359 Perl_sortsv_flags(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
360 {
361     IV i, run, offset;
362     I32 sense, level;
363     gptr *f1, *f2, *t, *b, *p;
364     int iwhich;
365     gptr *aux;
366     gptr *p1;
367     gptr small[SMALLSORT];
368     gptr *which[3];
369     off_runs stack[60], *stackp;
370     SVCOMPARE_t savecmp = NULL;
371
372     PERL_ARGS_ASSERT_SORTSV_FLAGS;
373     if (nmemb <= 1) return;                     /* sorted trivially */
374
375     if ((flags & SORTf_DESC) != 0) {
376         savecmp = PL_sort_RealCmp;      /* Save current comparison routine, if any */
377         PL_sort_RealCmp = cmp;  /* Put comparison routine where cmp_desc can find it */
378         cmp = cmp_desc;
379     }
380
381     if (nmemb <= SMALLSORT) aux = small;        /* use stack for aux array */
382     else { Newx(aux,nmemb,gptr); }              /* allocate auxiliary array */
383     level = 0;
384     stackp = stack;
385     stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
386     stackp->offset = offset = 0;
387     which[0] = which[2] = base;
388     which[1] = aux;
389     for (;;) {
390         /* On levels where both runs have be constructed (stackp->runs == 0),
391          * merge them, and note the offset of their end, in case the offset
392          * is needed at the next level up.  Hop up a level, and,
393          * as long as stackp->runs is 0, keep merging.
394          */
395         IV runs = stackp->runs;
396         if (runs == 0) {
397             gptr *list1, *list2;
398             iwhich = level & 1;
399             list1 = which[iwhich];              /* area where runs are now */
400             list2 = which[++iwhich];            /* area for merged runs */
401             do {
402                 gptr *l1, *l2, *tp2;
403                 offset = stackp->offset;
404                 f1 = p1 = list1 + offset;               /* start of first run */
405                 p = tp2 = list2 + offset;       /* where merged run will go */
406                 t = NEXT(p);                    /* where first run ends */
407                 f2 = l1 = POTHER(t, list2, list1); /* ... on the other side */
408                 t = NEXT(t);                    /* where second runs ends */
409                 l2 = POTHER(t, list2, list1);   /* ... on the other side */
410                 offset = PNELEM(list2, t);
411                 while (f1 < l1 && f2 < l2) {
412                     /* If head 1 is larger than head 2, find ALL the elements
413                     ** in list 2 strictly less than head1, write them all,
414                     ** then head 1.  Then compare the new heads, and repeat,
415                     ** until one or both lists are exhausted.
416                     **
417                     ** In all comparisons (after establishing
418                     ** which head to merge) the item to merge
419                     ** (at pointer q) is the first operand of
420                     ** the comparison.  When we want to know
421                     ** if "q is strictly less than the other",
422                     ** we can't just do
423                     **    cmp(q, other) < 0
424                     ** because stability demands that we treat equality
425                     ** as high when q comes from l2, and as low when
426                     ** q was from l1.  So we ask the question by doing
427                     **    cmp(q, other) <= sense
428                     ** and make sense == 0 when equality should look low,
429                     ** and -1 when equality should look high.
430                     */
431
432                     gptr *q;
433                     if (cmp(aTHX_ *f1, *f2) <= 0) {
434                         q = f2; b = f1; t = l1;
435                         sense = -1;
436                     } else {
437                         q = f1; b = f2; t = l2;
438                         sense = 0;
439                     }
440
441
442                     /* ramp up
443                     **
444                     ** Leave t at something strictly
445                     ** greater than q (or at the end of the list),
446                     ** and b at something strictly less than q.
447                     */
448                     for (i = 1, run = 0 ;;) {
449                         if ((p = PINDEX(b, i)) >= t) {
450                             /* off the end */
451                             if (((p = PINDEX(t, -1)) > b) &&
452                                 (cmp(aTHX_ *q, *p) <= sense))
453                                  t = p;
454                             else b = p;
455                             break;
456                         } else if (cmp(aTHX_ *q, *p) <= sense) {
457                             t = p;
458                             break;
459                         } else b = p;
460                         if (++run >= RTHRESH) i += i;
461                     }
462
463
464                     /* q is known to follow b and must be inserted before t.
465                     ** Increment b, so the range of possibilities is [b,t).
466                     ** Round binary split down, to favor early appearance.
467                     ** Adjust b and t until q belongs just before t.
468                     */
469
470                     b++;
471                     while (b < t) {
472                         p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
473                         if (cmp(aTHX_ *q, *p) <= sense) {
474                             t = p;
475                         } else b = p + 1;
476                     }
477
478
479                     /* Copy all the strictly low elements */
480
481                     if (q == f1) {
482                         FROMTOUPTO(f2, tp2, t);
483                         *tp2++ = *f1++;
484                     } else {
485                         FROMTOUPTO(f1, tp2, t);
486                         *tp2++ = *f2++;
487                     }
488                 }
489
490
491                 /* Run out remaining list */
492                 if (f1 == l1) {
493                        if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
494                 } else              FROMTOUPTO(f1, tp2, l1);
495                 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
496
497                 if (--level == 0) goto done;
498                 --stackp;
499                 t = list1; list1 = list2; list2 = t;    /* swap lists */
500             } while ((runs = stackp->runs) == 0);
501         }
502
503
504         stackp->runs = 0;               /* current run will finish level */
505         /* While there are more than 2 runs remaining,
506          * turn them into exactly 2 runs (at the "other" level),
507          * each made up of approximately half the runs.
508          * Stack the second half for later processing,
509          * and set about producing the first half now.
510          */
511         while (runs > 2) {
512             ++level;
513             ++stackp;
514             stackp->offset = offset;
515             runs -= stackp->runs = runs / 2;
516         }
517         /* We must construct a single run from 1 or 2 runs.
518          * All the original runs are in which[0] == base.
519          * The run we construct must end up in which[level&1].
520          */
521         iwhich = level & 1;
522         if (runs == 1) {
523             /* Constructing a single run from a single run.
524              * If it's where it belongs already, there's nothing to do.
525              * Otherwise, copy it to where it belongs.
526              * A run of 1 is either a singleton at level 0,
527              * or the second half of a split 3.  In neither event
528              * is it necessary to set offset.  It will be set by the merge
529              * that immediately follows.
530              */
531             if (iwhich) {       /* Belongs in aux, currently in base */
532                 f1 = b = PINDEX(base, offset);  /* where list starts */
533                 f2 = PINDEX(aux, offset);       /* where list goes */
534                 t = NEXT(f2);                   /* where list will end */
535                 offset = PNELEM(aux, t);        /* offset thereof */
536                 t = PINDEX(base, offset);       /* where it currently ends */
537                 FROMTOUPTO(f1, f2, t);          /* copy */
538                 NEXT(b) = t;                    /* set up parallel pointer */
539             } else if (level == 0) goto done;   /* single run at level 0 */
540         } else {
541             /* Constructing a single run from two runs.
542              * The merge code at the top will do that.
543              * We need only make sure the two runs are in the "other" array,
544              * so they'll end up in the correct array after the merge.
545              */
546             ++level;
547             ++stackp;
548             stackp->offset = offset;
549             stackp->runs = 0;   /* take care of both runs, trigger merge */
550             if (!iwhich) {      /* Merged runs belong in aux, copy 1st */
551                 f1 = b = PINDEX(base, offset);  /* where first run starts */
552                 f2 = PINDEX(aux, offset);       /* where it will be copied */
553                 t = NEXT(f2);                   /* where first run will end */
554                 offset = PNELEM(aux, t);        /* offset thereof */
555                 p = PINDEX(base, offset);       /* end of first run */
556                 t = NEXT(t);                    /* where second run will end */
557                 t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
558                 FROMTOUPTO(f1, f2, t);          /* copy both runs */
559                 NEXT(b) = p;                    /* paralleled pointer for 1st */
560                 NEXT(p) = t;                    /* ... and for second */
561             }
562         }
563     }
564   done:
565     if (aux != small) Safefree(aux);    /* free iff allocated */
566     if (savecmp != NULL) {
567          PL_sort_RealCmp = savecmp;     /* Restore current comparison routine, if any */
568     }
569     return;
570 }
571
572 /*
573  * The quicksort implementation was derived from source code contributed
574  * by Tom Horsley.
575  *
576  * NOTE: this code was derived from Tom Horsley's qsort replacement
577  * and should not be confused with the original code.
578  */
579
580 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
581
582    Permission granted to distribute under the same terms as perl which are
583    (briefly):
584
585     This program is free software; you can redistribute it and/or modify
586     it under the terms of either:
587
588         a) the GNU General Public License as published by the Free
589         Software Foundation; either version 1, or (at your option) any
590         later version, or
591
592         b) the "Artistic License" which comes with this Kit.
593
594    Details on the perl license can be found in the perl source code which
595    may be located via the www.perl.com web page.
596
597    This is the most wonderfulest possible qsort I can come up with (and
598    still be mostly portable) My (limited) tests indicate it consistently
599    does about 20% fewer calls to compare than does the qsort in the Visual
600    C++ library, other vendors may vary.
601
602    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
603    others I invented myself (or more likely re-invented since they seemed
604    pretty obvious once I watched the algorithm operate for a while).
605
606    Most of this code was written while watching the Marlins sweep the Giants
607    in the 1997 National League Playoffs - no Braves fans allowed to use this
608    code (just kidding :-).
609
610    I realize that if I wanted to be true to the perl tradition, the only
611    comment in this file would be something like:
612
613    ...they shuffled back towards the rear of the line. 'No, not at the
614    rear!'  the slave-driver shouted. 'Three files up. And stay there...
615
616    However, I really needed to violate that tradition just so I could keep
617    track of what happens myself, not to mention some poor fool trying to
618    understand this years from now :-).
619 */
620
621 /* ********************************************************** Configuration */
622
623 #ifndef QSORT_ORDER_GUESS
624 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
625 #endif
626
627 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
628    future processing - a good max upper bound is log base 2 of memory size
629    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
630    safely be smaller than that since the program is taking up some space and
631    most operating systems only let you grab some subset of contiguous
632    memory (not to mention that you are normally sorting data larger than
633    1 byte element size :-).
634 */
635 #ifndef QSORT_MAX_STACK
636 #define QSORT_MAX_STACK 32
637 #endif
638
639 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
640    Anything bigger and we use qsort. If you make this too small, the qsort
641    will probably break (or become less efficient), because it doesn't expect
642    the middle element of a partition to be the same as the right or left -
643    you have been warned).
644 */
645 #ifndef QSORT_BREAK_EVEN
646 #define QSORT_BREAK_EVEN 6
647 #endif
648
649 /* QSORT_PLAY_SAFE is the size of the largest partition we're willing
650    to go quadratic on.  We innoculate larger partitions against
651    quadratic behavior by shuffling them before sorting.  This is not
652    an absolute guarantee of non-quadratic behavior, but it would take
653    staggeringly bad luck to pick extreme elements as the pivot
654    from randomized data.
655 */
656 #ifndef QSORT_PLAY_SAFE
657 #define QSORT_PLAY_SAFE 255
658 #endif
659
660 /* ************************************************************* Data Types */
661
662 /* hold left and right index values of a partition waiting to be sorted (the
663    partition includes both left and right - right is NOT one past the end or
664    anything like that).
665 */
666 struct partition_stack_entry {
667    int left;
668    int right;
669 #ifdef QSORT_ORDER_GUESS
670    int qsort_break_even;
671 #endif
672 };
673
674 /* ******************************************************* Shorthand Macros */
675
676 /* Note that these macros will be used from inside the qsort function where
677    we happen to know that the variable 'elt_size' contains the size of an
678    array element and the variable 'temp' points to enough space to hold a
679    temp element and the variable 'array' points to the array being sorted
680    and 'compare' is the pointer to the compare routine.
681
682    Also note that there are very many highly architecture specific ways
683    these might be sped up, but this is simply the most generally portable
684    code I could think of.
685 */
686
687 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
688 */
689 #define qsort_cmp(elt1, elt2) \
690    ((*compare)(aTHX_ array[elt1], array[elt2]))
691
692 #ifdef QSORT_ORDER_GUESS
693 #define QSORT_NOTICE_SWAP swapped++;
694 #else
695 #define QSORT_NOTICE_SWAP
696 #endif
697
698 /* swaps contents of array elements elt1, elt2.
699 */
700 #define qsort_swap(elt1, elt2) \
701    STMT_START { \
702       QSORT_NOTICE_SWAP \
703       temp = array[elt1]; \
704       array[elt1] = array[elt2]; \
705       array[elt2] = temp; \
706    } STMT_END
707
708 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
709    elt3 and elt3 gets elt1.
710 */
711 #define qsort_rotate(elt1, elt2, elt3) \
712    STMT_START { \
713       QSORT_NOTICE_SWAP \
714       temp = array[elt1]; \
715       array[elt1] = array[elt2]; \
716       array[elt2] = array[elt3]; \
717       array[elt3] = temp; \
718    } STMT_END
719
720 /* ************************************************************ Debug stuff */
721
722 #ifdef QSORT_DEBUG
723
724 static void
725 break_here()
726 {
727    return; /* good place to set a breakpoint */
728 }
729
730 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
731
732 static void
733 doqsort_all_asserts(
734    void * array,
735    size_t num_elts,
736    size_t elt_size,
737    int (*compare)(const void * elt1, const void * elt2),
738    int pc_left, int pc_right, int u_left, int u_right)
739 {
740    int i;
741
742    qsort_assert(pc_left <= pc_right);
743    qsort_assert(u_right < pc_left);
744    qsort_assert(pc_right < u_left);
745    for (i = u_right + 1; i < pc_left; ++i) {
746       qsort_assert(qsort_cmp(i, pc_left) < 0);
747    }
748    for (i = pc_left; i < pc_right; ++i) {
749       qsort_assert(qsort_cmp(i, pc_right) == 0);
750    }
751    for (i = pc_right + 1; i < u_left; ++i) {
752       qsort_assert(qsort_cmp(pc_right, i) < 0);
753    }
754 }
755
756 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
757    doqsort_all_asserts(array, num_elts, elt_size, compare, \
758                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
759
760 #else
761
762 #define qsort_assert(t) ((void)0)
763
764 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
765
766 #endif
767
768 /*
769 =head1 Array Manipulation Functions
770
771 =for apidoc sortsv
772
773 In-place sort an array of SV pointers with the given comparison routine.
774
775 Currently this always uses mergesort.  See C<L</sortsv_flags>> for a more
776 flexible routine.
777
778 =cut
779 */
780
781 void
782 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
783 {
784     PERL_ARGS_ASSERT_SORTSV;
785
786     sortsv_flags(array, nmemb, cmp, 0);
787 }
788
789 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
790 #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
791 #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
792
793 PP(pp_sort)
794 {
795     dSP; dMARK; dORIGMARK;
796     SV **p1 = ORIGMARK+1, **p2;
797     SSize_t max, i;
798     AV* av = NULL;
799     GV *gv;
800     CV *cv = NULL;
801     U8 gimme = GIMME_V;
802     OP* const nextop = PL_op->op_next;
803     I32 overloading = 0;
804     bool hasargs = FALSE;
805     bool copytmps;
806     I32 is_xsub = 0;
807     const U8 priv = PL_op->op_private;
808     const U8 flags = PL_op->op_flags;
809     U32 sort_flags = 0;
810     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
811       = Perl_sortsv_flags;
812     I32 all_SIVs = 1;
813
814     if ((priv & OPpSORT_DESCEND) != 0)
815         sort_flags |= SORTf_DESC;
816     if ((priv & OPpSORT_STABLE) != 0)
817         sort_flags |= SORTf_STABLE;
818     if ((priv & OPpSORT_UNSTABLE) != 0)
819         sort_flags |= SORTf_UNSTABLE;
820
821     if (gimme != G_ARRAY) {
822         SP = MARK;
823         EXTEND(SP,1);
824         RETPUSHUNDEF;
825     }
826
827     ENTER;
828     SAVEVPTR(PL_sortcop);
829     if (flags & OPf_STACKED) {
830         if (flags & OPf_SPECIAL) {
831             OP *nullop = OpSIBLING(cLISTOP->op_first);  /* pass pushmark */
832             assert(nullop->op_type == OP_NULL);
833             PL_sortcop = nullop->op_next;
834         }
835         else {
836             GV *autogv = NULL;
837             HV *stash;
838             cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
839           check_cv:
840             if (cv && SvPOK(cv)) {
841                 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
842                 if (proto && strEQ(proto, "$$")) {
843                     hasargs = TRUE;
844                 }
845             }
846             if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
847                 is_xsub = 1;
848             }
849             else if (!(cv && CvROOT(cv))) {
850                 if (gv) {
851                     goto autoload;
852                 }
853                 else if (!CvANON(cv) && (gv = CvGV(cv))) {
854                   if (cv != GvCV(gv)) cv = GvCV(gv);
855                  autoload:
856                   if (!autogv && (
857                         autogv = gv_autoload_pvn(
858                             GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
859                             GvNAMEUTF8(gv) ? SVf_UTF8 : 0
860                         )
861                      )) {
862                     cv = GvCVu(autogv);
863                     goto check_cv;
864                   }
865                   else {
866                     SV *tmpstr = sv_newmortal();
867                     gv_efullname3(tmpstr, gv, NULL);
868                     DIE(aTHX_ "Undefined sort subroutine \"%" SVf "\" called",
869                         SVfARG(tmpstr));
870                   }
871                 }
872                 else {
873                     DIE(aTHX_ "Undefined subroutine in sort");
874                 }
875             }
876
877             if (is_xsub)
878                 PL_sortcop = (OP*)cv;
879             else
880                 PL_sortcop = CvSTART(cv);
881         }
882     }
883     else {
884         PL_sortcop = NULL;
885     }
886
887     /* optimiser converts "@a = sort @a" to "sort \@a".  In this case,
888      * push (@a) onto stack, then assign result back to @a at the end of
889      * this function */
890     if (priv & OPpSORT_INPLACE) {
891         assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
892         (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
893         av = MUTABLE_AV((*SP));
894         if (SvREADONLY(av))
895             Perl_croak_no_modify();
896         max = AvFILL(av) + 1;
897         MEXTEND(SP, max);
898         if (SvMAGICAL(av)) {
899             for (i=0; i < max; i++) {
900                 SV **svp = av_fetch(av, i, FALSE);
901                 *SP++ = (svp) ? *svp : NULL;
902             }
903         }
904         else {
905             SV **svp = AvARRAY(av);
906             assert(svp || max == 0);
907             for (i = 0; i < max; i++)
908                 *SP++ = *svp++;
909         }
910         SP--;
911         p1 = p2 = SP - (max-1);
912     }
913     else {
914         p2 = MARK+1;
915         max = SP - MARK;
916    }
917
918     /* shuffle stack down, removing optional initial cv (p1!=p2), plus
919      * any nulls; also stringify or converting to integer or number as
920      * required any args */
921     copytmps = cBOOL(PL_sortcop);
922     for (i=max; i > 0 ; i--) {
923         if ((*p1 = *p2++)) {                    /* Weed out nulls. */
924             if (copytmps && SvPADTMP(*p1)) {
925                 *p1 = sv_mortalcopy(*p1);
926             }
927             SvTEMP_off(*p1);
928             if (!PL_sortcop) {
929                 if (priv & OPpSORT_NUMERIC) {
930                     if (priv & OPpSORT_INTEGER) {
931                         if (!SvIOK(*p1))
932                             (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
933                     }
934                     else {
935                         if (!SvNSIOK(*p1))
936                             (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
937                         if (all_SIVs && !SvSIOK(*p1))
938                             all_SIVs = 0;
939                     }
940                 }
941                 else {
942                     if (!SvPOK(*p1))
943                         (void)sv_2pv_flags(*p1, 0,
944                             SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
945                 }
946                 if (SvAMAGIC(*p1))
947                     overloading = 1;
948             }
949             p1++;
950         }
951         else
952             max--;
953     }
954     if (max > 1) {
955         SV **start;
956         if (PL_sortcop) {
957             PERL_CONTEXT *cx;
958             const bool oldcatch = CATCH_GET;
959             I32 old_savestack_ix = PL_savestack_ix;
960
961             SAVEOP();
962
963             CATCH_SET(TRUE);
964             PUSHSTACKi(PERLSI_SORT);
965             if (!hasargs && !is_xsub) {
966                 SAVEGENERICSV(PL_firstgv);
967                 SAVEGENERICSV(PL_secondgv);
968                 PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
969                     gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
970                 ));
971                 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
972                     gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
973                 ));
974                 /* make sure the GP isn't removed out from under us for
975                  * the SAVESPTR() */
976                 save_gp(PL_firstgv, 0);
977                 save_gp(PL_secondgv, 0);
978                 /* we don't want modifications localized */
979                 GvINTRO_off(PL_firstgv);
980                 GvINTRO_off(PL_secondgv);
981                 SAVEGENERICSV(GvSV(PL_firstgv));
982                 SvREFCNT_inc(GvSV(PL_firstgv));
983                 SAVEGENERICSV(GvSV(PL_secondgv));
984                 SvREFCNT_inc(GvSV(PL_secondgv));
985             }
986
987             gimme = G_SCALAR;
988             cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix);
989             if (!(flags & OPf_SPECIAL)) {
990                 cx->cx_type = CXt_SUB|CXp_MULTICALL;
991                 cx_pushsub(cx, cv, NULL, hasargs);
992                 if (!is_xsub) {
993                     PADLIST * const padlist = CvPADLIST(cv);
994
995                     if (++CvDEPTH(cv) >= 2)
996                         pad_push(padlist, CvDEPTH(cv));
997                     PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
998
999                     if (hasargs) {
1000                         /* This is mostly copied from pp_entersub */
1001                         AV * const av = MUTABLE_AV(PAD_SVl(0));
1002
1003                         cx->blk_sub.savearray = GvAV(PL_defgv);
1004                         GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1005                     }
1006
1007                 }
1008             }
1009
1010             start = p1 - max;
1011             sortsvp(aTHX_ start, max,
1012                     (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1013                     sort_flags);
1014
1015             /* Reset cx, in case the context stack has been reallocated. */
1016             cx = CX_CUR();
1017
1018             PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1019
1020             CX_LEAVE_SCOPE(cx);
1021             if (!(flags & OPf_SPECIAL)) {
1022                 assert(CxTYPE(cx) == CXt_SUB);
1023                 cx_popsub(cx);
1024             }
1025             else
1026                 assert(CxTYPE(cx) == CXt_NULL);
1027                 /* there isn't a POPNULL ! */
1028
1029             cx_popblock(cx);
1030             CX_POP(cx);
1031             POPSTACK;
1032             CATCH_SET(oldcatch);
1033         }
1034         else {
1035             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
1036             start = ORIGMARK+1;
1037             sortsvp(aTHX_ start, max,
1038                     (priv & OPpSORT_NUMERIC)
1039                         ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1040                             ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1041                             : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1042                         : (
1043 #ifdef USE_LOCALE_COLLATE
1044                            IN_LC_RUNTIME(LC_COLLATE)
1045                             ? ( overloading
1046                                 ? (SVCOMPARE_t)S_amagic_cmp_locale
1047                                 : (SVCOMPARE_t)sv_cmp_locale_static)
1048                             :
1049 #endif
1050                               ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1051                     sort_flags);
1052         }
1053         if ((priv & OPpSORT_REVERSE) != 0) {
1054             SV **q = start+max-1;
1055             while (start < q) {
1056                 SV * const tmp = *start;
1057                 *start++ = *q;
1058                 *q-- = tmp;
1059             }
1060         }
1061     }
1062
1063     if (av) {
1064         /* copy back result to the array */
1065         SV** const base = MARK+1;
1066         SSize_t max_minus_one = max - 1; /* attempt to work around mingw bug */
1067         if (SvMAGICAL(av)) {
1068             for (i = 0; i <= max_minus_one; i++)
1069                 base[i] = newSVsv(base[i]);
1070             av_clear(av);
1071             if (max_minus_one >= 0)
1072                 av_extend(av, max_minus_one);
1073             for (i=0; i <= max_minus_one; i++) {
1074                 SV * const sv = base[i];
1075                 SV ** const didstore = av_store(av, i, sv);
1076                 if (SvSMAGICAL(sv))
1077                     mg_set(sv);
1078                 if (!didstore)
1079                     sv_2mortal(sv);
1080             }
1081         }
1082         else {
1083             /* the elements of av are likely to be the same as the
1084              * (non-refcounted) elements on the stack, just in a different
1085              * order. However, its possible that someone's messed with av
1086              * in the meantime. So bump and unbump the relevant refcounts
1087              * first.
1088              */
1089             for (i = 0; i <= max_minus_one; i++) {
1090                 SV *sv = base[i];
1091                 assert(sv);
1092                 if (SvREFCNT(sv) > 1)
1093                     base[i] = newSVsv(sv);
1094                 else
1095                     SvREFCNT_inc_simple_void_NN(sv);
1096             }
1097             av_clear(av);
1098             if (max_minus_one >= 0) {
1099                 av_extend(av, max_minus_one);
1100                 Copy(base, AvARRAY(av), max, SV*);
1101             }
1102             AvFILLp(av) = max_minus_one;
1103             AvREIFY_off(av);
1104             AvREAL_on(av);
1105         }
1106     }
1107     LEAVE;
1108     PL_stack_sp = ORIGMARK +  max;
1109     return nextop;
1110 }
1111
1112 static I32
1113 S_sortcv(pTHX_ SV *const a, SV *const b)
1114 {
1115     const I32 oldsaveix = PL_savestack_ix;
1116     I32 result;
1117     PMOP * const pm = PL_curpm;
1118     COP * const cop = PL_curcop;
1119     SV *olda, *oldb;
1120  
1121     PERL_ARGS_ASSERT_SORTCV;
1122
1123     olda = GvSV(PL_firstgv);
1124     GvSV(PL_firstgv) = SvREFCNT_inc_simple_NN(a);
1125     SvREFCNT_dec(olda);
1126     oldb = GvSV(PL_secondgv);
1127     GvSV(PL_secondgv) = SvREFCNT_inc_simple_NN(b);
1128     SvREFCNT_dec(oldb);
1129     PL_stack_sp = PL_stack_base;
1130     PL_op = PL_sortcop;
1131     CALLRUNOPS(aTHX);
1132     PL_curcop = cop;
1133     /* entry zero of a stack is always PL_sv_undef, which
1134      * simplifies converting a '()' return into undef in scalar context */
1135     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1136     result = SvIV(*PL_stack_sp);
1137
1138     LEAVE_SCOPE(oldsaveix);
1139     PL_curpm = pm;
1140     return result;
1141 }
1142
1143 static I32
1144 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1145 {
1146     const I32 oldsaveix = PL_savestack_ix;
1147     I32 result;
1148     AV * const av = GvAV(PL_defgv);
1149     PMOP * const pm = PL_curpm;
1150     COP * const cop = PL_curcop;
1151
1152     PERL_ARGS_ASSERT_SORTCV_STACKED;
1153
1154     if (AvREAL(av)) {
1155         av_clear(av);
1156         AvREAL_off(av);
1157         AvREIFY_on(av);
1158     }
1159     if (AvMAX(av) < 1) {
1160         SV **ary = AvALLOC(av);
1161         if (AvARRAY(av) != ary) {
1162             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1163             AvARRAY(av) = ary;
1164         }
1165         if (AvMAX(av) < 1) {
1166             Renew(ary,2,SV*);
1167             AvMAX(av) = 1;
1168             AvARRAY(av) = ary;
1169             AvALLOC(av) = ary;
1170         }
1171     }
1172     AvFILLp(av) = 1;
1173
1174     AvARRAY(av)[0] = a;
1175     AvARRAY(av)[1] = b;
1176     PL_stack_sp = PL_stack_base;
1177     PL_op = PL_sortcop;
1178     CALLRUNOPS(aTHX);
1179     PL_curcop = cop;
1180     /* entry zero of a stack is always PL_sv_undef, which
1181      * simplifies converting a '()' return into undef in scalar context */
1182     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1183     result = SvIV(*PL_stack_sp);
1184
1185     LEAVE_SCOPE(oldsaveix);
1186     PL_curpm = pm;
1187     return result;
1188 }
1189
1190 static I32
1191 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1192 {
1193     dSP;
1194     const I32 oldsaveix = PL_savestack_ix;
1195     CV * const cv=MUTABLE_CV(PL_sortcop);
1196     I32 result;
1197     PMOP * const pm = PL_curpm;
1198
1199     PERL_ARGS_ASSERT_SORTCV_XSUB;
1200
1201     SP = PL_stack_base;
1202     PUSHMARK(SP);
1203     EXTEND(SP, 2);
1204     *++SP = a;
1205     *++SP = b;
1206     PUTBACK;
1207     (void)(*CvXSUB(cv))(aTHX_ cv);
1208     /* entry zero of a stack is always PL_sv_undef, which
1209      * simplifies converting a '()' return into undef in scalar context */
1210     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1211     result = SvIV(*PL_stack_sp);
1212
1213     LEAVE_SCOPE(oldsaveix);
1214     PL_curpm = pm;
1215     return result;
1216 }
1217
1218
1219 static I32
1220 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1221 {
1222     I32 cmp = do_ncmp(a, b);
1223
1224     PERL_ARGS_ASSERT_SV_NCMP;
1225
1226     if (cmp == 2) {
1227         if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1228         return 0;
1229     }
1230
1231     return cmp;
1232 }
1233
1234 static I32
1235 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1236 {
1237     const IV iv1 = SvIV(a);
1238     const IV iv2 = SvIV(b);
1239
1240     PERL_ARGS_ASSERT_SV_I_NCMP;
1241
1242     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1243 }
1244
1245 #define tryCALL_AMAGICbin(left,right,meth) \
1246     (SvAMAGIC(left)||SvAMAGIC(right)) \
1247         ? amagic_call(left, right, meth, 0) \
1248         : NULL;
1249
1250 #define SORT_NORMAL_RETURN_VALUE(val)  (((val) > 0) ? 1 : ((val) ? -1 : 0))
1251
1252 static I32
1253 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1254 {
1255     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1256
1257     PERL_ARGS_ASSERT_AMAGIC_NCMP;
1258
1259     if (tmpsv) {
1260         if (SvIOK(tmpsv)) {
1261             const I32 i = SvIVX(tmpsv);
1262             return SORT_NORMAL_RETURN_VALUE(i);
1263         }
1264         else {
1265             const NV d = SvNV(tmpsv);
1266             return SORT_NORMAL_RETURN_VALUE(d);
1267         }
1268      }
1269      return S_sv_ncmp(aTHX_ a, b);
1270 }
1271
1272 static I32
1273 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1274 {
1275     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1276
1277     PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1278
1279     if (tmpsv) {
1280         if (SvIOK(tmpsv)) {
1281             const I32 i = SvIVX(tmpsv);
1282             return SORT_NORMAL_RETURN_VALUE(i);
1283         }
1284         else {
1285             const NV d = SvNV(tmpsv);
1286             return SORT_NORMAL_RETURN_VALUE(d);
1287         }
1288     }
1289     return S_sv_i_ncmp(aTHX_ a, b);
1290 }
1291
1292 static I32
1293 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1294 {
1295     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1296
1297     PERL_ARGS_ASSERT_AMAGIC_CMP;
1298
1299     if (tmpsv) {
1300         if (SvIOK(tmpsv)) {
1301             const I32 i = SvIVX(tmpsv);
1302             return SORT_NORMAL_RETURN_VALUE(i);
1303         }
1304         else {
1305             const NV d = SvNV(tmpsv);
1306             return SORT_NORMAL_RETURN_VALUE(d);
1307         }
1308     }
1309     return sv_cmp(str1, str2);
1310 }
1311
1312 #ifdef USE_LOCALE_COLLATE
1313
1314 static I32
1315 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1316 {
1317     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1318
1319     PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1320
1321     if (tmpsv) {
1322         if (SvIOK(tmpsv)) {
1323             const I32 i = SvIVX(tmpsv);
1324             return SORT_NORMAL_RETURN_VALUE(i);
1325         }
1326         else {
1327             const NV d = SvNV(tmpsv);
1328             return SORT_NORMAL_RETURN_VALUE(d);
1329         }
1330     }
1331     return sv_cmp_locale(str1, str2);
1332 }
1333
1334 #endif
1335
1336 /*
1337  * ex: set ts=8 sts=4 sw=4 et:
1338  */