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