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