pp_sort.c

   1 /*    pp_sort.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   ...they shuffled back towards the rear of the line.  'No, not at the
  13  *   rear!' the slave-driver shouted.  'Three files up. And stay there...
  14  *
  15  *     [p.931 of _The Lord of the Rings_, VI/ii: "The Land of Shadow"]
  16  */
  17
  18 /* This file contains pp ("push/pop") functions that
  19  * execute the opcodes that make up a perl program. A typical pp function
  20  * expects to find its arguments on the stack, and usually pushes its
  21  * results onto the stack, hence the 'pp' terminology. Each OP structure
  22  * contains a pointer to the relevant pp_foo() function.
  23  *
  24  * This particular file just contains pp_sort(), which is complex
  25  * enough to merit its own file! See the other pp*.c files for the rest of
  26  * the pp_ functions.
  27  */
  28
  29 #include "EXTERN.h"
  30 #define PERL_IN_PP_SORT_C
  31 #include "perl.h"
  32
  33 #if defined(UNDER_CE)
  34 /* looks like 'small' is reserved word for WINCE (or somesuch)*/
  35 #define small xsmall
  36 #endif
  37
  38 #define sv_cmp_static Perl_sv_cmp
  39 #define sv_cmp_locale_static Perl_sv_cmp_locale
  40
  41 #ifndef SMALLSORT
  42 #define SMALLSORT (200)
  43 #endif
  44
  45 /* Flags for qsortsv and mergesortsv */
  46 #define SORTf_DESC   1
  47 #define SORTf_STABLE 2
  48 #define SORTf_QSORT  4
  49
  50 /*
  51  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
  52  *
  53  * The original code was written in conjunction with BSD Computer Software
  54  * Research Group at University of California, Berkeley.
  55  *
  56  * See also: "Optimistic 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.
  60  *
  61  * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
  62  *
  63  * The code can be distributed under the same terms as Perl itself.
  64  *
  65  */
  66
  67
  68 typedef char * aptr;            /* pointer for arithmetic on sizes */
  69 typedef 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
 111 /* Runs are identified by a pointer in the auxiliary list.
 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 **
 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.
 148 **
 149 ** p2 parallels b in the list2 array, where runs are defined by
 150 ** a pointer chain.
 151 **
 152 ** t represents the "top" of the adjacent pairs that might extend
 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,
 156 ** or it may be equal to "last", the first element beyond list1.
 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
 187 static IV
 188 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
 189 {
 190     I32 sense;
 191     gptr *b, *p, *q, *t, *p2;
 192     gptr *last, *r;
 193     IV runs = 0;
 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) &&
 212                        ((p -= 2) > q)) {}
 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 */
 224                 gptr *savep = p;
 225
 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;
 232                 p2 = NEXT(p2) = p2 + (p - b); ++runs;
 233                 if (sense)
 234                     while (b < --p) {
 235                         const gptr c = *b;
 236                         *b++ = *p;
 237                         *p = c;
 238                     }
 239                 p = savep;
 240             }
 241             while (q < p) {             /* simple pairs */
 242                 p2 = NEXT(p2) = p2 + 2; ++runs;
 243                 if (sense) {
 244                     const gptr c = *q++;
 245                     *(q-1) = *q;
 246                     *q++ = c;
 247                 } else q += 2;
 248             }
 249             if (((b = p) == t) && ((t+1) == last)) {
 250                 NEXT(p2) = p2 + 1; ++runs;
 251                 b++;
 252             }
 253             q = r;
 254         } while (b < t);
 255         sense = !sense;
 256     }
 257     return runs;
 258 }
 259
 260
 261 /* The original merge sort, in use since 5.7, was as fast as, or faster than,
 262  * qsort on many platforms, but slower than qsort, conspicuously so,
 263  * on others.  The most likely explanation was platform-specific
 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,
 270  * as long as smaller is faster, take advantage of them.
 271  *
 272  * By contrast, consider how the original mergesort algorithm worked.
 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.
 339  */
 340
 341 typedef 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
 346
 347 static I32
 348 cmp_desc(pTHX_ gptr const a, gptr const b)
 349 {
 350     return -PL_sort_RealCmp(aTHX_ a, b);
 351 }
 352
 353 STATIC void
 354 S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
 355 {
 356     IV i, run, offset;
 357     I32 sense, level;
 358     gptr *f1, *f2, *t, *b, *p;
 359     int iwhich;
 360     gptr *aux;
 361     gptr *p1;
 362     gptr small[SMALLSORT];
 363     gptr *which[3];
 364     off_runs stack[60], *stackp;
 365     SVCOMPARE_t savecmp = NULL;
 366
 367     if (nmemb <= 1) return;                     /* sorted trivially */
 368
 369     if ((flags & SORTf_DESC) != 0) {
 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
 375     if (nmemb <= SMALLSORT) aux = small;        /* use stack for aux array */
 376     else { Newx(aux,nmemb,gptr); }              /* allocate auxiliary array */
 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          */
 389         IV runs = stackp->runs;
 390         if (runs == 0) {
 391             gptr *list1, *list2;
 392             iwhich = level & 1;
 393             list1 = which[iwhich];              /* area where runs are now */
 394             list2 = which[++iwhich];            /* area for merged runs */
 395             do {
 396                 gptr *l1, *l2, *tp2;
 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
 415                     ** if "q is strictly less than the other",
 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
 426                     gptr *q;
 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 */
 553                 NEXT(b) = p;                    /* paralleled pointer for 1st */
 554                 NEXT(p) = t;                    /* ... and for second */
 555             }
 556         }
 557     }
 558   done:
 559     if (aux != small) Safefree(aux);    /* free iff allocated */
 560     if (flags) {
 561          PL_sort_RealCmp = savecmp;     /* Restore current comparison routine, if any */
 562     }
 563     return;
 564 }
 565
 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
 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
 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 */
 660 struct 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
 718 static void
 719 break_here()
 720 {
 721    return; /* good place to set a breakpoint */
 722 }
 723
 724 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
 725
 726 static void
 727 doqsort_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
 764 STATIC void /* the standard unstable (u) quicksort (qsort) */
 765 S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
 766 {
 767    SV * temp;
 768    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
 769    int next_stack_entry = 0;
 770    int part_left;
 771    int part_right;
 772 #ifdef QSORT_ORDER_GUESS
 773    int qsort_break_even;
 774    int swapped;
 775 #endif
 776
 777     PERL_ARGS_ASSERT_QSORTSVU;
 778
 779    /* Make sure we actually have work to do.
 780    */
 781    if (num_elts <= 1) {
 782       return;
 783    }
 784
 785    /* Inoculate large partitions against quadratic behavior */
 786    if (num_elts > QSORT_PLAY_SAFE) {
 787       size_t n;
 788       SV ** const q = array;
 789       for (n = num_elts; n > 1; ) {
 790          const size_t j = (size_t)(n-- * Drand01());
 791          temp = q[j];
 792          q[j] = q[n];
 793          q[n] = temp;
 794       }
 795    }
 796
 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
 897             are referred to as l c and r in the following comments.
 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
1146             const int prev_break = qsort_break_even;
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
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
1295  * using their address in the list1 array, ensuring stability.
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
1319
1320 static I32
1321 cmpindir(pTHX_ gptr const a, gptr const b)
1322 {
1323     gptr * const ap = (gptr *)a;
1324     gptr * const bp = (gptr *)b;
1325     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1326
1327     if (sense)
1328         return sense;
1329     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1330 }
1331
1332 static I32
1333 cmpindir_desc(pTHX_ gptr const a, gptr const b)
1334 {
1335     gptr * const ap = (gptr *)a;
1336     gptr * const bp = (gptr *)b;
1337     const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
1338
1339     /* Reverse the default */
1340     if (sense)
1341         return -sense;
1342     /* But don't reverse the stability test.  */
1343     return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
1344
1345 }
1346
1347 STATIC void
1348 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1349 {
1350     if ((flags & SORTf_STABLE) != 0) {
1351          gptr **pp, *q;
1352          size_t n, j, i;
1353          gptr *small[SMALLSORT], **indir, tmp;
1354          SVCOMPARE_t savecmp;
1355          if (nmemb <= 1) return;     /* sorted trivially */
1356
1357          /* Small arrays can use the stack, big ones must be allocated */
1358          if (nmemb <= SMALLSORT) indir = small;
1359          else { Newx(indir, nmemb, gptr *); }
1360
1361          /* Copy pointers to original array elements into indirect array */
1362          for (n = nmemb, pp = indir, q = list1; n--; ) *pp++ = q++;
1363
1364          savecmp = PL_sort_RealCmp;     /* Save current comparison routine, if any */
1365          PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
1366
1367          /* sort, with indirection */
1368          if (flags & SORTf_DESC)
1369             qsortsvu((gptr *)indir, nmemb, cmpindir_desc);
1370         else
1371             qsortsvu((gptr *)indir, nmemb, cmpindir);
1372
1373          pp = indir;
1374          q = list1;
1375          for (n = nmemb; n--; ) {
1376               /* Assert A: all elements of q with index > n are already
1377                * in place.  This is vacuously true at the start, and we
1378                * put element n where it belongs below (if it wasn't
1379                * already where it belonged). Assert B: we only move
1380                * elements that aren't where they belong,
1381                * so, by A, we never tamper with elements above n.
1382                */
1383               j = pp[n] - q;            /* This sets j so that q[j] is
1384                                          * at pp[n].  *pp[j] belongs in
1385                                          * q[j], by construction.
1386                                          */
1387               if (n != j) {             /* all's well if n == j */
1388                    tmp = q[j];          /* save what's in q[j] */
1389                    do {
1390                         q[j] = *pp[j];  /* put *pp[j] where it belongs */
1391                         i = pp[j] - q;  /* the index in q of the element
1392                                          * just moved */
1393                         pp[j] = q + j;  /* this is ok now */
1394                    } while ((j = i) != n);
1395                    /* There are only finitely many (nmemb) addresses
1396                     * in the pp array.
1397                     * So we must eventually revisit an index we saw before.
1398                     * Suppose the first revisited index is k != n.
1399                     * An index is visited because something else belongs there.
1400                     * If we visit k twice, then two different elements must
1401                     * belong in the same place, which cannot be.
1402                     * So j must get back to n, the loop terminates,
1403                     * and we put the saved element where it belongs.
1404                     */
1405                    q[n] = tmp;          /* put what belongs into
1406                                          * the n-th element */
1407               }
1408          }
1409
1410         /* free iff allocated */
1411          if (indir != small) { Safefree(indir); }
1412          /* restore prevailing comparison routine */
1413          PL_sort_RealCmp = savecmp;
1414     } else if ((flags & SORTf_DESC) != 0) {
1415          const SVCOMPARE_t savecmp = PL_sort_RealCmp;   /* Save current comparison routine, if any */
1416          PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
1417          cmp = cmp_desc;
1418          qsortsvu(list1, nmemb, cmp);
1419          /* restore prevailing comparison routine */
1420          PL_sort_RealCmp = savecmp;
1421     } else {
1422          qsortsvu(list1, nmemb, cmp);
1423     }
1424 }
1425
1426 /*
1427 =head1 Array Manipulation Functions
1428
1429 =for apidoc sortsv
1430
1431 Sort an array.  Here is an example:
1432
1433     sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
1434
1435 Currently this always uses mergesort.  See C<L</sortsv_flags>> for a more
1436 flexible routine.
1437
1438 =cut
1439 */
1440
1441 void
1442 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
1443 {
1444     PERL_ARGS_ASSERT_SORTSV;
1445
1446     sortsv_flags(array, nmemb, cmp, 0);
1447 }
1448
1449 /*
1450 =for apidoc sortsv_flags
1451
1452 Sort an array, with various options.
1453
1454 =cut
1455 */
1456 void
1457 Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1458 {
1459     PERL_ARGS_ASSERT_SORTSV_FLAGS;
1460
1461     if (flags & SORTf_QSORT)
1462         S_qsortsv(aTHX_ array, nmemb, cmp, flags);
1463     else
1464         S_mergesortsv(aTHX_ array, nmemb, cmp, flags);
1465 }
1466
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
1471 PP(pp_sort)
1472 {
1473     dSP; dMARK; dORIGMARK;
1474     SV **p1 = ORIGMARK+1, **p2;
1475     SSize_t max, i;
1476     AV* av = NULL;
1477     GV *gv;
1478     CV *cv = NULL;
1479     I32 gimme = GIMME_V;
1480     OP* const nextop = PL_op->op_next;
1481     I32 overloading = 0;
1482     bool hasargs = FALSE;
1483     bool copytmps;
1484     I32 is_xsub = 0;
1485     I32 sorting_av = 0;
1486     const U8 priv = PL_op->op_private;
1487     const U8 flags = PL_op->op_flags;
1488     U32 sort_flags = 0;
1489     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
1490       = Perl_sortsv_flags;
1491     I32 all_SIVs = 1;
1492
1493     if ((priv & OPpSORT_DESCEND) != 0)
1494         sort_flags |= SORTf_DESC;
1495     if ((priv & OPpSORT_QSORT) != 0)
1496         sort_flags |= SORTf_QSORT;
1497     if ((priv & OPpSORT_STABLE) != 0)
1498         sort_flags |= SORTf_STABLE;
1499
1500     if (gimme != G_ARRAY) {
1501         SP = MARK;
1502         EXTEND(SP,1);
1503         RETPUSHUNDEF;
1504     }
1505
1506     ENTER;
1507     SAVEVPTR(PL_sortcop);
1508     if (flags & OPf_STACKED) {
1509         if (flags & OPf_SPECIAL) {
1510             OP *nullop = OpSIBLING(cLISTOP->op_first);  /* pass pushmark */
1511             assert(nullop->op_type == OP_NULL);
1512             PL_sortcop = nullop->op_next;
1513         }
1514         else {
1515             GV *autogv = NULL;
1516             HV *stash;
1517             cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
1518           check_cv:
1519             if (cv && SvPOK(cv)) {
1520                 const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
1521                 if (proto && strEQ(proto, "$$")) {
1522                     hasargs = TRUE;
1523                 }
1524             }
1525             if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
1526                 is_xsub = 1;
1527             }
1528             else if (!(cv && CvROOT(cv))) {
1529                 if (gv) {
1530                     goto autoload;
1531                 }
1532                 else if (!CvANON(cv) && (gv = CvGV(cv))) {
1533                   if (cv != GvCV(gv)) cv = GvCV(gv);
1534                  autoload:
1535                   if (!autogv && (
1536                         autogv = gv_autoload_pvn(
1537                             GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1538                             GvNAMEUTF8(gv) ? SVf_UTF8 : 0
1539                         )
1540                      )) {
1541                     cv = GvCVu(autogv);
1542                     goto check_cv;
1543                   }
1544                   else {
1545                     SV *tmpstr = sv_newmortal();
1546                     gv_efullname3(tmpstr, gv, NULL);
1547                     DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
1548                         SVfARG(tmpstr));
1549                   }
1550                 }
1551                 else {
1552                     DIE(aTHX_ "Undefined subroutine in sort");
1553                 }
1554             }
1555
1556             if (is_xsub)
1557                 PL_sortcop = (OP*)cv;
1558             else
1559                 PL_sortcop = CvSTART(cv);
1560         }
1561     }
1562     else {
1563         PL_sortcop = NULL;
1564     }
1565
1566     /* optimiser converts "@a = sort @a" to "sort \@a";
1567      * in case of tied @a, pessimise: push (@a) onto stack, then assign
1568      * result back to @a at the end of this function */
1569     if (priv & OPpSORT_INPLACE) {
1570         assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
1571         (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
1572         av = MUTABLE_AV((*SP));
1573         max = AvFILL(av) + 1;
1574         if (SvMAGICAL(av)) {
1575             MEXTEND(SP, max);
1576             for (i=0; i < max; i++) {
1577                 SV **svp = av_fetch(av, i, FALSE);
1578                 *SP++ = (svp) ? *svp : NULL;
1579             }
1580             SP--;
1581             p1 = p2 = SP - (max-1);
1582         }
1583         else {
1584             if (SvREADONLY(av))
1585                 Perl_croak_no_modify();
1586             else
1587             {
1588                 SvREADONLY_on(av);
1589                 save_pushptr((void *)av, SAVEt_READONLY_OFF);
1590             }
1591             p1 = p2 = AvARRAY(av);
1592             sorting_av = 1;
1593         }
1594     }
1595     else {
1596         p2 = MARK+1;
1597         max = SP - MARK;
1598    }
1599
1600     /* shuffle stack down, removing optional initial cv (p1!=p2), plus
1601      * any nulls; also stringify or converting to integer or number as
1602      * required any args */
1603     copytmps = !sorting_av && PL_sortcop;
1604     for (i=max; i > 0 ; i--) {
1605         if ((*p1 = *p2++)) {                    /* Weed out nulls. */
1606             if (copytmps && SvPADTMP(*p1)) {
1607                 *p1 = sv_mortalcopy(*p1);
1608             }
1609             SvTEMP_off(*p1);
1610             if (!PL_sortcop) {
1611                 if (priv & OPpSORT_NUMERIC) {
1612                     if (priv & OPpSORT_INTEGER) {
1613                         if (!SvIOK(*p1))
1614                             (void)sv_2iv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1615                     }
1616                     else {
1617                         if (!SvNSIOK(*p1))
1618                             (void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
1619                         if (all_SIVs && !SvSIOK(*p1))
1620                             all_SIVs = 0;
1621                     }
1622                 }
1623                 else {
1624                     if (!SvPOK(*p1))
1625                         (void)sv_2pv_flags(*p1, 0,
1626                             SV_GMAGIC|SV_CONST_RETURN|SV_SKIP_OVERLOAD);
1627                 }
1628                 if (SvAMAGIC(*p1))
1629                     overloading = 1;
1630             }
1631             p1++;
1632         }
1633         else
1634             max--;
1635     }
1636     if (sorting_av)
1637         AvFILLp(av) = max-1;
1638
1639     if (max > 1) {
1640         SV **start;
1641         if (PL_sortcop) {
1642             PERL_CONTEXT *cx;
1643             SV** newsp;
1644             const bool oldcatch = CATCH_GET;
1645
1646             SAVETMPS;
1647             SAVEOP();
1648
1649             CATCH_SET(TRUE);
1650             PUSHSTACKi(PERLSI_SORT);
1651             if (!hasargs && !is_xsub) {
1652                 SAVEGENERICSV(PL_firstgv);
1653                 SAVEGENERICSV(PL_secondgv);
1654                 PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
1655                     gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
1656                 ));
1657                 PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
1658                     gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
1659                 ));
1660                 SAVESPTR(GvSV(PL_firstgv));
1661                 SAVESPTR(GvSV(PL_secondgv));
1662             }
1663
1664             gimme = G_SCALAR;
1665             PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1666             if (!(flags & OPf_SPECIAL)) {
1667                 cx->cx_type = CXt_SUB;
1668                 /* If our comparison routine is already active (CvDEPTH is
1669                  * is not 0),  then PUSHSUB does not increase the refcount,
1670                  * so we have to do it ourselves, because the LEAVESUB fur-
1671                  * ther down lowers it. */
1672                 if (CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv);
1673                 PUSHSUB(cx);
1674                 if (!is_xsub) {
1675                     PADLIST * const padlist = CvPADLIST(cv);
1676
1677                     if (++CvDEPTH(cv) >= 2) {
1678                         PERL_STACK_OVERFLOW_CHECK();
1679                         pad_push(padlist, CvDEPTH(cv));
1680                     }
1681                     SAVECOMPPAD();
1682                     PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
1683
1684                     if (hasargs) {
1685                         /* This is mostly copied from pp_entersub */
1686                         AV * const av = MUTABLE_AV(PAD_SVl(0));
1687
1688                         cx->blk_sub.savearray = GvAV(PL_defgv);
1689                         GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
1690                         CX_CURPAD_SAVE(cx->blk_sub);
1691                         cx->blk_sub.argarray = av;
1692                     }
1693
1694                 }
1695             }
1696             cx->cx_type |= CXp_MULTICALL;
1697
1698             start = p1 - max;
1699             sortsvp(aTHX_ start, max,
1700                     (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
1701                     sort_flags);
1702
1703             if (!(flags & OPf_SPECIAL)) {
1704                 SV *sv;
1705                 /* Reset cx, in case the context stack has been
1706                    reallocated. */
1707                 cx = &cxstack[cxstack_ix];
1708                 POPSUB(cx, sv);
1709                 LEAVESUB(sv);
1710             }
1711             POPBLOCK(cx,PL_curpm);
1712             PL_stack_sp = newsp;
1713             POPSTACK;
1714             CATCH_SET(oldcatch);
1715         }
1716         else {
1717             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
1718             start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
1719             sortsvp(aTHX_ start, max,
1720                     (priv & OPpSORT_NUMERIC)
1721                         ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
1722                             ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
1723                             : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
1724                         : (
1725 #ifdef USE_LOCALE_COLLATE
1726                            IN_LC_RUNTIME(LC_COLLATE)
1727                             ? ( overloading
1728                                 ? (SVCOMPARE_t)S_amagic_cmp_locale
1729                                 : (SVCOMPARE_t)sv_cmp_locale_static)
1730                             :
1731 #endif
1732                               ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
1733                     sort_flags);
1734         }
1735         if ((priv & OPpSORT_REVERSE) != 0) {
1736             SV **q = start+max-1;
1737             while (start < q) {
1738                 SV * const tmp = *start;
1739                 *start++ = *q;
1740                 *q-- = tmp;
1741             }
1742         }
1743     }
1744     if (sorting_av)
1745         SvREADONLY_off(av);
1746     else if (av && !sorting_av) {
1747         /* simulate pp_aassign of tied AV */
1748         SV** const base = MARK+1;
1749         for (i=0; i < max; i++) {
1750             base[i] = newSVsv(base[i]);
1751         }
1752         av_clear(av);
1753         av_extend(av, max);
1754         for (i=0; i < max; i++) {
1755             SV * const sv = base[i];
1756             SV ** const didstore = av_store(av, i, sv);
1757             if (SvSMAGICAL(sv))
1758                 mg_set(sv);
1759             if (!didstore)
1760                 sv_2mortal(sv);
1761         }
1762     }
1763     LEAVE;
1764     PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
1765     return nextop;
1766 }
1767
1768 static I32
1769 S_sortcv(pTHX_ SV *const a, SV *const b)
1770 {
1771     const I32 oldsaveix = PL_savestack_ix;
1772     const I32 oldscopeix = PL_scopestack_ix;
1773     I32 result;
1774     PMOP * const pm = PL_curpm;
1775     COP * const cop = PL_curcop;
1776
1777     PERL_ARGS_ASSERT_SORTCV;
1778
1779     GvSV(PL_firstgv) = a;
1780     GvSV(PL_secondgv) = b;
1781     PL_stack_sp = PL_stack_base;
1782     PL_op = PL_sortcop;
1783     CALLRUNOPS(aTHX);
1784     PL_curcop = cop;
1785     /* entry zero of a stack is always PL_sv_undef, which
1786      * simplifies converting a '()' return into undef in scalar context */
1787     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1788     result = SvIV(*PL_stack_sp);
1789
1790     while (PL_scopestack_ix > oldscopeix) {
1791         LEAVE;
1792     }
1793     leave_scope(oldsaveix);
1794     PL_curpm = pm;
1795     return result;
1796 }
1797
1798 static I32
1799 S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
1800 {
1801     const I32 oldsaveix = PL_savestack_ix;
1802     const I32 oldscopeix = PL_scopestack_ix;
1803     I32 result;
1804     AV * const av = GvAV(PL_defgv);
1805     PMOP * const pm = PL_curpm;
1806     COP * const cop = PL_curcop;
1807
1808     PERL_ARGS_ASSERT_SORTCV_STACKED;
1809
1810     if (AvREAL(av)) {
1811         av_clear(av);
1812         AvREAL_off(av);
1813         AvREIFY_on(av);
1814     }
1815     if (AvMAX(av) < 1) {
1816         SV **ary = AvALLOC(av);
1817         if (AvARRAY(av) != ary) {
1818             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1819             AvARRAY(av) = ary;
1820         }
1821         if (AvMAX(av) < 1) {
1822             AvMAX(av) = 1;
1823             Renew(ary,2,SV*);
1824             AvARRAY(av) = ary;
1825             AvALLOC(av) = ary;
1826         }
1827     }
1828     AvFILLp(av) = 1;
1829
1830     AvARRAY(av)[0] = a;
1831     AvARRAY(av)[1] = b;
1832     PL_stack_sp = PL_stack_base;
1833     PL_op = PL_sortcop;
1834     CALLRUNOPS(aTHX);
1835     PL_curcop = cop;
1836     /* entry zero of a stack is always PL_sv_undef, which
1837      * simplifies converting a '()' return into undef in scalar context */
1838     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1839     result = SvIV(*PL_stack_sp);
1840
1841     while (PL_scopestack_ix > oldscopeix) {
1842         LEAVE;
1843     }
1844     leave_scope(oldsaveix);
1845     PL_curpm = pm;
1846     return result;
1847 }
1848
1849 static I32
1850 S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
1851 {
1852     dSP;
1853     const I32 oldsaveix = PL_savestack_ix;
1854     const I32 oldscopeix = PL_scopestack_ix;
1855     CV * const cv=MUTABLE_CV(PL_sortcop);
1856     I32 result;
1857     PMOP * const pm = PL_curpm;
1858
1859     PERL_ARGS_ASSERT_SORTCV_XSUB;
1860
1861     SP = PL_stack_base;
1862     PUSHMARK(SP);
1863     EXTEND(SP, 2);
1864     *++SP = a;
1865     *++SP = b;
1866     PUTBACK;
1867     (void)(*CvXSUB(cv))(aTHX_ cv);
1868     /* entry zero of a stack is always PL_sv_undef, which
1869      * simplifies converting a '()' return into undef in scalar context */
1870     assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
1871     result = SvIV(*PL_stack_sp);
1872
1873     while (PL_scopestack_ix > oldscopeix) {
1874         LEAVE;
1875     }
1876     leave_scope(oldsaveix);
1877     PL_curpm = pm;
1878     return result;
1879 }
1880
1881
1882 static I32
1883 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
1884 {
1885     const NV nv1 = SvNSIV(a);
1886     const NV nv2 = SvNSIV(b);
1887
1888     PERL_ARGS_ASSERT_SV_NCMP;
1889
1890 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1891     if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
1892 #else
1893     if (nv1 != nv1 || nv2 != nv2) {
1894 #endif
1895         if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
1896         return 0;
1897     }
1898     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
1899 }
1900
1901 static I32
1902 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
1903 {
1904     const IV iv1 = SvIV(a);
1905     const IV iv2 = SvIV(b);
1906
1907     PERL_ARGS_ASSERT_SV_I_NCMP;
1908
1909     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
1910 }
1911
1912 #define tryCALL_AMAGICbin(left,right,meth) \
1913     (SvAMAGIC(left)||SvAMAGIC(right)) \
1914         ? amagic_call(left, right, meth, 0) \
1915         : NULL;
1916
1917 #define SORT_NORMAL_RETURN_VALUE(val)  (((val) > 0) ? 1 : ((val) ? -1 : 0))
1918
1919 static I32
1920 S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
1921 {
1922     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1923
1924     PERL_ARGS_ASSERT_AMAGIC_NCMP;
1925
1926     if (tmpsv) {
1927         if (SvIOK(tmpsv)) {
1928             const I32 i = SvIVX(tmpsv);
1929             return SORT_NORMAL_RETURN_VALUE(i);
1930         }
1931         else {
1932             const NV d = SvNV(tmpsv);
1933             return SORT_NORMAL_RETURN_VALUE(d);
1934         }
1935      }
1936      return S_sv_ncmp(aTHX_ a, b);
1937 }
1938
1939 static I32
1940 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
1941 {
1942     SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
1943
1944     PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
1945
1946     if (tmpsv) {
1947         if (SvIOK(tmpsv)) {
1948             const I32 i = SvIVX(tmpsv);
1949             return SORT_NORMAL_RETURN_VALUE(i);
1950         }
1951         else {
1952             const NV d = SvNV(tmpsv);
1953             return SORT_NORMAL_RETURN_VALUE(d);
1954         }
1955     }
1956     return S_sv_i_ncmp(aTHX_ a, b);
1957 }
1958
1959 static I32
1960 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
1961 {
1962     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1963
1964     PERL_ARGS_ASSERT_AMAGIC_CMP;
1965
1966     if (tmpsv) {
1967         if (SvIOK(tmpsv)) {
1968             const I32 i = SvIVX(tmpsv);
1969             return SORT_NORMAL_RETURN_VALUE(i);
1970         }
1971         else {
1972             const NV d = SvNV(tmpsv);
1973             return SORT_NORMAL_RETURN_VALUE(d);
1974         }
1975     }
1976     return sv_cmp(str1, str2);
1977 }
1978
1979 #ifdef USE_LOCALE_COLLATE
1980
1981 static I32
1982 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
1983 {
1984     SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
1985
1986     PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
1987
1988     if (tmpsv) {
1989         if (SvIOK(tmpsv)) {
1990             const I32 i = SvIVX(tmpsv);
1991             return SORT_NORMAL_RETURN_VALUE(i);
1992         }
1993         else {
1994             const NV d = SvNV(tmpsv);
1995             return SORT_NORMAL_RETURN_VALUE(d);
1996         }
1997     }
1998     return sv_cmp_locale(str1, str2);
1999 }
2000
2001 #endif
2002
2003 /*
2004  * ex: set ts=8 sts=4 sw=4 et:
2005  */