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