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 #if N_WORD_BITS == 32
  74  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
  75 #elif N_WORD_BITS == 64
  76  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
  77 #endif
  78
  79 \f
  80 static boolean
  81 forwarding_pointer_p(lispobj obj)
  82 {
  83     lispobj *ptr = native_pointer(obj);
  84
  85     return ((static_end <= ptr && ptr <= static_free) ||
  86             (read_only_end <= ptr && ptr <= read_only_free));
  87 }
  88
  89 static boolean
  90 dynamic_pointer_p(lispobj ptr)
  91 {
  92     return (ptr >= (lispobj)current_dynamic_space
  93             &&
  94             ptr < (lispobj)dynamic_space_purify_pointer);
  95 }
  96
  97 static inline lispobj *
  98 newspace_alloc(long nwords, int constantp)
  99 {
 100     lispobj *ret;
 101     nwords=CEILING(nwords,2);
 102     if(constantp) {
 103         if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) {
 104             lose("Ran out of read-only space while purifying!\n");
 105         }
 106         ret=read_only_free;
 107         read_only_free+=nwords;
 108     } else {
 109         if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) {
 110             lose("Ran out of static space while purifying!\n");
 111         }
 112         ret=static_free;
 113         static_free+=nwords;
 114     }
 115     return ret;
 116 }
 117
 118 \f
 119 static void
 120 pscav_later(lispobj *where, long count)
 121 {
 122     struct later *new;
 123
 124     if (count > LATERMAXCOUNT) {
 125         while (count > LATERMAXCOUNT) {
 126             pscav_later(where, LATERMAXCOUNT);
 127             count -= LATERMAXCOUNT;
 128             where += LATERMAXCOUNT;
 129         }
 130     }
 131     else {
 132         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
 133             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
 134             new  = (struct later *)malloc(sizeof(struct later));
 135             new->next = later_blocks;
 136             if (later_blocks && later_count < LATERBLOCKSIZE)
 137                 later_blocks->u[later_count].ptr = NULL;
 138             later_blocks = new;
 139             later_count = 0;
 140         }
 141
 142         if (count != 1)
 143             later_blocks->u[later_count++].count = count;
 144         later_blocks->u[later_count++].ptr = where;
 145     }
 146 }
 147
 148 static lispobj
 149 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 150 {
 151     long nwords;
 152     lispobj result, *new, *old;
 153
 154     nwords = CEILING(1 + HeaderValue(header), 2);
 155
 156     /* Allocate it */
 157     old = (lispobj *)native_pointer(thing);
 158     new = newspace_alloc(nwords,constant);
 159
 160     /* Copy it. */
 161     bcopy(old, new, nwords * sizeof(lispobj));
 162
 163     /* Deposit forwarding pointer. */
 164     result = make_lispobj(new, lowtag_of(thing));
 165     *old = result;
 166
 167     /* Scavenge it. */
 168     pscav(new, nwords, constant);
 169
 170     return result;
 171 }
 172
 173 /* We need to look at the layout to see whether it is a pure structure
 174  * class, and only then can we transport as constant. If it is pure,
 175  * we can ALWAYS transport as a constant. */
 176 static lispobj
 177 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
 178 {
 179     struct layout *layout =
 180       (struct layout *) native_pointer(((struct instance *)native_pointer(thing))->slots[0]);
 181     lispobj pure = layout->pure;
 182
 183     switch (pure) {
 184     case T:
 185         return (ptrans_boxed(thing, header, 1));
 186     case NIL:
 187         return (ptrans_boxed(thing, header, 0));
 188     default:
 189         gc_abort();
 190         return NIL; /* dummy value: return something ... */
 191     }
 192 }
 193
 194 static lispobj
 195 ptrans_fdefn(lispobj thing, lispobj header)
 196 {
 197     long nwords;
 198     lispobj result, *new, *old, oldfn;
 199     struct fdefn *fdefn;
 200
 201     nwords = CEILING(1 + HeaderValue(header), 2);
 202
 203     /* Allocate it */
 204     old = (lispobj *)native_pointer(thing);
 205     new = newspace_alloc(nwords, 0);    /* inconstant */
 206
 207     /* Copy it. */
 208     bcopy(old, new, nwords * sizeof(lispobj));
 209
 210     /* Deposit forwarding pointer. */
 211     result = make_lispobj(new, lowtag_of(thing));
 212     *old = result;
 213
 214     /* Scavenge the function. */
 215     fdefn = (struct fdefn *)new;
 216     oldfn = fdefn->fun;
 217     pscav(&fdefn->fun, 1, 0);
 218     if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
 219         fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
 220
 221     return result;
 222 }
 223
 224 static lispobj
 225 ptrans_unboxed(lispobj thing, lispobj header)
 226 {
 227     long nwords;
 228     lispobj result, *new, *old;
 229
 230     nwords = CEILING(1 + HeaderValue(header), 2);
 231
 232     /* Allocate it */
 233     old = (lispobj *)native_pointer(thing);
 234     new = newspace_alloc(nwords,1);     /* always constant */
 235
 236     /* copy it. */
 237     bcopy(old, new, nwords * sizeof(lispobj));
 238
 239     /* Deposit forwarding pointer. */
 240     result = make_lispobj(new , lowtag_of(thing));
 241     *old = result;
 242
 243     return result;
 244 }
 245
 246 static lispobj
 247 ptrans_vector(lispobj thing, long bits, long extra,
 248               boolean boxed, boolean constant)
 249 {
 250     struct vector *vector;
 251     long nwords;
 252     lispobj result, *new;
 253     long length;
 254
 255     vector = (struct vector *)native_pointer(thing);
 256     length = fixnum_value(vector->length)+extra;
 257     // Argh, handle simple-vector-nil separately.
 258     if (bits == 0) {
 259       nwords = 2;
 260     } else {
 261       nwords = CEILING(NWORDS(length, bits) + 2, 2);
 262     }
 263
 264     new=newspace_alloc(nwords, (constant || !boxed));
 265     bcopy(vector, new, nwords * sizeof(lispobj));
 266
 267     result = make_lispobj(new, lowtag_of(thing));
 268     vector->header = result;
 269
 270     if (boxed)
 271         pscav(new, nwords, constant);
 272
 273     return result;
 274 }
 275
 276 static lispobj
 277 ptrans_code(lispobj thing)
 278 {
 279     struct code *code, *new;
 280     long nwords;
 281     lispobj func, result;
 282
 283     code = (struct code *)native_pointer(thing);
 284     nwords = CEILING(HeaderValue(code->header) + fixnum_word_value(code->code_size),
 285                      2);
 286
 287     new = (struct code *)newspace_alloc(nwords,1); /* constant */
 288
 289     bcopy(code, new, nwords * sizeof(lispobj));
 290
 291     result = make_lispobj(new, OTHER_POINTER_LOWTAG);
 292
 293     /* Stick in a forwarding pointer for the code object. */
 294     *(lispobj *)code = result;
 295
 296     /* Put in forwarding pointers for all the functions. */
 297     for (func = code->entry_points;
 298          func != NIL;
 299          func = ((struct simple_fun *)native_pointer(func))->next) {
 300
 301         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
 302
 303         *(lispobj *)native_pointer(func) = result + (func - thing);
 304     }
 305
 306     /* Arrange to scavenge the debug info later. */
 307     pscav_later(&new->debug_info, 1);
 308
 309     /* Scavenge the constants. */
 310     pscav(new->constants,
 311           HeaderValue(new->header) - (offsetof(struct code, constants) >> WORD_SHIFT),
 312           1);
 313
 314     /* Scavenge all the functions. */
 315     pscav(&new->entry_points, 1, 1);
 316     for (func = new->entry_points;
 317          func != NIL;
 318          func = ((struct simple_fun *)native_pointer(func))->next) {
 319         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
 320         gc_assert(!dynamic_pointer_p(func));
 321
 322         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
 323         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 4);
 324     }
 325
 326     return result;
 327 }
 328
 329 static lispobj
 330 ptrans_func(lispobj thing, lispobj header)
 331 {
 332     long nwords;
 333     lispobj code, *new, *old, result;
 334     struct simple_fun *function;
 335
 336     /* Thing can either be a function header, a closure function
 337      * header, a closure, or a funcallable-instance. If it's a closure
 338      * or a funcallable-instance, we do the same as ptrans_boxed.
 339      * Otherwise we have to do something strange, 'cause it is buried
 340      * inside a code object. */
 341
 342     if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
 343
 344         /* We can only end up here if the code object has not been
 345          * scavenged, because if it had been scavenged, forwarding pointers
 346          * would have been left behind for all the entry points. */
 347
 348         function = (struct simple_fun *)native_pointer(thing);
 349         code =
 350             make_lispobj
 351             ((native_pointer(thing) -
 352               (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
 353
 354         /* This will cause the function's header to be replaced with a
 355          * forwarding pointer. */
 356
 357         ptrans_code(code);
 358
 359         /* So we can just return that. */
 360         return function->header;
 361     }
 362     else {
 363         /* It's some kind of closure-like thing. */
 364         nwords = CEILING(1 + HeaderValue(header), 2);
 365         old = (lispobj *)native_pointer(thing);
 366
 367         /* Allocate the new one.  FINs *must* not go in read_only
 368          * space.  Closures can; they never change */
 369
 370         new = newspace_alloc
 371             (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG));
 372
 373         /* Copy it. */
 374         bcopy(old, new, nwords * sizeof(lispobj));
 375
 376         /* Deposit forwarding pointer. */
 377         result = make_lispobj(new, lowtag_of(thing));
 378         *old = result;
 379
 380         /* Scavenge it. */
 381         pscav(new, nwords, 0);
 382
 383         return result;
 384     }
 385 }
 386
 387 static lispobj
 388 ptrans_returnpc(lispobj thing, lispobj header)
 389 {
 390     lispobj code, new;
 391
 392     /* Find the corresponding code object. */
 393     code = thing - HeaderValue(header)*sizeof(lispobj);
 394
 395     /* Make sure it's been transported. */
 396     new = *(lispobj *)native_pointer(code);
 397     if (!forwarding_pointer_p(new))
 398         new = ptrans_code(code);
 399
 400     /* Maintain the offset: */
 401     return new + (thing - code);
 402 }
 403
 404 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
 405
 406 static lispobj
 407 ptrans_list(lispobj thing, boolean constant)
 408 {
 409     struct cons *old, *new, *orig;
 410     long length;
 411
 412     orig = (struct cons *) newspace_alloc(0,constant);
 413     length = 0;
 414
 415     do {
 416         /* Allocate a new cons cell. */
 417         old = (struct cons *)native_pointer(thing);
 418         new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
 419
 420         /* Copy the cons cell and keep a pointer to the cdr. */
 421         new->car = old->car;
 422         thing = new->cdr = old->cdr;
 423
 424         /* Set up the forwarding pointer. */
 425         *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
 426
 427         /* And count this cell. */
 428         length++;
 429     } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
 430              dynamic_pointer_p(thing) &&
 431              !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
 432
 433     /* Scavenge the list we just copied. */
 434     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
 435
 436     return make_lispobj(orig, LIST_POINTER_LOWTAG);
 437 }
 438
 439 static lispobj
 440 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 441 {
 442     switch (widetag_of(header)) {
 443         /* FIXME: this needs a reindent */
 444       case BIGNUM_WIDETAG:
 445       case SINGLE_FLOAT_WIDETAG:
 446       case DOUBLE_FLOAT_WIDETAG:
 447 #ifdef LONG_FLOAT_WIDETAG
 448       case LONG_FLOAT_WIDETAG:
 449 #endif
 450 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 451       case COMPLEX_SINGLE_FLOAT_WIDETAG:
 452 #endif
 453 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 454       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 455 #endif
 456 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 457       case COMPLEX_LONG_FLOAT_WIDETAG:
 458 #endif
 459       case SAP_WIDETAG:
 460           return ptrans_unboxed(thing, header);
 461       case RATIO_WIDETAG:
 462       case COMPLEX_WIDETAG:
 463       case SIMPLE_ARRAY_WIDETAG:
 464       case COMPLEX_BASE_STRING_WIDETAG:
 465 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 466     case COMPLEX_CHARACTER_STRING_WIDETAG:
 467 #endif
 468       case COMPLEX_BIT_VECTOR_WIDETAG:
 469       case COMPLEX_VECTOR_NIL_WIDETAG:
 470       case COMPLEX_VECTOR_WIDETAG:
 471       case COMPLEX_ARRAY_WIDETAG:
 472         return ptrans_boxed(thing, header, constant);
 473
 474       case VALUE_CELL_HEADER_WIDETAG:
 475       case WEAK_POINTER_WIDETAG:
 476         return ptrans_boxed(thing, header, 0);
 477
 478       case SYMBOL_HEADER_WIDETAG:
 479         return ptrans_boxed(thing, header, 0);
 480
 481       case SIMPLE_ARRAY_NIL_WIDETAG:
 482         return ptrans_vector(thing, 0, 0, 0, constant);
 483
 484       case SIMPLE_BASE_STRING_WIDETAG:
 485         return ptrans_vector(thing, 8, 1, 0, constant);
 486
 487 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
 488     case SIMPLE_CHARACTER_STRING_WIDETAG:
 489         return ptrans_vector(thing, 32, 1, 0, constant);
 490 #endif
 491
 492       case SIMPLE_BIT_VECTOR_WIDETAG:
 493         return ptrans_vector(thing, 1, 0, 0, constant);
 494
 495       case SIMPLE_VECTOR_WIDETAG:
 496         return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant);
 497
 498       case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
 499         return ptrans_vector(thing, 2, 0, 0, constant);
 500
 501       case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
 502         return ptrans_vector(thing, 4, 0, 0, constant);
 503
 504       case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 505 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
 506       case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
 507       case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 508 #endif
 509         return ptrans_vector(thing, 8, 0, 0, constant);
 510
 511       case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 512 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
 513       case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
 514       case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 515 #endif
 516         return ptrans_vector(thing, 16, 0, 0, constant);
 517
 518       case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 519       case SIMPLE_ARRAY_FIXNUM_WIDETAG:
 520       case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
 521 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
 522       case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
 523       case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 524 #endif
 525         return ptrans_vector(thing, 32, 0, 0, constant);
 526
 527 #if N_WORD_BITS == 64
 528 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
 529       case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
 530 #endif
 531 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
 532       case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
 533 #endif
 534 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
 535       case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
 536 #endif
 537         return ptrans_vector(thing, 64, 0, 0, constant);
 538 #endif
 539
 540       case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
 541         return ptrans_vector(thing, 32, 0, 0, constant);
 542
 543       case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
 544         return ptrans_vector(thing, 64, 0, 0, constant);
 545
 546 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
 547       case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
 548 #ifdef LISP_FEATURE_SPARC
 549         return ptrans_vector(thing, 128, 0, 0, constant);
 550 #endif
 551 #endif
 552
 553 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
 554       case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
 555         return ptrans_vector(thing, 64, 0, 0, constant);
 556 #endif
 557
 558 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
 559       case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
 560         return ptrans_vector(thing, 128, 0, 0, constant);
 561 #endif
 562
 563 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
 564       case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
 565 #ifdef LISP_FEATURE_SPARC
 566         return ptrans_vector(thing, 256, 0, 0, constant);
 567 #endif
 568 #endif
 569
 570       case CODE_HEADER_WIDETAG:
 571         return ptrans_code(thing);
 572
 573       case RETURN_PC_HEADER_WIDETAG:
 574         return ptrans_returnpc(thing, header);
 575
 576       case FDEFN_WIDETAG:
 577         return ptrans_fdefn(thing, header);
 578
 579       default:
 580         fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
 581         /* Should only come across other pointers to the above stuff. */
 582         gc_abort();
 583         return NIL;
 584     }
 585 }
 586
 587 static long
 588 pscav_fdefn(struct fdefn *fdefn)
 589 {
 590     boolean fix_func;
 591
 592     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
 593     pscav(&fdefn->name, 1, 1);
 594     pscav(&fdefn->fun, 1, 0);
 595     if (fix_func)
 596         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 597     return sizeof(struct fdefn) / sizeof(lispobj);
 598 }
 599
 600 static lispobj *
 601 pscav(lispobj *addr, long nwords, boolean constant)
 602 {
 603     lispobj thing, *thingp, header;
 604     long count = 0; /* (0 = dummy init value to stop GCC warning) */
 605     struct vector *vector;
 606
 607     while (nwords > 0) {
 608         thing = *addr;
 609         if (is_lisp_pointer(thing)) {
 610             /* It's a pointer. Is it something we might have to move? */
 611             if (dynamic_pointer_p(thing)) {
 612                 /* Maybe. Have we already moved it? */
 613                 thingp = (lispobj *)native_pointer(thing);
 614                 header = *thingp;
 615                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
 616                     /* Yep, so just copy the forwarding pointer. */
 617                     thing = header;
 618                 else {
 619                     /* Nope, copy the object. */
 620                     switch (lowtag_of(thing)) {
 621                       case FUN_POINTER_LOWTAG:
 622                         thing = ptrans_func(thing, header);
 623                         break;
 624
 625                       case LIST_POINTER_LOWTAG:
 626                         thing = ptrans_list(thing, constant);
 627                         break;
 628
 629                       case INSTANCE_POINTER_LOWTAG:
 630                         thing = ptrans_instance(thing, header, constant);
 631                         break;
 632
 633                       case OTHER_POINTER_LOWTAG:
 634                         thing = ptrans_otherptr(thing, header, constant);
 635                         break;
 636
 637                       default:
 638                         /* It was a pointer, but not one of them? */
 639                         gc_abort();
 640                     }
 641                 }
 642                 *addr = thing;
 643             }
 644             count = 1;
 645         }
 646 #if N_WORD_BITS == 64
 647         else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) {
 648             count = 1;
 649         }
 650 #endif
 651         else if (thing & FIXNUM_TAG_MASK) {
 652             /* It's an other immediate. Maybe the header for an unboxed */
 653             /* object. */
 654             switch (widetag_of(thing)) {
 655               case BIGNUM_WIDETAG:
 656               case SINGLE_FLOAT_WIDETAG:
 657               case DOUBLE_FLOAT_WIDETAG:
 658 #ifdef LONG_FLOAT_WIDETAG
 659               case LONG_FLOAT_WIDETAG:
 660 #endif
 661               case SAP_WIDETAG:
 662                 /* It's an unboxed simple object. */
 663                 count = CEILING(HeaderValue(thing)+1, 2);
 664                 break;
 665
 666               case SIMPLE_VECTOR_WIDETAG:
 667                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
 668                     struct hash_table *hash_table =
 669                         (struct hash_table *)native_pointer(addr[2]);
 670                     hash_table->needs_rehash_p = T;
 671                   }
 672                 count = 2;
 673                 break;
 674
 675               case SIMPLE_ARRAY_NIL_WIDETAG:
 676                 count = 2;
 677                 break;
 678
 679               case SIMPLE_BASE_STRING_WIDETAG:
 680                 vector = (struct vector *)addr;
 681                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,8)+2,2);
 682                 break;
 683
 684 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
 685             case SIMPLE_CHARACTER_STRING_WIDETAG:
 686                 vector = (struct vector *)addr;
 687                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,32)+2,2);
 688                 break;
 689 #endif
 690
 691               case SIMPLE_BIT_VECTOR_WIDETAG:
 692                 vector = (struct vector *)addr;
 693                 count = CEILING(NWORDS(fixnum_value(vector->length),1)+2,2);
 694                 break;
 695
 696               case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
 697                 vector = (struct vector *)addr;
 698                 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
 699                 break;
 700
 701               case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
 702                 vector = (struct vector *)addr;
 703                 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
 704                 break;
 705
 706               case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 707 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
 708               case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
 709               case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 710 #endif
 711                 vector = (struct vector *)addr;
 712                 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
 713                 break;
 714
 715               case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 716 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
 717               case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
 718               case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 719 #endif
 720                 vector = (struct vector *)addr;
 721                 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
 722                 break;
 723
 724               case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 725
 726               case SIMPLE_ARRAY_FIXNUM_WIDETAG:
 727               case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
 728
 729 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
 730               case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
 731               case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 732 #endif
 733                 vector = (struct vector *)addr;
 734                 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
 735                 break;
 736
 737 #if N_WORD_BITS == 64
 738               case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
 739 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
 740               case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
 741               case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
 742 #endif
 743                 vector = (struct vector *)addr;
 744                 count = CEILING(NWORDS(fixnum_value(vector->length),64)+2,2);
 745                 break;
 746 #endif
 747
 748               case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
 749                 vector = (struct vector *)addr;
 750                 count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2,
 751                                 2);
 752                 break;
 753
 754               case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
 755 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
 756               case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
 757 #endif
 758                 vector = (struct vector *)addr;
 759                 count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2,
 760                                 2);
 761                 break;
 762
 763 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
 764               case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
 765                 vector = (struct vector *)addr;
 766 #ifdef LISP_FEATURE_SPARC
 767                 count = fixnum_value(vector->length)*4+2;
 768 #endif
 769                 break;
 770 #endif
 771
 772 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
 773               case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
 774                 vector = (struct vector *)addr;
 775                 count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2,
 776                                 2);
 777                 break;
 778 #endif
 779
 780 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
 781               case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
 782                 vector = (struct vector *)addr;
 783 #ifdef LISP_FEATURE_SPARC
 784                 count = fixnum_value(vector->length)*8+2;
 785 #endif
 786                 break;
 787 #endif
 788
 789               case CODE_HEADER_WIDETAG:
 790                 gc_abort(); /* no code headers in static space */
 791                 break;
 792
 793               case SIMPLE_FUN_HEADER_WIDETAG:
 794               case RETURN_PC_HEADER_WIDETAG:
 795                 /* We should never hit any of these, 'cause they occur
 796                  * buried in the middle of code objects. */
 797                 gc_abort();
 798                 break;
 799
 800               case WEAK_POINTER_WIDETAG:
 801                 /* Weak pointers get preserved during purify, 'cause I
 802                  * don't feel like figuring out how to break them. */
 803                 pscav(addr+1, 2, constant);
 804                 count = 4;
 805                 break;
 806
 807               case FDEFN_WIDETAG:
 808                 /* We have to handle fdefn objects specially, so we
 809                  * can fix up the raw function address. */
 810                 count = pscav_fdefn((struct fdefn *)addr);
 811                 break;
 812
 813               case INSTANCE_HEADER_WIDETAG:
 814                 {
 815                     struct instance *instance = (struct instance *) addr;
 816                     struct layout *layout
 817                         = (struct layout *) native_pointer(instance->slots[0]);
 818                     long nuntagged = fixnum_value(layout->n_untagged_slots);
 819                     long nslots = HeaderValue(*addr);
 820                     pscav(addr + 1, nslots - nuntagged, constant);
 821                     count = CEILING(1 + nslots, 2);
 822                 }
 823                 break;
 824
 825               default:
 826                 count = 1;
 827                 break;
 828             }
 829         }
 830         else {
 831             /* It's a fixnum. */
 832             count = 1;
 833         }
 834
 835         addr += count;
 836         nwords -= count;
 837     }
 838
 839     return addr;
 840 }
 841
 842 int
 843 purify(lispobj static_roots, lispobj read_only_roots)
 844 {
 845     lispobj *clean;
 846     long count, i;
 847     struct later *laters, *next;
 848     struct thread *thread;
 849
 850     if(all_threads->next) {
 851         /* FIXME: there should be _some_ sensible error reporting
 852          * convention.  See following comment too */
 853         fprintf(stderr,"Can't purify when more than one thread exists\n");
 854         fflush(stderr);
 855         return 0;
 856     }
 857
 858 #ifdef PRINTNOISE
 859     printf("[doing purification:");
 860     fflush(stdout);
 861 #endif
 862
 863     for_each_thread(thread)
 864         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
 865         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
 866          * its error simply by a. printing a string b. to stdout instead
 867          * of stderr. */
 868         printf(" Ack! Can't purify interrupt contexts. ");
 869         fflush(stdout);
 870         return 0;
 871     }
 872
 873     dynamic_space_purify_pointer = dynamic_space_free_pointer;
 874
 875     read_only_end = read_only_free =
 876         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
 877     static_end = static_free =
 878         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
 879
 880 #ifdef PRINTNOISE
 881     printf(" roots");
 882     fflush(stdout);
 883 #endif
 884
 885     pscav(&static_roots, 1, 0);
 886     pscav(&read_only_roots, 1, 1);
 887
 888 #ifdef PRINTNOISE
 889     printf(" handlers");
 890     fflush(stdout);
 891 #endif
 892     pscav((lispobj *) interrupt_handlers,
 893           sizeof(interrupt_handlers) / sizeof(lispobj),
 894           0);
 895
 896 #ifdef PRINTNOISE
 897     printf(" stack");
 898     fflush(stdout);
 899 #endif
 900     pscav((lispobj *)all_threads->control_stack_start,
 901           access_control_stack_pointer(all_threads) -
 902           all_threads->control_stack_start,
 903           0);
 904
 905 #ifdef PRINTNOISE
 906     printf(" bindings");
 907     fflush(stdout);
 908 #endif
 909
 910     pscav( (lispobj *)all_threads->binding_stack_start,
 911            (lispobj *)get_binding_stack_pointer(all_threads) -
 912            all_threads->binding_stack_start,
 913           0);
 914
 915     /* The original CMU CL code had scavenge-read-only-space code
 916      * controlled by the Lisp-level variable
 917      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
 918      * wasn't documented under what circumstances it was useful or
 919      * safe to turn it on, so it's been turned off in SBCL. If you
 920      * want/need this functionality, and can test and document it,
 921      * please submit a patch. */
 922 #if 0
 923     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
 924         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
 925       unsigned  read_only_space_size =
 926           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
 927           (lispobj *)READ_ONLY_SPACE_START;
 928       fprintf(stderr,
 929               "scavenging read only space: %d bytes\n",
 930               read_only_space_size * sizeof(lispobj));
 931       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
 932     }
 933 #endif
 934
 935 #ifdef PRINTNOISE
 936     printf(" static");
 937     fflush(stdout);
 938 #endif
 939     clean = (lispobj *)STATIC_SPACE_START;
 940     do {
 941         while (clean != static_free)
 942             clean = pscav(clean, static_free - clean, 0);
 943         laters = later_blocks;
 944         count = later_count;
 945         later_blocks = NULL;
 946         later_count = 0;
 947         while (laters != NULL) {
 948             for (i = 0; i < count; i++) {
 949                 if (laters->u[i].count == 0) {
 950                     ;
 951                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
 952                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
 953                     i++;
 954                 } else {
 955                     pscav(laters->u[i].ptr, 1, 1);
 956                 }
 957             }
 958             next = laters->next;
 959             free(laters);
 960             laters = next;
 961             count = LATERBLOCKSIZE;
 962         }
 963     } while (clean != static_free || later_blocks != NULL);
 964
 965 #ifdef PRINTNOISE
 966     printf(" cleanup");
 967     fflush(stdout);
 968 #endif
 969 #ifdef LISP_FEATURE_HPUX
 970     clear_auto_gc_trigger(); /* restore mmap as it was given by os */
 971 #endif
 972
 973     os_zero((os_vm_address_t) current_dynamic_space, dynamic_space_size);
 974
 975     /* Zero the stack. */
 976     os_zero((os_vm_address_t) access_control_stack_pointer(all_threads),
 977             (os_vm_size_t)
 978             ((all_threads->control_stack_end -
 979               access_control_stack_pointer(all_threads)) * sizeof(lispobj)));
 980
 981     /* It helps to update the heap free pointers so that free_heap can
 982      * verify after it's done. */
 983     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
 984     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
 985
 986     dynamic_space_free_pointer = current_dynamic_space;
 987     set_auto_gc_trigger(bytes_consed_between_gcs);
 988
 989     /* Blast away instruction cache */
 990     os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
 991     os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
 992
 993 #ifdef PRINTNOISE
 994     printf(" done]\n");
 995     fflush(stdout);
 996 #endif
 997     return 0;
 998 }
 999 #else /* LISP_FEATURE_GENCGC */
1000 int
1001 purify(lispobj static_roots, lispobj read_only_roots)
1002 {
1003     lose("purify called for GENCGC. This should not happen.");
1004 }
1005 #endif /* LISP_FEATURE_GENCGC */