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/primitive-objects.h"
  34 #include "genesis/static-symbols.h"
  35 #include "genesis/layout.h"
  36 #include "genesis/hash-table.h"
  37 #include "gencgc.h"
  38
  39 /* We don't ever do purification with GENCGC as of 1.0.5.*. There was
  40  * a lot of hairy and fragile ifdeffage in here to support purify on
  41  * x86oids, which has now been removed. So this code can't even be
  42  * compiled with GENCGC any more.  -- JES, 2007-04-30.
  43  */
  44 #ifndef LISP_FEATURE_GENCGC
  45
  46 #define PRINTNOISE
  47
  48 static lispobj *dynamic_space_purify_pointer;
  49
  50 \f
  51 /* These hold the original end of the read_only and static spaces so
  52  * we can tell what are forwarding pointers. */
  53
  54 static lispobj *read_only_end, *static_end;
  55
  56 static lispobj *read_only_free, *static_free;
  57
  58 static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
  59
  60 #define LATERBLOCKSIZE 1020
  61 #define LATERMAXCOUNT 10
  62
  63 static struct
  64 later {
  65     struct later *next;
  66     union {
  67         lispobj *ptr;
  68         long count;
  69     } u[LATERBLOCKSIZE];
  70 } *later_blocks = NULL;
  71 static long later_count = 0;
  72
  73 \f
  74 static boolean
  75 forwarding_pointer_p(lispobj obj)
  76 {
  77     lispobj *ptr = native_pointer(obj);
  78
  79     return ((static_end <= ptr && ptr <= static_free) ||
  80             (read_only_end <= ptr && ptr <= read_only_free));
  81 }
  82
  83 static boolean
  84 dynamic_pointer_p(lispobj ptr)
  85 {
  86     return (ptr >= (lispobj)current_dynamic_space
  87             &&
  88             ptr < (lispobj)dynamic_space_purify_pointer);
  89 }
  90
  91 static inline lispobj *
  92 newspace_alloc(long nwords, int constantp)
  93 {
  94     lispobj *ret;
  95     gc_assert((nwords & 1) == 0);
  96     if(constantp) {
  97         if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) {
  98             lose("Ran out of read-only space while purifying!\n");
  99         }
 100         ret=read_only_free;
 101         read_only_free+=nwords;
 102     } else {
 103         if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) {
 104             lose("Ran out of static space while purifying!\n");
 105         }
 106         ret=static_free;
 107         static_free+=nwords;
 108     }
 109     return ret;
 110 }
 111
 112 \f
 113 static void
 114 pscav_later(lispobj *where, long count)
 115 {
 116     struct later *new;
 117
 118     if (count > LATERMAXCOUNT) {
 119         while (count > LATERMAXCOUNT) {
 120             pscav_later(where, LATERMAXCOUNT);
 121             count -= LATERMAXCOUNT;
 122             where += LATERMAXCOUNT;
 123         }
 124     }
 125     else {
 126         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
 127             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
 128             new  = (struct later *)malloc(sizeof(struct later));
 129             new->next = later_blocks;
 130             if (later_blocks && later_count < LATERBLOCKSIZE)
 131                 later_blocks->u[later_count].ptr = NULL;
 132             later_blocks = new;
 133             later_count = 0;
 134         }
 135
 136         if (count != 1)
 137             later_blocks->u[later_count++].count = count;
 138         later_blocks->u[later_count++].ptr = where;
 139     }
 140 }
 141
 142 static lispobj
 143 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 144 {
 145     /* Allocate it */
 146     lispobj *old = native_pointer(thing);
 147     long nwords = sizetab[widetag_of(header)](old);
 148     lispobj *new = newspace_alloc(nwords,constant);
 149
 150     /* Copy it. */
 151     bcopy(old, new, nwords * sizeof(lispobj));
 152
 153     /* Deposit forwarding pointer. */
 154     lispobj result = make_lispobj(new, lowtag_of(thing));
 155     *old = result;
 156
 157     /* Scavenge it. */
 158     pscav(new, nwords, constant);
 159
 160     return result;
 161 }
 162
 163 /* We need to look at the layout to see whether it is a pure structure
 164  * class, and only then can we transport as constant. If it is pure,
 165  * we can ALWAYS transport as a constant. */
 166 static lispobj
 167 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
 168 {
 169     struct layout *layout =
 170       (struct layout *) native_pointer(((struct instance *)native_pointer(thing))->slots[0]);
 171     lispobj pure = 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 = (struct vector *)native_pointer(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_HEADER_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_HEADER_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     switch (widetag_of(header)) {
 392         /* FIXME: this needs a reindent */
 393       case BIGNUM_WIDETAG:
 394       case SINGLE_FLOAT_WIDETAG:
 395       case DOUBLE_FLOAT_WIDETAG:
 396 #ifdef LONG_FLOAT_WIDETAG
 397       case LONG_FLOAT_WIDETAG:
 398 #endif
 399 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 400       case COMPLEX_SINGLE_FLOAT_WIDETAG:
 401 #endif
 402 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 403       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 404 #endif
 405 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 406       case COMPLEX_LONG_FLOAT_WIDETAG:
 407 #endif
 408       case SAP_WIDETAG:
 409           return ptrans_unboxed(thing, header);
 410       case RATIO_WIDETAG:
 411       case COMPLEX_WIDETAG:
 412       case SIMPLE_ARRAY_WIDETAG:
 413       case COMPLEX_BASE_STRING_WIDETAG:
 414 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 415     case COMPLEX_CHARACTER_STRING_WIDETAG:
 416 #endif
 417       case COMPLEX_BIT_VECTOR_WIDETAG:
 418       case COMPLEX_VECTOR_NIL_WIDETAG:
 419       case COMPLEX_VECTOR_WIDETAG:
 420       case COMPLEX_ARRAY_WIDETAG:
 421         return ptrans_boxed(thing, header, constant);
 422
 423       case VALUE_CELL_HEADER_WIDETAG:
 424       case WEAK_POINTER_WIDETAG:
 425         return ptrans_boxed(thing, header, 0);
 426
 427       case SYMBOL_HEADER_WIDETAG:
 428         return ptrans_boxed(thing, header, 0);
 429
 430 #include "genesis/specialized-vectors.inc"
 431         return ptrans_vector(thing, 0, constant);
 432
 433       case SIMPLE_VECTOR_WIDETAG:
 434         return ptrans_vector(thing, 1, constant);
 435
 436       case CODE_HEADER_WIDETAG:
 437         return ptrans_code(thing);
 438
 439       case RETURN_PC_HEADER_WIDETAG:
 440         return ptrans_returnpc(thing, header);
 441
 442       case FDEFN_WIDETAG:
 443         return ptrans_fdefn(thing, header);
 444
 445       default:
 446         fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
 447         /* Should only come across other pointers to the above stuff. */
 448         gc_abort();
 449         return NIL;
 450     }
 451 }
 452
 453 static long
 454 pscav_fdefn(struct fdefn *fdefn)
 455 {
 456     boolean fix_func;
 457
 458     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
 459     pscav(&fdefn->name, 1, 1);
 460     pscav(&fdefn->fun, 1, 0);
 461     if (fix_func)
 462         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 463     return sizeof(struct fdefn) / sizeof(lispobj);
 464 }
 465
 466 static lispobj *
 467 pscav(lispobj *addr, long nwords, boolean constant)
 468 {
 469     lispobj thing, *thingp, header;
 470     long count = 0; /* (0 = dummy init value to stop GCC warning) */
 471
 472     while (nwords > 0) {
 473         thing = *addr;
 474         if (is_lisp_pointer(thing)) {
 475             /* It's a pointer. Is it something we might have to move? */
 476             if (dynamic_pointer_p(thing)) {
 477                 /* Maybe. Have we already moved it? */
 478                 thingp = native_pointer(thing);
 479                 header = *thingp;
 480                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
 481                     /* Yep, so just copy the forwarding pointer. */
 482                     thing = header;
 483                 else {
 484                     /* Nope, copy the object. */
 485                     switch (lowtag_of(thing)) {
 486                       case FUN_POINTER_LOWTAG:
 487                         thing = ptrans_func(thing, header);
 488                         break;
 489
 490                       case LIST_POINTER_LOWTAG:
 491                         thing = ptrans_list(thing, constant);
 492                         break;
 493
 494                       case INSTANCE_POINTER_LOWTAG:
 495                         thing = ptrans_instance(thing, header, constant);
 496                         break;
 497
 498                       case OTHER_POINTER_LOWTAG:
 499                         thing = ptrans_otherptr(thing, header, constant);
 500                         break;
 501
 502                       default:
 503                         /* It was a pointer, but not one of them? */
 504                         gc_abort();
 505                     }
 506                 }
 507                 *addr = thing;
 508             }
 509             count = 1;
 510         }
 511 #if N_WORD_BITS == 64
 512         else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) {
 513             count = 1;
 514         }
 515 #endif
 516         else if (thing & FIXNUM_TAG_MASK) {
 517             /* It's an other immediate. Maybe the header for an unboxed */
 518             /* object. */
 519             switch (widetag_of(thing)) {
 520               case BIGNUM_WIDETAG:
 521               case SINGLE_FLOAT_WIDETAG:
 522               case DOUBLE_FLOAT_WIDETAG:
 523 #ifdef LONG_FLOAT_WIDETAG
 524               case LONG_FLOAT_WIDETAG:
 525 #endif
 526               case SAP_WIDETAG:
 527                 /* It's an unboxed simple object. */
 528                 count = CEILING(HeaderValue(thing)+1, 2);
 529                 break;
 530
 531               case SIMPLE_VECTOR_WIDETAG:
 532                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
 533                     struct hash_table *hash_table =
 534                         (struct hash_table *)native_pointer(addr[2]);
 535                     hash_table->needs_rehash_p = T;
 536                   }
 537                 count = 2;
 538                 break;
 539
 540 #include "genesis/specialized-vectors.inc"
 541                 count = sizetab[widetag_of(thing)](addr);
 542                 break;
 543
 544               case CODE_HEADER_WIDETAG:
 545                 gc_abort(); /* no code headers in static space */
 546                 break;
 547
 548               case SIMPLE_FUN_HEADER_WIDETAG:
 549               case RETURN_PC_HEADER_WIDETAG:
 550                 /* We should never hit any of these, 'cause they occur
 551                  * buried in the middle of code objects. */
 552                 gc_abort();
 553                 break;
 554
 555               case WEAK_POINTER_WIDETAG:
 556                 /* Weak pointers get preserved during purify, 'cause I
 557                  * don't feel like figuring out how to break them. */
 558                 pscav(addr+1, 2, constant);
 559                 count = WEAK_POINTER_NWORDS;
 560                 break;
 561
 562               case FDEFN_WIDETAG:
 563                 /* We have to handle fdefn objects specially, so we
 564                  * can fix up the raw function address. */
 565                 count = pscav_fdefn((struct fdefn *)addr);
 566                 break;
 567
 568               case INSTANCE_HEADER_WIDETAG:
 569                 {
 570                     struct layout *layout
 571                         = (struct layout *)native_pointer(instance_layout(addr));
 572                     lispobj* slots = addr + 1;
 573                     long nslots = instance_length(*addr) | 1;
 574                     int index;
 575                     if (fixnump(layout->bitmap)) {
 576                       sword_t bitmap = (sword_t)layout->bitmap >> N_FIXNUM_TAG_BITS;
 577                       for (index = 0; index < nslots ; index++, bitmap >>= 1)
 578                         if (bitmap & 1)
 579                           pscav(slots + index, 1, constant);
 580                     } else {
 581                       struct bignum * bitmap;
 582                       bitmap = (struct bignum*)native_pointer(layout->bitmap);
 583                       for (index = 0; index < nslots ; index++)
 584                         if (positive_bignum_logbitp(index, bitmap))
 585                           pscav(slots + index, 1, constant);
 586                     }
 587                     count = 1 + nslots;
 588                 }
 589                 break;
 590
 591               default:
 592                 count = 1;
 593                 break;
 594             }
 595         }
 596         else {
 597             /* It's a fixnum. */
 598             count = 1;
 599         }
 600
 601         addr += count;
 602         nwords -= count;
 603     }
 604
 605     return addr;
 606 }
 607
 608 int
 609 purify(lispobj static_roots, lispobj read_only_roots)
 610 {
 611     lispobj *clean;
 612     long count, i;
 613     struct later *laters, *next;
 614     struct thread *thread;
 615
 616     if(all_threads->next) {
 617         /* FIXME: there should be _some_ sensible error reporting
 618          * convention.  See following comment too */
 619         fprintf(stderr,"Can't purify when more than one thread exists\n");
 620         fflush(stderr);
 621         return 0;
 622     }
 623
 624 #ifdef PRINTNOISE
 625     printf("[doing purification:");
 626     fflush(stdout);
 627 #endif
 628
 629     for_each_thread(thread)
 630         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
 631         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
 632          * its error simply by a. printing a string b. to stdout instead
 633          * of stderr. */
 634         printf(" Ack! Can't purify interrupt contexts. ");
 635         fflush(stdout);
 636         return 0;
 637     }
 638
 639     dynamic_space_purify_pointer = dynamic_space_free_pointer;
 640
 641     read_only_end = read_only_free =
 642         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
 643     static_end = static_free =
 644         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
 645
 646 #ifdef PRINTNOISE
 647     printf(" roots");
 648     fflush(stdout);
 649 #endif
 650
 651     pscav(&static_roots, 1, 0);
 652     pscav(&read_only_roots, 1, 1);
 653
 654 #ifdef PRINTNOISE
 655     printf(" handlers");
 656     fflush(stdout);
 657 #endif
 658     pscav((lispobj *) interrupt_handlers,
 659           sizeof(interrupt_handlers) / sizeof(lispobj),
 660           0);
 661
 662 #ifdef PRINTNOISE
 663     printf(" stack");
 664     fflush(stdout);
 665 #endif
 666     pscav((lispobj *)all_threads->control_stack_start,
 667           access_control_stack_pointer(all_threads) -
 668           all_threads->control_stack_start,
 669           0);
 670
 671 #ifdef PRINTNOISE
 672     printf(" bindings");
 673     fflush(stdout);
 674 #endif
 675
 676     pscav( (lispobj *)all_threads->binding_stack_start,
 677            (lispobj *)get_binding_stack_pointer(all_threads) -
 678            all_threads->binding_stack_start,
 679           0);
 680
 681     /* The original CMU CL code had scavenge-read-only-space code
 682      * controlled by the Lisp-level variable
 683      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
 684      * wasn't documented under what circumstances it was useful or
 685      * safe to turn it on, so it's been turned off in SBCL. If you
 686      * want/need this functionality, and can test and document it,
 687      * please submit a patch. */
 688 #if 0
 689     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
 690         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
 691       unsigned  read_only_space_size =
 692           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
 693           (lispobj *)READ_ONLY_SPACE_START;
 694       fprintf(stderr,
 695               "scavenging read only space: %d bytes\n",
 696               read_only_space_size * sizeof(lispobj));
 697       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
 698     }
 699 #endif
 700
 701 #ifdef PRINTNOISE
 702     printf(" static");
 703     fflush(stdout);
 704 #endif
 705     clean = (lispobj *)STATIC_SPACE_START;
 706     do {
 707         while (clean != static_free)
 708             clean = pscav(clean, static_free - clean, 0);
 709         laters = later_blocks;
 710         count = later_count;
 711         later_blocks = NULL;
 712         later_count = 0;
 713         while (laters != NULL) {
 714             for (i = 0; i < count; i++) {
 715                 if (laters->u[i].count == 0) {
 716                     ;
 717                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
 718                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
 719                     i++;
 720                 } else {
 721                     pscav(laters->u[i].ptr, 1, 1);
 722                 }
 723             }
 724             next = laters->next;
 725             free(laters);
 726             laters = next;
 727             count = LATERBLOCKSIZE;
 728         }
 729     } while (clean != static_free || later_blocks != NULL);
 730
 731 #ifdef PRINTNOISE
 732     printf(" cleanup");
 733     fflush(stdout);
 734 #endif
 735 #ifdef LISP_FEATURE_HPUX
 736     clear_auto_gc_trigger(); /* restore mmap as it was given by os */
 737 #endif
 738
 739     os_zero((os_vm_address_t) current_dynamic_space, dynamic_space_size);
 740
 741     /* Zero the stack. */
 742     os_zero((os_vm_address_t) access_control_stack_pointer(all_threads),
 743             (os_vm_size_t)
 744             ((all_threads->control_stack_end -
 745               access_control_stack_pointer(all_threads)) * sizeof(lispobj)));
 746
 747     /* It helps to update the heap free pointers so that free_heap can
 748      * verify after it's done. */
 749     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
 750     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
 751
 752     dynamic_space_free_pointer = current_dynamic_space;
 753     set_auto_gc_trigger(bytes_consed_between_gcs);
 754
 755     /* Blast away instruction cache */
 756     os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
 757     os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
 758
 759 #ifdef PRINTNOISE
 760     printf(" done]\n");
 761     fflush(stdout);
 762 #endif
 763     return 0;
 764 }
 765 #else /* LISP_FEATURE_GENCGC */
 766 int
 767 purify(lispobj static_roots, lispobj read_only_roots)
 768 {
 769     lose("purify called for GENCGC. This should not happen.");
 770 }
 771 #endif /* LISP_FEATURE_GENCGC */