src/runtime/purify.c

   1 /*
   2  * C-level stuff to implement Lisp-level PURIFY
   3  */
   4
   5 /*
   6  * This software is part of the SBCL system. See the README file for
   7  * more information.
   8  *
   9  * This software is derived from the CMU CL system, which was
  10  * written at Carnegie Mellon University and released into the
  11  * public domain. The software is in the public domain and is
  12  * provided with absolutely no warranty. See the COPYING and CREDITS
  13  * files for more information.
  14  */
  15
  16 #include <stdio.h>
  17 #include <sys/types.h>
  18 #include <stdlib.h>
  19 #include <strings.h>
  20 #include <errno.h>
  21
  22 #include "sbcl.h"
  23 #include "runtime.h"
  24 #include "os.h"
  25 #include "globals.h"
  26 #include "validate.h"
  27 #include "interrupt.h"
  28 #include "purify.h"
  29 #include "interr.h"
  30 #include "gc.h"
  31 #include "gc-internal.h"
  32 #include "thread.h"
  33 #include "genesis/gc-tables.h"
  34 #include "genesis/primitive-objects.h"
  35 #include "genesis/static-symbols.h"
  36 #include "genesis/layout.h"
  37 #include "genesis/hash-table.h"
  38 #include "gencgc.h"
  39
  40 /* We don't ever do purification with GENCGC as of 1.0.5.*. There was
  41  * a lot of hairy and fragile ifdeffage in here to support purify on
  42  * x86oids, which has now been removed. So this code can't even be
  43  * compiled with GENCGC any more.  -- JES, 2007-04-30.
  44  */
  45 #ifndef LISP_FEATURE_GENCGC
  46
  47 #define PRINTNOISE
  48
  49 static lispobj *dynamic_space_purify_pointer;
  50
  51 \f
  52 /* These hold the original end of the read_only and static spaces so
  53  * we can tell what are forwarding pointers. */
  54
  55 static lispobj *read_only_end, *static_end;
  56
  57 static lispobj *read_only_free, *static_free;
  58
  59 static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
  60
  61 #define LATERBLOCKSIZE 1020
  62 #define LATERMAXCOUNT 10
  63
  64 static struct
  65 later {
  66     struct later *next;
  67     union {
  68         lispobj *ptr;
  69         long count;
  70     } u[LATERBLOCKSIZE];
  71 } *later_blocks = NULL;
  72 static long later_count = 0;
  73
  74 \f
  75 static boolean
  76 forwarding_pointer_p(lispobj obj)
  77 {
  78     lispobj *ptr = native_pointer(obj);
  79
  80     return ((static_end <= ptr && ptr <= static_free) ||
  81             (read_only_end <= ptr && ptr <= read_only_free));
  82 }
  83
  84 static boolean
  85 dynamic_pointer_p(lispobj ptr)
  86 {
  87     return (ptr >= (lispobj)current_dynamic_space
  88             &&
  89             ptr < (lispobj)dynamic_space_purify_pointer);
  90 }
  91
  92 static inline lispobj *
  93 newspace_alloc(long nwords, int constantp)
  94 {
  95     lispobj *ret;
  96     gc_assert((nwords & 1) == 0);
  97     if(constantp) {
  98         if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) {
  99             lose("Ran out of read-only space while purifying!\n");
 100         }
 101         ret=read_only_free;
 102         read_only_free+=nwords;
 103     } else {
 104         if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) {
 105             lose("Ran out of static space while purifying!\n");
 106         }
 107         ret=static_free;
 108         static_free+=nwords;
 109     }
 110     return ret;
 111 }
 112
 113 \f
 114 static void
 115 pscav_later(lispobj *where, long count)
 116 {
 117     struct later *new;
 118
 119     if (count > LATERMAXCOUNT) {
 120         while (count > LATERMAXCOUNT) {
 121             pscav_later(where, LATERMAXCOUNT);
 122             count -= LATERMAXCOUNT;
 123             where += LATERMAXCOUNT;
 124         }
 125     }
 126     else {
 127         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
 128             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
 129             new  = (struct later *)malloc(sizeof(struct later));
 130             new->next = later_blocks;
 131             if (later_blocks && later_count < LATERBLOCKSIZE)
 132                 later_blocks->u[later_count].ptr = NULL;
 133             later_blocks = new;
 134             later_count = 0;
 135         }
 136
 137         if (count != 1)
 138             later_blocks->u[later_count++].count = count;
 139         later_blocks->u[later_count++].ptr = where;
 140     }
 141 }
 142
 143 static lispobj
 144 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 145 {
 146     /* Allocate it */
 147     lispobj *old = native_pointer(thing);
 148     long nwords = sizetab[widetag_of(header)](old);
 149     lispobj *new = newspace_alloc(nwords,constant);
 150
 151     /* Copy it. */
 152     bcopy(old, new, nwords * sizeof(lispobj));
 153
 154     /* Deposit forwarding pointer. */
 155     lispobj result = make_lispobj(new, lowtag_of(thing));
 156     *old = result;
 157
 158     /* Scavenge it. */
 159     pscav(new, nwords, constant);
 160
 161     return result;
 162 }
 163
 164 /* We need to look at the layout to see whether it is a pure structure
 165  * class, and only then can we transport as constant. If it is pure,
 166  * we can ALWAYS transport as a constant. */
 167 static lispobj
 168 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
 169 {
 170     lispobj layout = instance_layout(native_pointer(thing));
 171     lispobj pure = LAYOUT(layout)->pure;
 172
 173     switch (pure) {
 174     case T:
 175         return (ptrans_boxed(thing, header, 1));
 176     case NIL:
 177         return (ptrans_boxed(thing, header, 0));
 178     default:
 179         gc_abort();
 180         return NIL; /* dummy value: return something ... */
 181     }
 182 }
 183
 184 static lispobj
 185 ptrans_fdefn(lispobj thing, lispobj header)
 186 {
 187     /* Allocate it */
 188     lispobj *old = native_pointer(thing);
 189     long nwords = sizetab[widetag_of(header)](old);
 190     lispobj *new = newspace_alloc(nwords, 0);    /* inconstant */
 191
 192     /* Copy it. */
 193     bcopy(old, new, nwords * sizeof(lispobj));
 194
 195     /* Deposit forwarding pointer. */
 196     lispobj result = make_lispobj(new, lowtag_of(thing));
 197     *old = result;
 198
 199     /* Scavenge the function. */
 200     struct fdefn *fdefn = (struct fdefn *)new;
 201     lispobj oldfn = fdefn->fun;
 202     pscav(&fdefn->fun, 1, 0);
 203     if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
 204         fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
 205
 206     return result;
 207 }
 208
 209 static lispobj
 210 ptrans_unboxed(lispobj thing, lispobj header)
 211 {
 212     /* Allocate it */
 213     lispobj *old = native_pointer(thing);
 214     long nwords = sizetab[widetag_of(header)](old);
 215     lispobj *new = newspace_alloc(nwords, 1);     /* always constant */
 216
 217     /* copy it. */
 218     bcopy(old, new, nwords * sizeof(lispobj));
 219
 220     /* Deposit forwarding pointer. */
 221     lispobj result = make_lispobj(new, lowtag_of(thing));
 222     *old = result;
 223
 224     return result;
 225 }
 226
 227 static lispobj
 228 ptrans_vector(lispobj thing, boolean boxed, boolean constant)
 229 {
 230     struct vector *vector = VECTOR(thing);
 231     long nwords = sizetab[widetag_of(vector->header)]((lispobj*)vector);
 232
 233     lispobj *new = newspace_alloc(nwords, (constant || !boxed));
 234     bcopy(vector, new, nwords * sizeof(lispobj));
 235
 236     lispobj result = make_lispobj(new, lowtag_of(thing));
 237     vector->header = result;
 238
 239     if (boxed)
 240         pscav(new, nwords, constant);
 241
 242     return result;
 243 }
 244
 245 static lispobj
 246 ptrans_code(lispobj thing)
 247 {
 248     struct code *code = (struct code *)native_pointer(thing);
 249     long nwords = code_header_words(code->header)
 250                 + code_instruction_words(code->code_size);
 251
 252     struct code *new = (struct code *)newspace_alloc(nwords,1); /* constant */
 253
 254     bcopy(code, new, nwords * sizeof(lispobj));
 255
 256     lispobj result = make_lispobj(new, OTHER_POINTER_LOWTAG);
 257
 258     /* Put in forwarding pointers for all the functions. */
 259     uword_t displacement = result - thing;
 260     for_each_simple_fun(i, newfunc, new, 1, {
 261         lispobj* old = (lispobj*)LOW_WORD((char*)newfunc - displacement);
 262         *old = make_lispobj(newfunc, FUN_POINTER_LOWTAG);
 263     });
 264
 265     /* Stick in a forwarding pointer for the code object. */
 266     /* This smashes the header, so do it only after reading n_funs */
 267     *(lispobj *)code = result;
 268
 269     /* Arrange to scavenge the debug info later. */
 270     pscav_later(&new->debug_info, 1);
 271
 272     /* Scavenge the constants. */
 273     pscav(new->constants,
 274           code_header_words(new->header) - (offsetof(struct code, constants) >> WORD_SHIFT),
 275           1);
 276
 277     /* Scavenge all the functions. */
 278     for_each_simple_fun(i, func, new, 1, {
 279         gc_assert(!dynamic_pointer_p((lispobj)func));
 280         pscav(&func->self, 1, 1);
 281         pscav_later(&func->name, 4);
 282     })
 283
 284     return result;
 285 }
 286
 287 static lispobj
 288 ptrans_func(lispobj thing, lispobj header)
 289 {
 290     /* Thing can either be a function header,
 291      * a closure, or a funcallable-instance. If it's a closure
 292      * or a funcallable-instance, we do the same as ptrans_boxed.
 293      * Otherwise we have to do something strange, 'cause it is buried
 294      * inside a code object. */
 295
 296     if (widetag_of(header) == SIMPLE_FUN_WIDETAG) {
 297
 298         /* We can only end up here if the code object has not been
 299          * scavenged, because if it had been scavenged, forwarding pointers
 300          * would have been left behind for all the entry points. */
 301
 302         struct simple_fun *function = (struct simple_fun *)native_pointer(thing);
 303         lispobj code = make_lispobj(native_pointer(thing) - HeaderValue(function->header),
 304                                     OTHER_POINTER_LOWTAG);
 305
 306         /* This will cause the function's header to be replaced with a
 307          * forwarding pointer. */
 308
 309         ptrans_code(code);
 310
 311         /* So we can just return that. */
 312         return function->header;
 313     } else {
 314         /* It's some kind of closure-like thing. */
 315         lispobj *old = native_pointer(thing);
 316         long nwords = sizetab[widetag_of(header)](old);
 317
 318         /* Allocate the new one.  FINs *must* not go in read_only
 319          * space.  Closures can; they never change */
 320
 321         lispobj *new = newspace_alloc
 322             (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_WIDETAG));
 323
 324         /* Copy it. */
 325         bcopy(old, new, nwords * sizeof(lispobj));
 326
 327         /* Deposit forwarding pointer. */
 328         lispobj result = make_lispobj(new, lowtag_of(thing));
 329         *old = result;
 330
 331         /* Scavenge it. */
 332         pscav(new, nwords, 0);
 333
 334         return result;
 335     }
 336 }
 337
 338 static lispobj
 339 ptrans_returnpc(lispobj thing, lispobj header)
 340 {
 341     /* Find the corresponding code object. */
 342     lispobj code = thing - HeaderValue(header)*sizeof(lispobj);
 343
 344     /* Make sure it's been transported. */
 345     lispobj new = *native_pointer(code);
 346     if (!forwarding_pointer_p(new))
 347         new = ptrans_code(code);
 348
 349     /* Maintain the offset: */
 350     return new + (thing - code);
 351 }
 352
 353 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
 354
 355 static lispobj
 356 ptrans_list(lispobj thing, boolean constant)
 357 {
 358     struct cons *old, *new, *orig;
 359     long length;
 360
 361     orig = (struct cons *) newspace_alloc(0,constant);
 362     length = 0;
 363
 364     do {
 365         /* Allocate a new cons cell. */
 366         old = (struct cons *)native_pointer(thing);
 367         new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
 368
 369         /* Copy the cons cell and keep a pointer to the cdr. */
 370         new->car = old->car;
 371         thing = new->cdr = old->cdr;
 372
 373         /* Set up the forwarding pointer. */
 374         *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
 375
 376         /* And count this cell. */
 377         length++;
 378     } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
 379              dynamic_pointer_p(thing) &&
 380              !(forwarding_pointer_p(*native_pointer(thing))));
 381
 382     /* Scavenge the list we just copied. */
 383     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
 384
 385     return make_lispobj(orig, LIST_POINTER_LOWTAG);
 386 }
 387
 388 static lispobj
 389 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 390 {
 391     int widetag = widetag_of(header);
 392     switch (widetag) {
 393         /* FIXME: this needs a reindent */
 394       case BIGNUM_WIDETAG:
 395       case SINGLE_FLOAT_WIDETAG:
 396       case DOUBLE_FLOAT_WIDETAG:
 397 #ifdef LONG_FLOAT_WIDETAG
 398       case LONG_FLOAT_WIDETAG:
 399 #endif
 400 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 401       case COMPLEX_SINGLE_FLOAT_WIDETAG:
 402 #endif
 403 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 404       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 405 #endif
 406 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 407       case COMPLEX_LONG_FLOAT_WIDETAG:
 408 #endif
 409       case SAP_WIDETAG:
 410           return ptrans_unboxed(thing, header);
 411       case RATIO_WIDETAG:
 412       case COMPLEX_WIDETAG:
 413       case SIMPLE_ARRAY_WIDETAG:
 414       case COMPLEX_BASE_STRING_WIDETAG:
 415 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 416     case COMPLEX_CHARACTER_STRING_WIDETAG:
 417 #endif
 418       case COMPLEX_BIT_VECTOR_WIDETAG:
 419       case COMPLEX_VECTOR_NIL_WIDETAG:
 420       case COMPLEX_VECTOR_WIDETAG:
 421       case COMPLEX_ARRAY_WIDETAG:
 422         return ptrans_boxed(thing, header, constant);
 423
 424       case VALUE_CELL_WIDETAG:
 425       case WEAK_POINTER_WIDETAG:
 426         return ptrans_boxed(thing, header, 0);
 427
 428       case SYMBOL_WIDETAG:
 429         return ptrans_boxed(thing, header, 0);
 430
 431       case SIMPLE_VECTOR_WIDETAG:
 432         return ptrans_vector(thing, 1, constant);
 433
 434       case CODE_HEADER_WIDETAG:
 435         return ptrans_code(thing);
 436
 437       case RETURN_PC_WIDETAG:
 438         return ptrans_returnpc(thing, header);
 439
 440       case FDEFN_WIDETAG:
 441         return ptrans_fdefn(thing, header);
 442
 443       default:
 444         if (other_immediate_lowtag_p(widetag) &&
 445             specialized_vector_widetag_p(widetag))
 446             return ptrans_vector(thing, 0, constant);
 447         fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
 448         /* Should only come across other pointers to the above stuff. */
 449         gc_abort();
 450         return NIL;
 451     }
 452 }
 453
 454 static long
 455 pscav_fdefn(struct fdefn *fdefn)
 456 {
 457     boolean fix_func;
 458
 459     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
 460     pscav(&fdefn->name, 1, 1);
 461     pscav(&fdefn->fun, 1, 0);
 462     if (fix_func)
 463         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 464     return sizeof(struct fdefn) / sizeof(lispobj);
 465 }
 466
 467 static lispobj *
 468 pscav(lispobj *addr, long nwords, boolean constant)
 469 {
 470     lispobj thing, *thingp, header;
 471     long count = 0; /* (0 = dummy init value to stop GCC warning) */
 472
 473     while (nwords > 0) {
 474         thing = *addr;
 475         int widetag = widetag_of(thing);
 476         if (is_lisp_pointer(thing)) {
 477             /* It's a pointer. Is it something we might have to move? */
 478             if (dynamic_pointer_p(thing)) {
 479                 /* Maybe. Have we already moved it? */
 480                 thingp = native_pointer(thing);
 481                 header = *thingp;
 482                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
 483                     /* Yep, so just copy the forwarding pointer. */
 484                     thing = header;
 485                 else {
 486                     /* Nope, copy the object. */
 487                     switch (lowtag_of(thing)) {
 488                       case FUN_POINTER_LOWTAG:
 489                         thing = ptrans_func(thing, header);
 490                         break;
 491
 492                       case LIST_POINTER_LOWTAG:
 493                         thing = ptrans_list(thing, constant);
 494                         break;
 495
 496                       case INSTANCE_POINTER_LOWTAG:
 497                         thing = ptrans_instance(thing, header, constant);
 498                         break;
 499
 500                       case OTHER_POINTER_LOWTAG:
 501                         thing = ptrans_otherptr(thing, header, constant);
 502                         break;
 503
 504                       default:
 505                         /* It was a pointer, but not one of them? */
 506                         gc_abort();
 507                     }
 508                 }
 509                 *addr = thing;
 510             }
 511             count = 1;
 512         }
 513 #if N_WORD_BITS == 64
 514         else if (widetag == SINGLE_FLOAT_WIDETAG) {
 515             count = 1;
 516         }
 517 #endif
 518         else if (thing & FIXNUM_TAG_MASK) {
 519             /* It's an other immediate. Maybe the header for an unboxed */
 520             /* object. */
 521             switch (widetag) {
 522               case BIGNUM_WIDETAG:
 523               case SINGLE_FLOAT_WIDETAG:
 524               case DOUBLE_FLOAT_WIDETAG:
 525 #ifdef LONG_FLOAT_WIDETAG
 526               case LONG_FLOAT_WIDETAG:
 527 #endif
 528               case SAP_WIDETAG:
 529                 /* It's an unboxed simple object. */
 530                 count = CEILING(HeaderValue(thing)+1, 2);
 531                 break;
 532
 533               case SIMPLE_VECTOR_WIDETAG:
 534                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
 535                     struct hash_table *hash_table =
 536                         (struct hash_table *)native_pointer(addr[2]);
 537                     hash_table->needs_rehash_p = T;
 538                   }
 539                 count = 2;
 540                 break;
 541
 542               case CODE_HEADER_WIDETAG:
 543                 gc_abort(); /* no code headers in static space */
 544                 break;
 545
 546               case SIMPLE_FUN_WIDETAG:
 547               case RETURN_PC_WIDETAG:
 548                 /* We should never hit any of these, 'cause they occur
 549                  * buried in the middle of code objects. */
 550                 gc_abort();
 551                 break;
 552
 553               case WEAK_POINTER_WIDETAG:
 554                 /* Weak pointers get preserved during purify, 'cause I
 555                  * don't feel like figuring out how to break them. */
 556                 pscav(addr+1, 2, constant);
 557                 count = WEAK_POINTER_NWORDS;
 558                 break;
 559
 560               case FDEFN_WIDETAG:
 561                 /* We have to handle fdefn objects specially, so we
 562                  * can fix up the raw function address. */
 563                 count = pscav_fdefn((struct fdefn *)addr);
 564                 break;
 565
 566               case INSTANCE_WIDETAG:
 567                 {
 568                     lispobj lbitmap = LAYOUT(instance_layout(addr))->bitmap;
 569                     lispobj* slots = addr + 1;
 570                     long nslots = instance_length(*addr) | 1;
 571                     int index;
 572                     if (fixnump(lbitmap)) {
 573                       sword_t bitmap = (sword_t)lbitmap >> N_FIXNUM_TAG_BITS;
 574                       for (index = 0; index < nslots ; index++, bitmap >>= 1)
 575                         if (bitmap & 1)
 576                           pscav(slots + index, 1, constant);
 577                     } else {
 578                       struct bignum * bitmap;
 579                       bitmap = (struct bignum*)native_pointer(lbitmap);
 580                       for (index = 0; index < nslots ; index++)
 581                         if (positive_bignum_logbitp(index, bitmap))
 582                           pscav(slots + index, 1, constant);
 583                     }
 584                     count = 1 + nslots;
 585                 }
 586                 break;
 587
 588               default:
 589                 if (other_immediate_lowtag_p(widetag) &&
 590                     specialized_vector_widetag_p(widetag))
 591                     count = sizetab[widetag_of(thing)](addr);
 592                 else
 593                     count = 1;
 594                 break;
 595             }
 596         }
 597         else {
 598             /* It's a fixnum. */
 599             count = 1;
 600         }
 601
 602         addr += count;
 603         nwords -= count;
 604     }
 605
 606     return addr;
 607 }
 608
 609 int
 610 purify(lispobj static_roots, lispobj read_only_roots)
 611 {
 612     lispobj *clean;
 613     long count, i;
 614     struct later *laters, *next;
 615     struct thread *thread;
 616
 617     if(all_threads->next) {
 618         /* FIXME: there should be _some_ sensible error reporting
 619          * convention.  See following comment too */
 620         fprintf(stderr,"Can't purify when more than one thread exists\n");
 621         fflush(stderr);
 622         return 0;
 623     }
 624
 625 #ifdef PRINTNOISE
 626     printf("[doing purification:");
 627     fflush(stdout);
 628 #endif
 629
 630     for_each_thread(thread)
 631         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
 632         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
 633          * its error simply by a. printing a string b. to stdout instead
 634          * of stderr. */
 635         printf(" Ack! Can't purify interrupt contexts. ");
 636         fflush(stdout);
 637         return 0;
 638     }
 639
 640     dynamic_space_purify_pointer = dynamic_space_free_pointer;
 641
 642     read_only_end = read_only_free =
 643         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
 644     static_end = static_free =
 645         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
 646
 647 #ifdef PRINTNOISE
 648     printf(" roots");
 649     fflush(stdout);
 650 #endif
 651
 652     pscav(&static_roots, 1, 0);
 653     pscav(&read_only_roots, 1, 1);
 654
 655 #ifdef PRINTNOISE
 656     printf(" handlers");
 657     fflush(stdout);
 658 #endif
 659     pscav((lispobj *) interrupt_handlers,
 660           sizeof(interrupt_handlers) / sizeof(lispobj),
 661           0);
 662
 663 #ifdef PRINTNOISE
 664     printf(" stack");
 665     fflush(stdout);
 666 #endif
 667     pscav((lispobj *)all_threads->control_stack_start,
 668           access_control_stack_pointer(all_threads) -
 669           all_threads->control_stack_start,
 670           0);
 671
 672 #ifdef PRINTNOISE
 673     printf(" bindings");
 674     fflush(stdout);
 675 #endif
 676
 677     pscav( (lispobj *)all_threads->binding_stack_start,
 678            (lispobj *)get_binding_stack_pointer(all_threads) -
 679            all_threads->binding_stack_start,
 680           0);
 681
 682     /* The original CMU CL code had scavenge-read-only-space code
 683      * controlled by the Lisp-level variable
 684      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
 685      * wasn't documented under what circumstances it was useful or
 686      * safe to turn it on, so it's been turned off in SBCL. If you
 687      * want/need this functionality, and can test and document it,
 688      * please submit a patch. */
 689 #if 0
 690     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
 691         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
 692       unsigned  read_only_space_size =
 693           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
 694           (lispobj *)READ_ONLY_SPACE_START;
 695       fprintf(stderr,
 696               "scavenging read only space: %d bytes\n",
 697               read_only_space_size * sizeof(lispobj));
 698       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
 699     }
 700 #endif
 701
 702 #ifdef PRINTNOISE
 703     printf(" static");
 704     fflush(stdout);
 705 #endif
 706     clean = (lispobj *)STATIC_SPACE_START;
 707     do {
 708         while (clean != static_free)
 709             clean = pscav(clean, static_free - clean, 0);
 710         laters = later_blocks;
 711         count = later_count;
 712         later_blocks = NULL;
 713         later_count = 0;
 714         while (laters != NULL) {
 715             for (i = 0; i < count; i++) {
 716                 if (laters->u[i].count == 0) {
 717                     ;
 718                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
 719                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
 720                     i++;
 721                 } else {
 722                     pscav(laters->u[i].ptr, 1, 1);
 723                 }
 724             }
 725             next = laters->next;
 726             free(laters);
 727             laters = next;
 728             count = LATERBLOCKSIZE;
 729         }
 730     } while (clean != static_free || later_blocks != NULL);
 731
 732 #ifdef PRINTNOISE
 733     printf(" cleanup");
 734     fflush(stdout);
 735 #endif
 736 #ifdef LISP_FEATURE_HPUX
 737     clear_auto_gc_trigger(); /* restore mmap as it was given by os */
 738 #endif
 739
 740     os_zero((os_vm_address_t) current_dynamic_space, dynamic_space_size);
 741
 742     /* Zero the stack. */
 743     os_zero((os_vm_address_t) access_control_stack_pointer(all_threads),
 744             (os_vm_size_t)
 745             ((all_threads->control_stack_end -
 746               access_control_stack_pointer(all_threads)) * sizeof(lispobj)));
 747
 748     /* It helps to update the heap free pointers so that free_heap can
 749      * verify after it's done. */
 750     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
 751     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
 752
 753     dynamic_space_free_pointer = current_dynamic_space;
 754     set_auto_gc_trigger(bytes_consed_between_gcs);
 755
 756     /* Blast away instruction cache */
 757     os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
 758     os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
 759
 760 #ifdef PRINTNOISE
 761     printf(" done]\n");
 762     fflush(stdout);
 763 #endif
 764     return 0;
 765 }
 766 #else /* LISP_FEATURE_GENCGC */
 767 int
 768 purify(lispobj static_roots, lispobj read_only_roots)
 769 {
 770     lose("purify called for GENCGC. This should not happen.");
 771 }
 772 #endif /* LISP_FEATURE_GENCGC */