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