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