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