xref: /openbsd/gnu/usr.bin/perl/pp_sort.c (revision 17df1aa7)
1 /*    pp_sort.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10 
11 /*
12  *   ...they shuffled back towards the rear of the line.  'No, not at the
13  *   rear!' the slave-driver shouted.  'Three files up. And stay there...
14  *
15  *     [p.931 of _The Lord of the Rings_, VI/ii: "The Land of Shadow"]
16  */
17 
18 /* This file contains pp ("push/pop") functions that
19  * execute the opcodes that make up a perl program. A typical pp function
20  * expects to find its arguments on the stack, and usually pushes its
21  * results onto the stack, hence the 'pp' terminology. Each OP structure
22  * contains a pointer to the relevant pp_foo() function.
23  *
24  * This particular file just contains pp_sort(), which is complex
25  * enough to merit its own file! See the other pp*.c files for the rest of
26  * the pp_ functions.
27  */
28 
29 #include "EXTERN.h"
30 #define PERL_IN_PP_SORT_C
31 #include "perl.h"
32 
33 #if defined(UNDER_CE)
34 /* looks like 'small' is reserved word for WINCE (or somesuch)*/
35 #define	small xsmall
36 #endif
37 
38 #define sv_cmp_static Perl_sv_cmp
39 #define sv_cmp_locale_static Perl_sv_cmp_locale
40 
41 #ifndef SMALLSORT
42 #define	SMALLSORT (200)
43 #endif
44 
45 /* Flags for qsortsv and mergesortsv */
46 #define SORTf_DESC   1
47 #define SORTf_STABLE 2
48 #define SORTf_QSORT  4
49 
50 /*
51  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
52  *
53  * The original code was written in conjunction with BSD Computer Software
54  * Research Group at University of California, Berkeley.
55  *
56  * See also: "Optimistic Merge Sort" (SODA '92)
57  *
58  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
59  *
60  * The code can be distributed under the same terms as Perl itself.
61  *
62  */
63 
64 
65 typedef char * aptr;		/* pointer for arithmetic on sizes */
66 typedef SV * gptr;		/* pointers in our lists */
67 
68 /* Binary merge internal sort, with a few special mods
69 ** for the special perl environment it now finds itself in.
70 **
71 ** Things that were once options have been hotwired
72 ** to values suitable for this use.  In particular, we'll always
73 ** initialize looking for natural runs, we'll always produce stable
74 ** output, and we'll always do Peter McIlroy's binary merge.
75 */
76 
77 /* Pointer types for arithmetic and storage and convenience casts */
78 
79 #define	APTR(P)	((aptr)(P))
80 #define	GPTP(P)	((gptr *)(P))
81 #define GPPP(P) ((gptr **)(P))
82 
83 
84 /* byte offset from pointer P to (larger) pointer Q */
85 #define	BYTEOFF(P, Q) (APTR(Q) - APTR(P))
86 
87 #define PSIZE sizeof(gptr)
88 
89 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
90 
91 #ifdef	PSHIFT
92 #define	PNELEM(P, Q)	(BYTEOFF(P,Q) >> (PSHIFT))
93 #define	PNBYTE(N)	((N) << (PSHIFT))
94 #define	PINDEX(P, N)	(GPTP(APTR(P) + PNBYTE(N)))
95 #else
96 /* Leave optimization to compiler */
97 #define	PNELEM(P, Q)	(GPTP(Q) - GPTP(P))
98 #define	PNBYTE(N)	((N) * (PSIZE))
99 #define	PINDEX(P, N)	(GPTP(P) + (N))
100 #endif
101 
102 /* Pointer into other corresponding to pointer into this */
103 #define	POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
104 
105 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
106 
107 
108 /* Runs are identified by a pointer in the auxilliary list.
109 ** The pointer is at the start of the list,
110 ** and it points to the start of the next list.
111 ** NEXT is used as an lvalue, too.
112 */
113 
114 #define	NEXT(P)		(*GPPP(P))
115 
116 
117 /* PTHRESH is the minimum number of pairs with the same sense to justify
118 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
119 ** not just elements, so PTHRESH == 8 means a run of 16.
120 */
121 
122 #define	PTHRESH (8)
123 
124 /* RTHRESH is the number of elements in a run that must compare low
125 ** to the low element from the opposing run before we justify
126 ** doing a binary rampup instead of single stepping.
127 ** In random input, N in a row low should only happen with
128 ** probability 2^(1-N), so we can risk that we are dealing
129 ** with orderly input without paying much when we aren't.
130 */
131 
132 #define RTHRESH (6)
133 
134 
135 /*
136 ** Overview of algorithm and variables.
137 ** The array of elements at list1 will be organized into runs of length 2,
138 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
139 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
140 **
141 ** Unless otherwise specified, pair pointers address the first of two elements.
142 **
143 ** b and b+1 are a pair that compare with sense "sense".
144 ** b is the "bottom" of adjacent pairs that might form a longer run.
145 **
146 ** p2 parallels b in the list2 array, where runs are defined by
147 ** a pointer chain.
148 **
149 ** t represents the "top" of the adjacent pairs that might extend
150 ** the run beginning at b.  Usually, t addresses a pair
151 ** that compares with opposite sense from (b,b+1).
152 ** However, it may also address a singleton element at the end of list1,
153 ** or it may be equal to "last", the first element beyond list1.
154 **
155 ** r addresses the Nth pair following b.  If this would be beyond t,
156 ** we back it off to t.  Only when r is less than t do we consider the
157 ** run long enough to consider checking.
158 **
159 ** q addresses a pair such that the pairs at b through q already form a run.
160 ** Often, q will equal b, indicating we only are sure of the pair itself.
161 ** However, a search on the previous cycle may have revealed a longer run,
162 ** so q may be greater than b.
163 **
164 ** p is used to work back from a candidate r, trying to reach q,
165 ** which would mean b through r would be a run.  If we discover such a run,
166 ** we start q at r and try to push it further towards t.
167 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
168 ** In any event, after the check (if any), we have two main cases.
169 **
170 ** 1) Short run.  b <= q < p <= r <= t.
171 **	b through q is a run (perhaps trivial)
172 **	q through p are uninteresting pairs
173 **	p through r is a run
174 **
175 ** 2) Long run.  b < r <= q < t.
176 **	b through q is a run (of length >= 2 * PTHRESH)
177 **
178 ** Note that degenerate cases are not only possible, but likely.
179 ** For example, if the pair following b compares with opposite sense,
180 ** then b == q < p == r == t.
181 */
182 
183 
184 static IV
185 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
186 {
187     I32 sense;
188     register gptr *b, *p, *q, *t, *p2;
189     register gptr *last, *r;
190     IV runs = 0;
191 
192     b = list1;
193     last = PINDEX(b, nmemb);
194     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
195     for (p2 = list2; b < last; ) {
196 	/* We just started, or just reversed sense.
197 	** Set t at end of pairs with the prevailing sense.
198 	*/
199 	for (p = b+2, t = p; ++p < last; t = ++p) {
200 	    if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
201 	}
202 	q = b;
203 	/* Having laid out the playing field, look for long runs */
204 	do {
205 	    p = r = b + (2 * PTHRESH);
206 	    if (r >= t) p = r = t;	/* too short to care about */
207 	    else {
208 		while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
209 		       ((p -= 2) > q)) {}
210 		if (p <= q) {
211 		    /* b through r is a (long) run.
212 		    ** Extend it as far as possible.
213 		    */
214 		    p = q = r;
215 		    while (((p += 2) < t) &&
216 			   ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
217 		    r = p = q + 2;	/* no simple pairs, no after-run */
218 		}
219 	    }
220 	    if (q > b) {		/* run of greater than 2 at b */
221 		gptr *savep = p;
222 
223 		p = q += 2;
224 		/* pick up singleton, if possible */
225 		if ((p == t) &&
226 		    ((t + 1) == last) &&
227 		    ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
228 		    savep = r = p = q = last;
229 		p2 = NEXT(p2) = p2 + (p - b); ++runs;
230 		if (sense)
231 		    while (b < --p) {
232 			const gptr c = *b;
233 			*b++ = *p;
234 			*p = c;
235 		    }
236 		p = savep;
237 	    }
238 	    while (q < p) {		/* simple pairs */
239 		p2 = NEXT(p2) = p2 + 2; ++runs;
240 		if (sense) {
241 		    const gptr c = *q++;
242 		    *(q-1) = *q;
243 		    *q++ = c;
244 		} else q += 2;
245 	    }
246 	    if (((b = p) == t) && ((t+1) == last)) {
247 		NEXT(p2) = p2 + 1; ++runs;
248 		b++;
249 	    }
250 	    q = r;
251 	} while (b < t);
252 	sense = !sense;
253     }
254     return runs;
255 }
256 
257 
258 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
259  * qsort on many platforms, but slower than qsort, conspicuously so,
260  * on others.  The most likely explanation was platform-specific
261  * differences in cache sizes and relative speeds.
262  *
263  * The quicksort divide-and-conquer algorithm guarantees that, as the
264  * problem is subdivided into smaller and smaller parts, the parts
265  * fit into smaller (and faster) caches.  So it doesn't matter how
266  * many levels of cache exist, quicksort will "find" them, and,
267  * as long as smaller is faster, take advantage of them.
268  *
269  * By contrast, consider how the original mergesort algorithm worked.
270  * Suppose we have five runs (each typically of length 2 after dynprep).
271  *
272  * pass               base                        aux
273  *  0              1 2 3 4 5
274  *  1                                           12 34 5
275  *  2                1234 5
276  *  3                                            12345
277  *  4                 12345
278  *
279  * Adjacent pairs are merged in "grand sweeps" through the input.
280  * This means, on pass 1, the records in runs 1 and 2 aren't revisited until
281  * runs 3 and 4 are merged and the runs from run 5 have been copied.
282  * The only cache that matters is one large enough to hold *all* the input.
283  * On some platforms, this may be many times slower than smaller caches.
284  *
285  * The following pseudo-code uses the same basic merge algorithm,
286  * but in a divide-and-conquer way.
287  *
288  * # merge $runs runs at offset $offset of list $list1 into $list2.
289  * # all unmerged runs ($runs == 1) originate in list $base.
290  * sub mgsort2 {
291  *     my ($offset, $runs, $base, $list1, $list2) = @_;
292  *
293  *     if ($runs == 1) {
294  *         if ($list1 is $base) copy run to $list2
295  *         return offset of end of list (or copy)
296  *     } else {
297  *         $off2 = mgsort2($offset, $runs-($runs/2), $base, $list2, $list1)
298  *         mgsort2($off2, $runs/2, $base, $list2, $list1)
299  *         merge the adjacent runs at $offset of $list1 into $list2
300  *         return the offset of the end of the merged runs
301  *     }
302  * }
303  * mgsort2(0, $runs, $base, $aux, $base);
304  *
305  * For our 5 runs, the tree of calls looks like
306  *
307  *           5
308  *      3        2
309  *   2     1   1   1
310  * 1   1
311  *
312  * 1   2   3   4   5
313  *
314  * and the corresponding activity looks like
315  *
316  * copy runs 1 and 2 from base to aux
317  * merge runs 1 and 2 from aux to base
318  * (run 3 is where it belongs, no copy needed)
319  * merge runs 12 and 3 from base to aux
320  * (runs 4 and 5 are where they belong, no copy needed)
321  * merge runs 4 and 5 from base to aux
322  * merge runs 123 and 45 from aux to base
323  *
324  * Note that we merge runs 1 and 2 immediately after copying them,
325  * while they are still likely to be in fast cache.  Similarly,
326  * run 3 is merged with run 12 while it still may be lingering in cache.
327  * This implementation should therefore enjoy much of the cache-friendly
328  * behavior that quicksort does.  In addition, it does less copying
329  * than the original mergesort implementation (only runs 1 and 2 are copied)
330  * and the "balancing" of merges is better (merged runs comprise more nearly
331  * equal numbers of original runs).
332  *
333  * The actual cache-friendly implementation will use a pseudo-stack
334  * to avoid recursion, and will unroll processing of runs of length 2,
335  * but it is otherwise similar to the recursive implementation.
336  */
337 
338 typedef struct {
339     IV	offset;		/* offset of 1st of 2 runs at this level */
340     IV	runs;		/* how many runs must be combined into 1 */
341 } off_runs;		/* pseudo-stack element */
342 
343 
344 static I32
345 cmp_desc(pTHX_ gptr a, gptr b)
346 {
347     dVAR;
348     return -PL_sort_RealCmp(aTHX_ a, b);
349 }
350 
351 STATIC void
352 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
353 {
354     dVAR;
355     IV i, run, offset;
356     I32 sense, level;
357     register gptr *f1, *f2, *t, *b, *p;
358     int iwhich;
359     gptr *aux;
360     gptr *p1;
361     gptr small[SMALLSORT];
362     gptr *which[3];
363     off_runs stack[60], *stackp;
364     SVCOMPARE_t savecmp = NULL;
365 
366     if (nmemb <= 1) return;			/* sorted trivially */
367 
368     if ((flags & SORTf_DESC) != 0) {
369 	savecmp = PL_sort_RealCmp;	/* Save current comparison routine, if any */
370 	PL_sort_RealCmp = cmp;	/* Put comparison routine where cmp_desc can find it */
371 	cmp = cmp_desc;
372     }
373 
374     if (nmemb <= SMALLSORT) aux = small;	/* use stack for aux array */
375     else { Newx(aux,nmemb,gptr); }		/* allocate auxilliary array */
376     level = 0;
377     stackp = stack;
378     stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
379     stackp->offset = offset = 0;
380     which[0] = which[2] = base;
381     which[1] = aux;
382     for (;;) {
383 	/* On levels where both runs have be constructed (stackp->runs == 0),
384 	 * merge them, and note the offset of their end, in case the offset
385 	 * is needed at the next level up.  Hop up a level, and,
386 	 * as long as stackp->runs is 0, keep merging.
387 	 */
388 	IV runs = stackp->runs;
389 	if (runs == 0) {
390 	    gptr *list1, *list2;
391 	    iwhich = level & 1;
392 	    list1 = which[iwhich];		/* area where runs are now */
393 	    list2 = which[++iwhich];		/* area for merged runs */
394 	    do {
395 		register gptr *l1, *l2, *tp2;
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 		    register gptr *q;
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    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
768    int next_stack_entry = 0;
769    int part_left;
770    int part_right;
771 #ifdef QSORT_ORDER_GUESS
772    int qsort_break_even;
773    int swapped;
774 #endif
775 
776     PERL_ARGS_ASSERT_QSORTSVU;
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     dVAR;
1323     gptr * const ap = (gptr *)a;
1324     gptr * const bp = (gptr *)b;
1325     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1326 
1327     if (sense)
1328 	return sense;
1329     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1330 }
1331 
1332 static I32
1333 cmpindir_desc(pTHX_ gptr a, gptr b)
1334 {
1335     dVAR;
1336     gptr * const ap = (gptr *)a;
1337     gptr * const bp = (gptr *)b;
1338     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1339 
1340     /* Reverse the default */
1341     if (sense)
1342 	return -sense;
1343     /* But don't reverse the stability test.  */
1344     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1345 
1346 }
1347 
1348 STATIC void
1349 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1350 {
1351     dVAR;
1352     if ((flags & SORTf_STABLE) != 0) {
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 	 if (flags & SORTf_DESC)
1371 	    qsortsvu((gptr *)indir, nmemb, cmpindir_desc);
1372 	else
1373 	    qsortsvu((gptr *)indir, nmemb, cmpindir);
1374 
1375 	 pp = indir;
1376 	 q = list1;
1377 	 for (n = nmemb; n--; ) {
1378 	      /* Assert A: all elements of q with index > n are already
1379 	       * in place.  This is vacuosly true at the start, and we
1380 	       * put element n where it belongs below (if it wasn't
1381 	       * already where it belonged). Assert B: we only move
1382 	       * elements that aren't where they belong,
1383 	       * so, by A, we never tamper with elements above n.
1384 	       */
1385 	      j = pp[n] - q;		/* This sets j so that q[j] is
1386 					 * at pp[n].  *pp[j] belongs in
1387 					 * q[j], by construction.
1388 					 */
1389 	      if (n != j) {		/* all's well if n == j */
1390 		   tmp = q[j];		/* save what's in q[j] */
1391 		   do {
1392 			q[j] = *pp[j];	/* put *pp[j] where it belongs */
1393 			i = pp[j] - q;	/* the index in q of the element
1394 					 * just moved */
1395 			pp[j] = q + j;	/* this is ok now */
1396 		   } while ((j = i) != n);
1397 		   /* There are only finitely many (nmemb) addresses
1398 		    * in the pp array.
1399 		    * So we must eventually revisit an index we saw before.
1400 		    * Suppose the first revisited index is k != n.
1401 		    * An index is visited because something else belongs there.
1402 		    * If we visit k twice, then two different elements must
1403 		    * belong in the same place, which cannot be.
1404 		    * So j must get back to n, the loop terminates,
1405 		    * and we put the saved element where it belongs.
1406 		    */
1407 		   q[n] = tmp;		/* put what belongs into
1408 					 * the n-th element */
1409 	      }
1410 	 }
1411 
1412 	/* free iff allocated */
1413 	 if (indir != small) { Safefree(indir); }
1414 	 /* restore prevailing comparison routine */
1415 	 PL_sort_RealCmp = savecmp;
1416     } else if ((flags & SORTf_DESC) != 0) {
1417 	 const SVCOMPARE_t savecmp = PL_sort_RealCmp;	/* Save current comparison routine, if any */
1418 	 PL_sort_RealCmp = cmp;	/* Put comparison routine where cmp_desc can find it */
1419 	 cmp = cmp_desc;
1420 	 qsortsvu(list1, nmemb, cmp);
1421 	 /* restore prevailing comparison routine */
1422 	 PL_sort_RealCmp = savecmp;
1423     } else {
1424 	 qsortsvu(list1, nmemb, cmp);
1425     }
1426 }
1427 
1428 /*
1429 =head1 Array Manipulation Functions
1430 
1431 =for apidoc sortsv
1432 
1433 Sort an array. Here is an example:
1434 
1435     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
1436 
1437 Currently this always uses mergesort. See sortsv_flags for a more
1438 flexible routine.
1439 
1440 =cut
1441 */
1442 
1443 void
1444 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1445 {
1446     PERL_ARGS_ASSERT_SORTSV;
1447 
1448     sortsv_flags(array, nmemb, cmp, 0);
1449 }
1450 
1451 /*
1452 =for apidoc sortsv_flags
1453 
1454 Sort an array, with various options.
1455 
1456 =cut
1457 */
1458 void
1459 Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1460 {
1461     PERL_ARGS_ASSERT_SORTSV_FLAGS;
1462 
1463     if (flags & SORTf_QSORT)
1464 	S_qsortsv(aTHX_ array, nmemb, cmp, flags);
1465     else
1466 	S_mergesortsv(aTHX_ array, nmemb, cmp, flags);
1467 }
1468 
1469 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
1470 #define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
1471 #define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
1472 
1473 PP(pp_sort)
1474 {
1475     dVAR; dSP; dMARK; dORIGMARK;
1476     register SV **p1 = ORIGMARK+1, **p2;
1477     register I32 max, i;
1478     AV* av = NULL;
1479     HV *stash;
1480     GV *gv;
1481     CV *cv = NULL;
1482     I32 gimme = GIMME;
1483     OP* const nextop = PL_op->op_next;
1484     I32 overloading = 0;
1485     bool hasargs = FALSE;
1486     I32 is_xsub = 0;
1487     I32 sorting_av = 0;
1488     const U8 priv = PL_op->op_private;
1489     const U8 flags = PL_op->op_flags;
1490     U32 sort_flags = 0;
1491     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1492       = Perl_sortsv_flags;
1493     I32 all_SIVs = 1;
1494 
1495     if ((priv & OPpSORT_DESCEND) != 0)
1496 	sort_flags |= SORTf_DESC;
1497     if ((priv & OPpSORT_QSORT) != 0)
1498 	sort_flags |= SORTf_QSORT;
1499     if ((priv & OPpSORT_STABLE) != 0)
1500 	sort_flags |= SORTf_STABLE;
1501 
1502     if (gimme != G_ARRAY) {
1503 	SP = MARK;
1504 	EXTEND(SP,1);
1505 	RETPUSHUNDEF;
1506     }
1507 
1508     ENTER;
1509     SAVEVPTR(PL_sortcop);
1510     if (flags & OPf_STACKED) {
1511 	if (flags & OPf_SPECIAL) {
1512 	    OP *kid = cLISTOP->op_first->op_sibling;	/* pass pushmark */
1513 	    kid = kUNOP->op_first;			/* pass rv2gv */
1514 	    kid = kUNOP->op_first;			/* pass leave */
1515 	    PL_sortcop = kid->op_next;
1516 	    stash = CopSTASH(PL_curcop);
1517 	}
1518 	else {
1519 	    cv = sv_2cv(*++MARK, &stash, &gv, 0);
1520 	    if (cv && SvPOK(cv)) {
1521 		const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
1522 		if (proto && strEQ(proto, "$$")) {
1523 		    hasargs = TRUE;
1524 		}
1525 	    }
1526 	    if (!(cv && CvROOT(cv))) {
1527 		if (cv && CvISXSUB(cv)) {
1528 		    is_xsub = 1;
1529 		}
1530 		else if (gv) {
1531 		    SV *tmpstr = sv_newmortal();
1532 		    gv_efullname3(tmpstr, gv, NULL);
1533 		    DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
1534 			SVfARG(tmpstr));
1535 		}
1536 		else {
1537 		    DIE(aTHX_ "Undefined subroutine in sort");
1538 		}
1539 	    }
1540 
1541 	    if (is_xsub)
1542 		PL_sortcop = (OP*)cv;
1543 	    else
1544 		PL_sortcop = CvSTART(cv);
1545 	}
1546     }
1547     else {
1548 	PL_sortcop = NULL;
1549 	stash = CopSTASH(PL_curcop);
1550     }
1551 
1552     /* optimiser converts "@a = sort @a" to "sort \@a";
1553      * in case of tied @a, pessimise: push (@a) onto stack, then assign
1554      * result back to @a at the end of this function */
1555     if (priv & OPpSORT_INPLACE) {
1556 	assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
1557 	(void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
1558 	av = MUTABLE_AV((*SP));
1559 	max = AvFILL(av) + 1;
1560 	if (SvMAGICAL(av)) {
1561 	    MEXTEND(SP, max);
1562 	    for (i=0; i < max; i++) {
1563 		SV **svp = av_fetch(av, i, FALSE);
1564 		*SP++ = (svp) ? *svp : NULL;
1565 	    }
1566 	    SP--;
1567 	    p1 = p2 = SP - (max-1);
1568 	}
1569 	else {
1570 	    if (SvREADONLY(av))
1571 		Perl_croak(aTHX_ "%s", PL_no_modify);
1572 	    else
1573 		SvREADONLY_on(av);
1574 	    p1 = p2 = AvARRAY(av);
1575 	    sorting_av = 1;
1576 	}
1577     }
1578     else {
1579 	p2 = MARK+1;
1580 	max = SP - MARK;
1581    }
1582 
1583     /* shuffle stack down, removing optional initial cv (p1!=p2), plus
1584      * any nulls; also stringify or converting to integer or number as
1585      * required any args */
1586     for (i=max; i > 0 ; i--) {
1587 	if ((*p1 = *p2++)) {			/* Weed out nulls. */
1588 	    SvTEMP_off(*p1);
1589 	    if (!PL_sortcop) {
1590 		if (priv & OPpSORT_NUMERIC) {
1591 		    if (priv & OPpSORT_INTEGER) {
1592 			if (!SvIOK(*p1)) {
1593 			    if (SvAMAGIC(*p1))
1594 				overloading = 1;
1595 			    else
1596 				(void)sv_2iv(*p1);
1597 			}
1598 		    }
1599 		    else {
1600 			if (!SvNSIOK(*p1)) {
1601 			    if (SvAMAGIC(*p1))
1602 				overloading = 1;
1603 			    else
1604 				(void)sv_2nv(*p1);
1605 			}
1606 			if (all_SIVs && !SvSIOK(*p1))
1607 			    all_SIVs = 0;
1608 		    }
1609 		}
1610 		else {
1611 		    if (!SvPOK(*p1)) {
1612 			if (SvAMAGIC(*p1))
1613 			    overloading = 1;
1614 			else
1615 			    (void)sv_2pv_flags(*p1, 0,
1616 					       SV_GMAGIC|SV_CONST_RETURN);
1617 		    }
1618 		}
1619 	    }
1620 	    p1++;
1621 	}
1622 	else
1623 	    max--;
1624     }
1625     if (sorting_av)
1626 	AvFILLp(av) = max-1;
1627 
1628     if (max > 1) {
1629 	SV **start;
1630 	if (PL_sortcop) {
1631 	    PERL_CONTEXT *cx;
1632 	    SV** newsp;
1633 	    const bool oldcatch = CATCH_GET;
1634 
1635 	    SAVETMPS;
1636 	    SAVEOP();
1637 
1638 	    CATCH_SET(TRUE);
1639 	    PUSHSTACKi(PERLSI_SORT);
1640 	    if (!hasargs && !is_xsub) {
1641 		SAVESPTR(PL_firstgv);
1642 		SAVESPTR(PL_secondgv);
1643 		SAVESPTR(PL_sortstash);
1644 		PL_firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV);
1645 		PL_secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV);
1646 		PL_sortstash = stash;
1647 		SAVESPTR(GvSV(PL_firstgv));
1648 		SAVESPTR(GvSV(PL_secondgv));
1649 	    }
1650 
1651 	    PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1652 	    if (!(flags & OPf_SPECIAL)) {
1653 		cx->cx_type = CXt_SUB;
1654 		cx->blk_gimme = G_SCALAR;
1655 		PUSHSUB(cx);
1656 		if (!is_xsub) {
1657 		    AV* const padlist = CvPADLIST(cv);
1658 
1659 		    if (++CvDEPTH(cv) >= 2) {
1660 			PERL_STACK_OVERFLOW_CHECK();
1661 			pad_push(padlist, CvDEPTH(cv));
1662 		    }
1663 		    SAVECOMPPAD();
1664 		    PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1665 
1666 		    if (hasargs) {
1667 			/* This is mostly copied from pp_entersub */
1668 			AV * const av = MUTABLE_AV(PAD_SVl(0));
1669 
1670 			cx->blk_sub.savearray = GvAV(PL_defgv);
1671 			GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1672 			CX_CURPAD_SAVE(cx->blk_sub);
1673 			cx->blk_sub.argarray = av;
1674 		    }
1675 
1676 		}
1677 	    }
1678 	    cx->cx_type |= CXp_MULTICALL;
1679 
1680 	    start = p1 - max;
1681 	    sortsvp(aTHX_ start, max,
1682 		    (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1683 		    sort_flags);
1684 
1685 	    if (!(flags & OPf_SPECIAL)) {
1686 		LEAVESUB(cv);
1687 		if (!is_xsub)
1688 		    CvDEPTH(cv)--;
1689 	    }
1690 	    POPBLOCK(cx,PL_curpm);
1691 	    PL_stack_sp = newsp;
1692 	    POPSTACK;
1693 	    CATCH_SET(oldcatch);
1694 	}
1695 	else {
1696 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
1697 	    start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
1698 	    sortsvp(aTHX_ start, max,
1699 		    (priv & OPpSORT_NUMERIC)
1700 		        ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1701 			    ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1702 			    : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1703 			: ( IN_LOCALE_RUNTIME
1704 			    ? ( overloading
1705 				? (SVCOMPARE_t)S_amagic_cmp_locale
1706 				: (SVCOMPARE_t)sv_cmp_locale_static)
1707 			    : ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1708 		    sort_flags);
1709 	}
1710 	if ((priv & OPpSORT_REVERSE) != 0) {
1711 	    SV **q = start+max-1;
1712 	    while (start < q) {
1713 		SV * const tmp = *start;
1714 		*start++ = *q;
1715 		*q-- = tmp;
1716 	    }
1717 	}
1718     }
1719     if (sorting_av)
1720 	SvREADONLY_off(av);
1721     else if (av && !sorting_av) {
1722 	/* simulate pp_aassign of tied AV */
1723 	SV** const base = MARK+1;
1724 	for (i=0; i < max; i++) {
1725 	    base[i] = newSVsv(base[i]);
1726 	}
1727 	av_clear(av);
1728 	av_extend(av, max);
1729 	for (i=0; i < max; i++) {
1730 	    SV * const sv = base[i];
1731 	    SV ** const didstore = av_store(av, i, sv);
1732 	    if (SvSMAGICAL(sv))
1733 		mg_set(sv);
1734 	    if (!didstore)
1735 		sv_2mortal(sv);
1736 	}
1737     }
1738     LEAVE;
1739     PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
1740     return nextop;
1741 }
1742 
1743 static I32
1744 S_sortcv(pTHX_ SV *a, SV *b)
1745 {
1746     dVAR;
1747     const I32 oldsaveix = PL_savestack_ix;
1748     const I32 oldscopeix = PL_scopestack_ix;
1749     I32 result;
1750 
1751     PERL_ARGS_ASSERT_SORTCV;
1752 
1753     GvSV(PL_firstgv) = a;
1754     GvSV(PL_secondgv) = b;
1755     PL_stack_sp = PL_stack_base;
1756     PL_op = PL_sortcop;
1757     CALLRUNOPS(aTHX);
1758     if (PL_stack_sp != PL_stack_base + 1)
1759 	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1760     if (!SvNIOKp(*PL_stack_sp))
1761 	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1762     result = SvIV(*PL_stack_sp);
1763     while (PL_scopestack_ix > oldscopeix) {
1764 	LEAVE;
1765     }
1766     leave_scope(oldsaveix);
1767     return result;
1768 }
1769 
1770 static I32
1771 S_sortcv_stacked(pTHX_ SV *a, SV *b)
1772 {
1773     dVAR;
1774     const I32 oldsaveix = PL_savestack_ix;
1775     const I32 oldscopeix = PL_scopestack_ix;
1776     I32 result;
1777     AV * const av = GvAV(PL_defgv);
1778 
1779     PERL_ARGS_ASSERT_SORTCV_STACKED;
1780 
1781     if (AvMAX(av) < 1) {
1782 	SV** ary = AvALLOC(av);
1783 	if (AvARRAY(av) != ary) {
1784 	    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1785 	    AvARRAY(av) = ary;
1786 	}
1787 	if (AvMAX(av) < 1) {
1788 	    AvMAX(av) = 1;
1789 	    Renew(ary,2,SV*);
1790 	    AvARRAY(av) = ary;
1791 	}
1792     }
1793     AvFILLp(av) = 1;
1794 
1795     AvARRAY(av)[0] = a;
1796     AvARRAY(av)[1] = b;
1797     PL_stack_sp = PL_stack_base;
1798     PL_op = PL_sortcop;
1799     CALLRUNOPS(aTHX);
1800     if (PL_stack_sp != PL_stack_base + 1)
1801 	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1802     if (!SvNIOKp(*PL_stack_sp))
1803 	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1804     result = SvIV(*PL_stack_sp);
1805     while (PL_scopestack_ix > oldscopeix) {
1806 	LEAVE;
1807     }
1808     leave_scope(oldsaveix);
1809     return result;
1810 }
1811 
1812 static I32
1813 S_sortcv_xsub(pTHX_ SV *a, SV *b)
1814 {
1815     dVAR; dSP;
1816     const I32 oldsaveix = PL_savestack_ix;
1817     const I32 oldscopeix = PL_scopestack_ix;
1818     CV * const cv=MUTABLE_CV(PL_sortcop);
1819     I32 result;
1820 
1821     PERL_ARGS_ASSERT_SORTCV_XSUB;
1822 
1823     SP = PL_stack_base;
1824     PUSHMARK(SP);
1825     EXTEND(SP, 2);
1826     *++SP = a;
1827     *++SP = b;
1828     PUTBACK;
1829     (void)(*CvXSUB(cv))(aTHX_ cv);
1830     if (PL_stack_sp != PL_stack_base + 1)
1831 	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1832     if (!SvNIOKp(*PL_stack_sp))
1833 	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1834     result = SvIV(*PL_stack_sp);
1835     while (PL_scopestack_ix > oldscopeix) {
1836 	LEAVE;
1837     }
1838     leave_scope(oldsaveix);
1839     return result;
1840 }
1841 
1842 
1843 static I32
1844 S_sv_ncmp(pTHX_ SV *a, SV *b)
1845 {
1846     const NV nv1 = SvNSIV(a);
1847     const NV nv2 = SvNSIV(b);
1848 
1849     PERL_ARGS_ASSERT_SV_NCMP;
1850 
1851     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
1852 }
1853 
1854 static I32
1855 S_sv_i_ncmp(pTHX_ SV *a, SV *b)
1856 {
1857     const IV iv1 = SvIV(a);
1858     const IV iv2 = SvIV(b);
1859 
1860     PERL_ARGS_ASSERT_SV_I_NCMP;
1861 
1862     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1863 }
1864 
1865 #define tryCALL_AMAGICbin(left,right,meth) \
1866     (PL_amagic_generation && (SvAMAGIC(left)||SvAMAGIC(right))) \
1867 	? amagic_call(left, right, CAT2(meth,_amg), 0) \
1868 	: NULL;
1869 
1870 #define SORT_NORMAL_RETURN_VALUE(val)  (((val) > 0) ? 1 : ((val) ? -1 : 0))
1871 
1872 static I32
1873 S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
1874 {
1875     dVAR;
1876     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
1877 
1878     PERL_ARGS_ASSERT_AMAGIC_NCMP;
1879 
1880     if (tmpsv) {
1881         if (SvIOK(tmpsv)) {
1882             const I32 i = SvIVX(tmpsv);
1883             return SORT_NORMAL_RETURN_VALUE(i);
1884         }
1885 	else {
1886 	    const NV d = SvNV(tmpsv);
1887 	    return SORT_NORMAL_RETURN_VALUE(d);
1888 	}
1889      }
1890      return S_sv_ncmp(aTHX_ a, b);
1891 }
1892 
1893 static I32
1894 S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
1895 {
1896     dVAR;
1897     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
1898 
1899     PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1900 
1901     if (tmpsv) {
1902         if (SvIOK(tmpsv)) {
1903             const I32 i = SvIVX(tmpsv);
1904             return SORT_NORMAL_RETURN_VALUE(i);
1905         }
1906 	else {
1907 	    const NV d = SvNV(tmpsv);
1908 	    return SORT_NORMAL_RETURN_VALUE(d);
1909 	}
1910     }
1911     return S_sv_i_ncmp(aTHX_ a, b);
1912 }
1913 
1914 static I32
1915 S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
1916 {
1917     dVAR;
1918     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
1919 
1920     PERL_ARGS_ASSERT_AMAGIC_CMP;
1921 
1922     if (tmpsv) {
1923         if (SvIOK(tmpsv)) {
1924             const I32 i = SvIVX(tmpsv);
1925             return SORT_NORMAL_RETURN_VALUE(i);
1926         }
1927 	else {
1928 	    const NV d = SvNV(tmpsv);
1929 	    return SORT_NORMAL_RETURN_VALUE(d);
1930 	}
1931     }
1932     return sv_cmp(str1, str2);
1933 }
1934 
1935 static I32
1936 S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
1937 {
1938     dVAR;
1939     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
1940 
1941     PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1942 
1943     if (tmpsv) {
1944         if (SvIOK(tmpsv)) {
1945             const I32 i = SvIVX(tmpsv);
1946             return SORT_NORMAL_RETURN_VALUE(i);
1947         }
1948 	else {
1949 	    const NV d = SvNV(tmpsv);
1950 	    return SORT_NORMAL_RETURN_VALUE(d);
1951 	}
1952     }
1953     return sv_cmp_locale(str1, str2);
1954 }
1955 
1956 /*
1957  * Local variables:
1958  * c-indentation-style: bsd
1959  * c-basic-offset: 4
1960  * indent-tabs-mode: t
1961  * End:
1962  *
1963  * ex: set ts=8 sts=4 sw=4 noet:
1964  */
1965