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