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 U8 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 const bool oldcatch = CATCH_GET; 1644 I32 old_savestack_ix = PL_savestack_ix; 1645 1646 SAVEOP(); 1647 1648 CATCH_SET(TRUE); 1649 PUSHSTACKi(PERLSI_SORT); 1650 if (!hasargs && !is_xsub) { 1651 SAVEGENERICSV(PL_firstgv); 1652 SAVEGENERICSV(PL_secondgv); 1653 PL_firstgv = MUTABLE_GV(SvREFCNT_inc( 1654 gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV) 1655 )); 1656 PL_secondgv = MUTABLE_GV(SvREFCNT_inc( 1657 gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV) 1658 )); 1659 /* make sure the GP isn't removed out from under us for 1660 * the SAVESPTR() */ 1661 save_gp(PL_firstgv, 0); 1662 save_gp(PL_secondgv, 0); 1663 /* we don't want modifications localized */ 1664 GvINTRO_off(PL_firstgv); 1665 GvINTRO_off(PL_secondgv); 1666 SAVESPTR(GvSV(PL_firstgv)); 1667 SAVESPTR(GvSV(PL_secondgv)); 1668 } 1669 1670 gimme = G_SCALAR; 1671 cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix); 1672 if (!(flags & OPf_SPECIAL)) { 1673 cx->cx_type = CXt_SUB|CXp_MULTICALL; 1674 cx_pushsub(cx, cv, NULL, hasargs); 1675 if (!is_xsub) { 1676 PADLIST * const padlist = CvPADLIST(cv); 1677 1678 if (++CvDEPTH(cv) >= 2) 1679 pad_push(padlist, CvDEPTH(cv)); 1680 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 1681 1682 if (hasargs) { 1683 /* This is mostly copied from pp_entersub */ 1684 AV * const av = MUTABLE_AV(PAD_SVl(0)); 1685 1686 cx->blk_sub.savearray = GvAV(PL_defgv); 1687 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); 1688 } 1689 1690 } 1691 } 1692 1693 start = p1 - max; 1694 sortsvp(aTHX_ start, max, 1695 (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv), 1696 sort_flags); 1697 1698 /* Reset cx, in case the context stack has been reallocated. */ 1699 cx = CX_CUR(); 1700 1701 PL_stack_sp = PL_stack_base + cx->blk_oldsp; 1702 1703 CX_LEAVE_SCOPE(cx); 1704 if (!(flags & OPf_SPECIAL)) { 1705 assert(CxTYPE(cx) == CXt_SUB); 1706 cx_popsub(cx); 1707 } 1708 else 1709 assert(CxTYPE(cx) == CXt_NULL); 1710 /* there isn't a POPNULL ! */ 1711 1712 cx_popblock(cx); 1713 CX_POP(cx); 1714 POPSTACK; 1715 CATCH_SET(oldcatch); 1716 } 1717 else { 1718 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ 1719 start = sorting_av ? AvARRAY(av) : ORIGMARK+1; 1720 sortsvp(aTHX_ start, max, 1721 (priv & OPpSORT_NUMERIC) 1722 ? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs) 1723 ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp) 1724 : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) ) 1725 : ( 1726 #ifdef USE_LOCALE_COLLATE 1727 IN_LC_RUNTIME(LC_COLLATE) 1728 ? ( overloading 1729 ? (SVCOMPARE_t)S_amagic_cmp_locale 1730 : (SVCOMPARE_t)sv_cmp_locale_static) 1731 : 1732 #endif 1733 ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)), 1734 sort_flags); 1735 } 1736 if ((priv & OPpSORT_REVERSE) != 0) { 1737 SV **q = start+max-1; 1738 while (start < q) { 1739 SV * const tmp = *start; 1740 *start++ = *q; 1741 *q-- = tmp; 1742 } 1743 } 1744 } 1745 if (sorting_av) 1746 SvREADONLY_off(av); 1747 else if (av && !sorting_av) { 1748 /* simulate pp_aassign of tied AV */ 1749 SV** const base = MARK+1; 1750 for (i=0; i < max; i++) { 1751 base[i] = newSVsv(base[i]); 1752 } 1753 av_clear(av); 1754 av_extend(av, max); 1755 for (i=0; i < max; i++) { 1756 SV * const sv = base[i]; 1757 SV ** const didstore = av_store(av, i, sv); 1758 if (SvSMAGICAL(sv)) 1759 mg_set(sv); 1760 if (!didstore) 1761 sv_2mortal(sv); 1762 } 1763 } 1764 LEAVE; 1765 PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max); 1766 return nextop; 1767 } 1768 1769 static I32 1770 S_sortcv(pTHX_ SV *const a, SV *const b) 1771 { 1772 const I32 oldsaveix = PL_savestack_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 LEAVE_SCOPE(oldsaveix); 1791 PL_curpm = pm; 1792 return result; 1793 } 1794 1795 static I32 1796 S_sortcv_stacked(pTHX_ SV *const a, SV *const b) 1797 { 1798 const I32 oldsaveix = PL_savestack_ix; 1799 I32 result; 1800 AV * const av = GvAV(PL_defgv); 1801 PMOP * const pm = PL_curpm; 1802 COP * const cop = PL_curcop; 1803 1804 PERL_ARGS_ASSERT_SORTCV_STACKED; 1805 1806 if (AvREAL(av)) { 1807 av_clear(av); 1808 AvREAL_off(av); 1809 AvREIFY_on(av); 1810 } 1811 if (AvMAX(av) < 1) { 1812 SV **ary = AvALLOC(av); 1813 if (AvARRAY(av) != ary) { 1814 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 1815 AvARRAY(av) = ary; 1816 } 1817 if (AvMAX(av) < 1) { 1818 AvMAX(av) = 1; 1819 Renew(ary,2,SV*); 1820 AvARRAY(av) = ary; 1821 AvALLOC(av) = ary; 1822 } 1823 } 1824 AvFILLp(av) = 1; 1825 1826 AvARRAY(av)[0] = a; 1827 AvARRAY(av)[1] = b; 1828 PL_stack_sp = PL_stack_base; 1829 PL_op = PL_sortcop; 1830 CALLRUNOPS(aTHX); 1831 PL_curcop = cop; 1832 /* entry zero of a stack is always PL_sv_undef, which 1833 * simplifies converting a '()' return into undef in scalar context */ 1834 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); 1835 result = SvIV(*PL_stack_sp); 1836 1837 LEAVE_SCOPE(oldsaveix); 1838 PL_curpm = pm; 1839 return result; 1840 } 1841 1842 static I32 1843 S_sortcv_xsub(pTHX_ SV *const a, SV *const b) 1844 { 1845 dSP; 1846 const I32 oldsaveix = PL_savestack_ix; 1847 CV * const cv=MUTABLE_CV(PL_sortcop); 1848 I32 result; 1849 PMOP * const pm = PL_curpm; 1850 1851 PERL_ARGS_ASSERT_SORTCV_XSUB; 1852 1853 SP = PL_stack_base; 1854 PUSHMARK(SP); 1855 EXTEND(SP, 2); 1856 *++SP = a; 1857 *++SP = b; 1858 PUTBACK; 1859 (void)(*CvXSUB(cv))(aTHX_ cv); 1860 /* entry zero of a stack is always PL_sv_undef, which 1861 * simplifies converting a '()' return into undef in scalar context */ 1862 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); 1863 result = SvIV(*PL_stack_sp); 1864 1865 LEAVE_SCOPE(oldsaveix); 1866 PL_curpm = pm; 1867 return result; 1868 } 1869 1870 1871 static I32 1872 S_sv_ncmp(pTHX_ SV *const a, SV *const b) 1873 { 1874 const NV nv1 = SvNSIV(a); 1875 const NV nv2 = SvNSIV(b); 1876 1877 PERL_ARGS_ASSERT_SV_NCMP; 1878 1879 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1880 if (Perl_isnan(nv1) || Perl_isnan(nv2)) { 1881 #else 1882 if (nv1 != nv1 || nv2 != nv2) { 1883 #endif 1884 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL); 1885 return 0; 1886 } 1887 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; 1888 } 1889 1890 static I32 1891 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b) 1892 { 1893 const IV iv1 = SvIV(a); 1894 const IV iv2 = SvIV(b); 1895 1896 PERL_ARGS_ASSERT_SV_I_NCMP; 1897 1898 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; 1899 } 1900 1901 #define tryCALL_AMAGICbin(left,right,meth) \ 1902 (SvAMAGIC(left)||SvAMAGIC(right)) \ 1903 ? amagic_call(left, right, meth, 0) \ 1904 : NULL; 1905 1906 #define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0)) 1907 1908 static I32 1909 S_amagic_ncmp(pTHX_ SV *const a, SV *const b) 1910 { 1911 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg); 1912 1913 PERL_ARGS_ASSERT_AMAGIC_NCMP; 1914 1915 if (tmpsv) { 1916 if (SvIOK(tmpsv)) { 1917 const I32 i = SvIVX(tmpsv); 1918 return SORT_NORMAL_RETURN_VALUE(i); 1919 } 1920 else { 1921 const NV d = SvNV(tmpsv); 1922 return SORT_NORMAL_RETURN_VALUE(d); 1923 } 1924 } 1925 return S_sv_ncmp(aTHX_ a, b); 1926 } 1927 1928 static I32 1929 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b) 1930 { 1931 SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg); 1932 1933 PERL_ARGS_ASSERT_AMAGIC_I_NCMP; 1934 1935 if (tmpsv) { 1936 if (SvIOK(tmpsv)) { 1937 const I32 i = SvIVX(tmpsv); 1938 return SORT_NORMAL_RETURN_VALUE(i); 1939 } 1940 else { 1941 const NV d = SvNV(tmpsv); 1942 return SORT_NORMAL_RETURN_VALUE(d); 1943 } 1944 } 1945 return S_sv_i_ncmp(aTHX_ a, b); 1946 } 1947 1948 static I32 1949 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2) 1950 { 1951 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg); 1952 1953 PERL_ARGS_ASSERT_AMAGIC_CMP; 1954 1955 if (tmpsv) { 1956 if (SvIOK(tmpsv)) { 1957 const I32 i = SvIVX(tmpsv); 1958 return SORT_NORMAL_RETURN_VALUE(i); 1959 } 1960 else { 1961 const NV d = SvNV(tmpsv); 1962 return SORT_NORMAL_RETURN_VALUE(d); 1963 } 1964 } 1965 return sv_cmp(str1, str2); 1966 } 1967 1968 #ifdef USE_LOCALE_COLLATE 1969 1970 static I32 1971 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2) 1972 { 1973 SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg); 1974 1975 PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE; 1976 1977 if (tmpsv) { 1978 if (SvIOK(tmpsv)) { 1979 const I32 i = SvIVX(tmpsv); 1980 return SORT_NORMAL_RETURN_VALUE(i); 1981 } 1982 else { 1983 const NV d = SvNV(tmpsv); 1984 return SORT_NORMAL_RETURN_VALUE(d); 1985 } 1986 } 1987 return sv_cmp_locale(str1, str2); 1988 } 1989 1990 #endif 1991 1992 /* 1993 * ex: set ts=8 sts=4 sw=4 et: 1994 */ 1995