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
  37 #define PRINTNOISE
  38
  39 #if defined(LISP_FEATURE_GENCGC)
  40 /* this is another artifact of the poor integration between gencgc and
  41  * the rest of the runtime: on cheney gc there is a global
  42  * dynamic_space_free_pointer which is valid whenever foreign function
  43  * call is active, but in gencgc there's no such variable and we have
  44  * to keep our own
  45  */
  46 static lispobj *dynamic_space_free_pointer;
  47 #endif
  48 extern unsigned long bytes_consed_between_gcs;
  49
  50 #define gc_abort() \
  51   lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
  52
  53 #if 1
  54 #define gc_assert(ex) do { \
  55         if (!(ex)) gc_abort(); \
  56 } while (0)
  57 #else
  58 #define gc_assert(ex)
  59 #endif
  60
  61 \f
  62 /* These hold the original end of the read_only and static spaces so
  63  * we can tell what are forwarding pointers. */
  64
  65 static lispobj *read_only_end, *static_end;
  66
  67 static lispobj *read_only_free, *static_free;
  68
  69 static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
  70
  71 #define LATERBLOCKSIZE 1020
  72 #define LATERMAXCOUNT 10
  73
  74 static struct
  75 later {
  76     struct later *next;
  77     union {
  78         lispobj *ptr;
  79         long count;
  80     } u[LATERBLOCKSIZE];
  81 } *later_blocks = NULL;
  82 static long later_count = 0;
  83
  84 #if N_WORD_BITS == 32
  85  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
  86 #elif N_WORD_BITS == 64
  87  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
  88 #endif
  89
  90 /* FIXME: Shouldn't this be defined in sbcl.h?  See also notes in
  91  * cheneygc.c */
  92
  93 #ifdef LISP_FEATURE_SPARC
  94 #define FUN_RAW_ADDR_OFFSET 0
  95 #else
  96 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
  97 #endif
  98 \f
  99 static boolean
 100 forwarding_pointer_p(lispobj obj)
 101 {
 102     lispobj *ptr = native_pointer(obj);
 103
 104     return ((static_end <= ptr && ptr <= static_free) ||
 105             (read_only_end <= ptr && ptr <= read_only_free));
 106 }
 107
 108 static boolean
 109 dynamic_pointer_p(lispobj ptr)
 110 {
 111 #ifndef LISP_FEATURE_GENCGC
 112     return (ptr >= (lispobj)current_dynamic_space
 113             &&
 114             ptr < (lispobj)dynamic_space_free_pointer);
 115 #else
 116     /* Be more conservative, and remember, this is a maybe. */
 117     return (ptr >= (lispobj)DYNAMIC_SPACE_START
 118             &&
 119             ptr < (lispobj)dynamic_space_free_pointer);
 120 #endif
 121 }
 122
 123 static inline lispobj *
 124 newspace_alloc(long nwords, int constantp)
 125 {
 126     lispobj *ret;
 127     nwords=CEILING(nwords,2);
 128     if(constantp) {
 129         ret=read_only_free;
 130         read_only_free+=nwords;
 131     } else {
 132         ret=static_free;
 133         static_free+=nwords;
 134     }
 135     return ret;
 136 }
 137
 138
 139 \f
 140 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 141
 142 #ifdef LISP_FEATURE_GENCGC
 143 /*
 144  * enhanced x86/GENCGC stack scavenging by Douglas Crosher
 145  *
 146  * Scavenging the stack on the i386 is problematic due to conservative
 147  * roots and raw return addresses. Here it is handled in two passes:
 148  * the first pass runs before any objects are moved and tries to
 149  * identify valid pointers and return address on the stack, the second
 150  * pass scavenges these.
 151  */
 152
 153 static unsigned pointer_filter_verbose = 0;
 154
 155 /* FIXME: This is substantially the same code as
 156  * possibly_valid_dynamic_space_pointer in gencgc.c.  The only
 157  * relevant difference seems to be that the gencgc code also checks
 158  * for raw pointers into Code objects, whereas in purify these are
 159  * checked separately in setup_i386_stack_scav - they go onto
 160  * valid_stack_ra_locations instead of just valid_stack_locations */
 161
 162 static int
 163 valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 164 {
 165     /* If it's not a return address then it needs to be a valid Lisp
 166      * pointer. */
 167     if (!is_lisp_pointer((lispobj)pointer))
 168         return 0;
 169
 170     /* Check that the object pointed to is consistent with the pointer
 171      * low tag. */
 172     switch (lowtag_of((lispobj)pointer)) {
 173     case FUN_POINTER_LOWTAG:
 174         /* Start_addr should be the enclosing code object, or a closure
 175          * header. */
 176         switch (widetag_of(*start_addr)) {
 177         case CODE_HEADER_WIDETAG:
 178             /* This case is probably caught above. */
 179             break;
 180         case CLOSURE_HEADER_WIDETAG:
 181         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
 182             if ((long)pointer != ((long)start_addr+FUN_POINTER_LOWTAG)) {
 183                 if (pointer_filter_verbose) {
 184                     fprintf(stderr,"*Wf2: %x %x %x\n",
 185                             (unsigned long) pointer,
 186                             (unsigned long) start_addr, *start_addr);
 187                 }
 188                 return 0;
 189             }
 190             break;
 191         default:
 192             if (pointer_filter_verbose) {
 193                 fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned long) pointer,
 194                         (unsigned long) start_addr, *start_addr);
 195             }
 196             return 0;
 197         }
 198         break;
 199     case LIST_POINTER_LOWTAG:
 200         if ((long)pointer != ((long)start_addr+LIST_POINTER_LOWTAG)) {
 201             if (pointer_filter_verbose)
 202                 fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned long) pointer,
 203                         (unsigned long) start_addr, *start_addr);
 204             return 0;
 205         }
 206         /* Is it plausible cons? */
 207         if ((is_lisp_pointer(start_addr[0])
 208             || ((start_addr[0] & FIXNUM_TAG_MASK) == 0) /* fixnum */
 209             || (widetag_of(start_addr[0]) == CHARACTER_WIDETAG)
 210 #if N_WORD_BITS == 64
 211             || (widetag_of(start_addr[0]) == SINGLE_FLOAT_WIDETAG)
 212 #endif
 213             || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
 214            && (is_lisp_pointer(start_addr[1])
 215                || ((start_addr[1] & FIXNUM_TAG_MASK) == 0) /* fixnum */
 216                || (widetag_of(start_addr[1]) == CHARACTER_WIDETAG)
 217 #if N_WORD_BITS == 64
 218                || (widetag_of(start_addr[1]) == SINGLE_FLOAT_WIDETAG)
 219 #endif
 220                || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG))) {
 221             break;
 222         } else {
 223             if (pointer_filter_verbose) {
 224                 fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned long) pointer,
 225                         (unsigned long) start_addr, *start_addr);
 226             }
 227             return 0;
 228         }
 229     case INSTANCE_POINTER_LOWTAG:
 230         if ((long)pointer != ((long)start_addr+INSTANCE_POINTER_LOWTAG)) {
 231             if (pointer_filter_verbose) {
 232                 fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned long) pointer,
 233                         (unsigned long) start_addr, *start_addr);
 234             }
 235             return 0;
 236         }
 237         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
 238             if (pointer_filter_verbose) {
 239                 fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned long) pointer,
 240                         (unsigned long) start_addr, *start_addr);
 241             }
 242             return 0;
 243         }
 244         break;
 245     case OTHER_POINTER_LOWTAG:
 246         if ((long)pointer != ((long)start_addr+OTHER_POINTER_LOWTAG)) {
 247             if (pointer_filter_verbose) {
 248                 fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned long) pointer,
 249                         (unsigned long) start_addr, *start_addr);
 250             }
 251             return 0;
 252         }
 253         /* Is it plausible? Not a cons. XXX should check the headers. */
 254         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & FIXNUM_TAG_MASK) == 0)) {
 255             if (pointer_filter_verbose) {
 256                 fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned long) pointer,
 257                         (unsigned long) start_addr, *start_addr);
 258             }
 259             return 0;
 260         }
 261         switch (widetag_of(start_addr[0])) {
 262         case UNBOUND_MARKER_WIDETAG:
 263         case CHARACTER_WIDETAG:
 264 #if N_WORD_BITS == 64
 265         case SINGLE_FLOAT_WIDETAG:
 266 #endif
 267             if (pointer_filter_verbose) {
 268                 fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned long) pointer,
 269                         (unsigned long) start_addr, *start_addr);
 270             }
 271             return 0;
 272
 273             /* only pointed to by function pointers? */
 274         case CLOSURE_HEADER_WIDETAG:
 275         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
 276             if (pointer_filter_verbose) {
 277                 fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned long) pointer,
 278                         (unsigned long) start_addr, *start_addr);
 279             }
 280             return 0;
 281
 282         case INSTANCE_HEADER_WIDETAG:
 283             if (pointer_filter_verbose) {
 284                 fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned long) pointer,
 285                         (unsigned long) start_addr, *start_addr);
 286             }
 287             return 0;
 288
 289             /* the valid other immediate pointer objects */
 290         case SIMPLE_VECTOR_WIDETAG:
 291         case RATIO_WIDETAG:
 292         case COMPLEX_WIDETAG:
 293 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 294         case COMPLEX_SINGLE_FLOAT_WIDETAG:
 295 #endif
 296 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 297         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 298 #endif
 299 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 300         case COMPLEX_LONG_FLOAT_WIDETAG:
 301 #endif
 302         case SIMPLE_ARRAY_WIDETAG:
 303         case COMPLEX_BASE_STRING_WIDETAG:
 304 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 305         case COMPLEX_CHARACTER_STRING_WIDETAG:
 306 #endif
 307         case COMPLEX_VECTOR_NIL_WIDETAG:
 308         case COMPLEX_BIT_VECTOR_WIDETAG:
 309         case COMPLEX_VECTOR_WIDETAG:
 310         case COMPLEX_ARRAY_WIDETAG:
 311         case VALUE_CELL_HEADER_WIDETAG:
 312         case SYMBOL_HEADER_WIDETAG:
 313         case FDEFN_WIDETAG:
 314         case CODE_HEADER_WIDETAG:
 315         case BIGNUM_WIDETAG:
 316 #if N_WORD_BITS != 64
 317         case SINGLE_FLOAT_WIDETAG:
 318 #endif
 319         case DOUBLE_FLOAT_WIDETAG:
 320 #ifdef LONG_FLOAT_WIDETAG
 321         case LONG_FLOAT_WIDETAG:
 322 #endif
 323         case SIMPLE_ARRAY_NIL_WIDETAG:
 324         case SIMPLE_BASE_STRING_WIDETAG:
 325 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
 326         case SIMPLE_CHARACTER_STRING_WIDETAG:
 327 #endif
 328         case SIMPLE_BIT_VECTOR_WIDETAG:
 329         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
 330         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
 331         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 332         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 333         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 334         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 335 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
 336         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
 337 #endif
 338         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 339         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 340 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
 341                 case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
 342 #endif
 343 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
 344                 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
 345 #endif
 346 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
 347                 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
 348 #endif
 349 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
 350         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
 351 #endif
 352 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
 353         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
 354 #endif
 355 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
 356         case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
 357 #endif
 358 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
 359         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
 360 #endif
 361 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
 362                 case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
 363 #endif
 364 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
 365                 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
 366 #endif
 367         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
 368         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
 369 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
 370         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
 371 #endif
 372 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
 373         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
 374 #endif
 375 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
 376         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
 377 #endif
 378 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
 379         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
 380 #endif
 381         case SAP_WIDETAG:
 382         case WEAK_POINTER_WIDETAG:
 383             break;
 384
 385         default:
 386             if (pointer_filter_verbose) {
 387                 fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned long) pointer,
 388                         (unsigned long) start_addr, *start_addr);
 389             }
 390             return 0;
 391         }
 392         break;
 393     default:
 394         if (pointer_filter_verbose) {
 395             fprintf(stderr,"*W?: %x %x %x\n", (unsigned long) pointer,
 396                     (unsigned long) start_addr, *start_addr);
 397         }
 398         return 0;
 399     }
 400
 401     /* looks good */
 402     return 1;
 403 }
 404
 405 #define MAX_STACK_POINTERS 256
 406 lispobj *valid_stack_locations[MAX_STACK_POINTERS];
 407 unsigned long num_valid_stack_locations;
 408
 409 #define MAX_STACK_RETURN_ADDRESSES 128
 410 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
 411 lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
 412 unsigned long num_valid_stack_ra_locations;
 413
 414 /* Identify valid stack slots. */
 415 static void
 416 setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
 417 {
 418     lispobj *sp = lowaddr;
 419     num_valid_stack_locations = 0;
 420     num_valid_stack_ra_locations = 0;
 421     for (sp = lowaddr; sp < base; sp++) {
 422         lispobj thing = *sp;
 423         /* Find the object start address */
 424         lispobj *start_addr = search_dynamic_space((void *)thing);
 425         if (start_addr) {
 426             /* We need to allow raw pointers into Code objects for
 427              * return addresses. This will also pick up pointers to
 428              * functions in code objects. */
 429             if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
 430                 /* FIXME asserting here is a really dumb thing to do.
 431                  * If we've overflowed some arbitrary static limit, we
 432                  * should just refuse to purify, instead of killing
 433                  * the whole lisp session
 434                  */
 435                 gc_assert(num_valid_stack_ra_locations <
 436                           MAX_STACK_RETURN_ADDRESSES);
 437                 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
 438                 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
 439                     (lispobj *)((long)start_addr + OTHER_POINTER_LOWTAG);
 440             } else {
 441                 if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
 442                     gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
 443                     valid_stack_locations[num_valid_stack_locations++] = sp;
 444                 }
 445             }
 446         }
 447     }
 448     if (pointer_filter_verbose) {
 449         fprintf(stderr, "number of valid stack pointers = %d\n",
 450                 num_valid_stack_locations);
 451         fprintf(stderr, "number of stack return addresses = %d\n",
 452                 num_valid_stack_ra_locations);
 453     }
 454 }
 455
 456 static void
 457 pscav_i386_stack(void)
 458 {
 459     long i;
 460
 461     for (i = 0; i < num_valid_stack_locations; i++)
 462         pscav(valid_stack_locations[i], 1, 0);
 463
 464     for (i = 0; i < num_valid_stack_ra_locations; i++) {
 465         lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
 466         pscav(&code_obj, 1, 0);
 467         if (pointer_filter_verbose) {
 468             fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
 469                     *valid_stack_ra_locations[i],
 470                     (long)(*valid_stack_ra_locations[i])
 471                     - ((long)valid_stack_ra_code_objects[i] - (long)code_obj),
 472                     (unsigned long) valid_stack_ra_code_objects[i], code_obj);
 473         }
 474         *valid_stack_ra_locations[i] =
 475             ((long)(*valid_stack_ra_locations[i])
 476              - ((long)valid_stack_ra_code_objects[i] - (long)code_obj));
 477     }
 478 }
 479 #endif
 480 #endif
 481
 482 \f
 483 static void
 484 pscav_later(lispobj *where, long count)
 485 {
 486     struct later *new;
 487
 488     if (count > LATERMAXCOUNT) {
 489         while (count > LATERMAXCOUNT) {
 490             pscav_later(where, LATERMAXCOUNT);
 491             count -= LATERMAXCOUNT;
 492             where += LATERMAXCOUNT;
 493         }
 494     }
 495     else {
 496         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
 497             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
 498             new  = (struct later *)malloc(sizeof(struct later));
 499             new->next = later_blocks;
 500             if (later_blocks && later_count < LATERBLOCKSIZE)
 501                 later_blocks->u[later_count].ptr = NULL;
 502             later_blocks = new;
 503             later_count = 0;
 504         }
 505
 506         if (count != 1)
 507             later_blocks->u[later_count++].count = count;
 508         later_blocks->u[later_count++].ptr = where;
 509     }
 510 }
 511
 512 static lispobj
 513 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 514 {
 515     long nwords;
 516     lispobj result, *new, *old;
 517
 518     nwords = CEILING(1 + HeaderValue(header), 2);
 519
 520     /* Allocate it */
 521     old = (lispobj *)native_pointer(thing);
 522     new = newspace_alloc(nwords,constant);
 523
 524     /* Copy it. */
 525     bcopy(old, new, nwords * sizeof(lispobj));
 526
 527     /* Deposit forwarding pointer. */
 528     result = make_lispobj(new, lowtag_of(thing));
 529     *old = result;
 530
 531     /* Scavenge it. */
 532     pscav(new, nwords, constant);
 533
 534     return result;
 535 }
 536
 537 /* We need to look at the layout to see whether it is a pure structure
 538  * class, and only then can we transport as constant. If it is pure,
 539  * we can ALWAYS transport as a constant. */
 540 static lispobj
 541 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
 542 {
 543     lispobj layout = ((struct instance *)native_pointer(thing))->slots[0];
 544     lispobj pure = ((struct instance *)native_pointer(layout))->slots[15];
 545
 546     switch (pure) {
 547     case T:
 548         return (ptrans_boxed(thing, header, 1));
 549     case NIL:
 550         return (ptrans_boxed(thing, header, 0));
 551     case 0:
 552         {
 553             /* Substructure: special case for the COMPACT-INFO-ENVs,
 554              * where the instance may have a point to the dynamic
 555              * space placed into it (e.g. the cache-name slot), but
 556              * the lists and arrays at the time of a purify can be
 557              * moved to the RO space. */
 558             long nwords;
 559             lispobj result, *new, *old;
 560
 561             nwords = CEILING(1 + HeaderValue(header), 2);
 562
 563             /* Allocate it */
 564             old = (lispobj *)native_pointer(thing);
 565             new = newspace_alloc(nwords, 0); /*  inconstant */
 566
 567             /* Copy it. */
 568             bcopy(old, new, nwords * sizeof(lispobj));
 569
 570             /* Deposit forwarding pointer. */
 571             result = make_lispobj(new, lowtag_of(thing));
 572             *old = result;
 573
 574             /* Scavenge it. */
 575             pscav(new, nwords, 1);
 576
 577             return result;
 578         }
 579     default:
 580         gc_abort();
 581         return NIL; /* dummy value: return something ... */
 582     }
 583 }
 584
 585 static lispobj
 586 ptrans_fdefn(lispobj thing, lispobj header)
 587 {
 588     long nwords;
 589     lispobj result, *new, *old, oldfn;
 590     struct fdefn *fdefn;
 591
 592     nwords = CEILING(1 + HeaderValue(header), 2);
 593
 594     /* Allocate it */
 595     old = (lispobj *)native_pointer(thing);
 596     new = newspace_alloc(nwords, 0);    /* inconstant */
 597
 598     /* Copy it. */
 599     bcopy(old, new, nwords * sizeof(lispobj));
 600
 601     /* Deposit forwarding pointer. */
 602     result = make_lispobj(new, lowtag_of(thing));
 603     *old = result;
 604
 605     /* Scavenge the function. */
 606     fdefn = (struct fdefn *)new;
 607     oldfn = fdefn->fun;
 608     pscav(&fdefn->fun, 1, 0);
 609     if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
 610         fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
 611
 612     return result;
 613 }
 614
 615 static lispobj
 616 ptrans_unboxed(lispobj thing, lispobj header)
 617 {
 618     long nwords;
 619     lispobj result, *new, *old;
 620
 621     nwords = CEILING(1 + HeaderValue(header), 2);
 622
 623     /* Allocate it */
 624     old = (lispobj *)native_pointer(thing);
 625     new = newspace_alloc(nwords,1);     /* always constant */
 626
 627     /* copy it. */
 628     bcopy(old, new, nwords * sizeof(lispobj));
 629
 630     /* Deposit forwarding pointer. */
 631     result = make_lispobj(new , lowtag_of(thing));
 632     *old = result;
 633
 634     return result;
 635 }
 636
 637 static lispobj
 638 ptrans_vector(lispobj thing, long bits, long extra,
 639               boolean boxed, boolean constant)
 640 {
 641     struct vector *vector;
 642     long nwords;
 643     lispobj result, *new;
 644     long length;
 645
 646     vector = (struct vector *)native_pointer(thing);
 647     length = fixnum_value(vector->length)+extra;
 648     // Argh, handle simple-vector-nil separately.
 649     if (bits == 0) {
 650       nwords = 2;
 651     } else {
 652       nwords = CEILING(NWORDS(length, bits) + 2, 2);
 653     }
 654
 655     new=newspace_alloc(nwords, (constant || !boxed));
 656     bcopy(vector, new, nwords * sizeof(lispobj));
 657
 658     result = make_lispobj(new, lowtag_of(thing));
 659     vector->header = result;
 660
 661     if (boxed)
 662         pscav(new, nwords, constant);
 663
 664     return result;
 665 }
 666
 667 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 668 static void
 669 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
 670 {
 671     long nheader_words, ncode_words, nwords;
 672     void  *constants_start_addr, *constants_end_addr;
 673     void  *code_start_addr, *code_end_addr;
 674     lispobj fixups = NIL;
 675     unsigned  displacement = (unsigned)new_code - (unsigned)old_code;
 676     struct vector *fixups_vector;
 677
 678     ncode_words = fixnum_value(new_code->code_size);
 679     nheader_words = HeaderValue(*(lispobj *)new_code);
 680     nwords = ncode_words + nheader_words;
 681
 682     constants_start_addr = (void *)new_code + 5 * N_WORD_BYTES;
 683     constants_end_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
 684     code_start_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
 685     code_end_addr = (void *)new_code + nwords*N_WORD_BYTES;
 686
 687     /* The first constant should be a pointer to the fixups for this
 688      * code objects. Check. */
 689     fixups = new_code->constants[0];
 690
 691     /* It will be 0 or the unbound-marker if there are no fixups, and
 692      * will be an other-pointer to a vector if it is valid. */
 693     if ((fixups==0) ||
 694         (fixups==UNBOUND_MARKER_WIDETAG) ||
 695         !is_lisp_pointer(fixups)) {
 696 #ifdef LISP_FEATURE_GENCGC
 697         /* Check for a possible errors. */
 698         sniff_code_object(new_code,displacement);
 699 #endif
 700         return;
 701     }
 702
 703     fixups_vector = (struct vector *)native_pointer(fixups);
 704
 705     /* Could be pointing to a forwarding pointer. */
 706     if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups))
 707         && forwarding_pointer_p(*(lispobj *)fixups_vector)) {
 708         /* If so then follow it. */
 709         fixups_vector =
 710             (struct vector *)native_pointer(*(lispobj *)fixups_vector);
 711     }
 712
 713     if (widetag_of(fixups_vector->header) == SIMPLE_ARRAY_WORD_WIDETAG) {
 714         /* We got the fixups for the code block. Now work through the
 715          * vector, and apply a fixup at each address. */
 716         long length = fixnum_value(fixups_vector->length);
 717         long i;
 718         for (i=0; i<length; i++) {
 719             unsigned offset = fixups_vector->data[i];
 720             /* Now check the current value of offset. */
 721             unsigned old_value =
 722                 *(unsigned *)((unsigned)code_start_addr + offset);
 723
 724             /* If it's within the old_code object then it must be an
 725              * absolute fixup (relative ones are not saved) */
 726             if ((old_value>=(unsigned)old_code)
 727                 && (old_value<((unsigned)old_code + nwords * N_WORD_BYTES)))
 728                 /* So add the dispacement. */
 729                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
 730                     + displacement;
 731             else
 732                 /* It is outside the old code object so it must be a relative
 733                  * fixup (absolute fixups are not saved). So subtract the
 734                  * displacement. */
 735                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
 736                     - displacement;
 737         }
 738     }
 739
 740     /* No longer need the fixups. */
 741     new_code->constants[0] = 0;
 742
 743 #ifdef LISP_FEATURE_GENCGC
 744     /* Check for possible errors. */
 745     sniff_code_object(new_code,displacement);
 746 #endif
 747 }
 748 #endif
 749
 750 static lispobj
 751 ptrans_code(lispobj thing)
 752 {
 753     struct code *code, *new;
 754     long nwords;
 755     lispobj func, result;
 756
 757     code = (struct code *)native_pointer(thing);
 758     nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
 759                      2);
 760
 761     new = (struct code *)newspace_alloc(nwords,1); /* constant */
 762
 763     bcopy(code, new, nwords * sizeof(lispobj));
 764
 765 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 766     apply_code_fixups_during_purify(code,new);
 767 #endif
 768
 769     result = make_lispobj(new, OTHER_POINTER_LOWTAG);
 770
 771     /* Stick in a forwarding pointer for the code object. */
 772     *(lispobj *)code = result;
 773
 774     /* Put in forwarding pointers for all the functions. */
 775     for (func = code->entry_points;
 776          func != NIL;
 777          func = ((struct simple_fun *)native_pointer(func))->next) {
 778
 779         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
 780
 781         *(lispobj *)native_pointer(func) = result + (func - thing);
 782     }
 783
 784     /* Arrange to scavenge the debug info later. */
 785     pscav_later(&new->debug_info, 1);
 786
 787     /* FIXME: why would this be a fixnum? */
 788     /* "why" is a hard word, but apparently for compiled functions the
 789        trace_table_offset contains the length of the instructions, as
 790        a fixnum.  See CODE-INST-AREA-LENGTH in
 791        src/compiler/target-disassem.lisp.  -- CSR, 2004-01-08 */
 792     if (!(fixnump(new->trace_table_offset)))
 793 #if 0
 794         pscav(&new->trace_table_offset, 1, 0);
 795 #else
 796         new->trace_table_offset = NIL; /* limit lifetime */
 797 #endif
 798
 799     /* Scavenge the constants. */
 800     pscav(new->constants, HeaderValue(new->header)-5, 1);
 801
 802     /* Scavenge all the functions. */
 803     pscav(&new->entry_points, 1, 1);
 804     for (func = new->entry_points;
 805          func != NIL;
 806          func = ((struct simple_fun *)native_pointer(func))->next) {
 807         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
 808         gc_assert(!dynamic_pointer_p(func));
 809
 810 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 811         /* Temporarily convert the self pointer to a real function pointer. */
 812         ((struct simple_fun *)native_pointer(func))->self
 813             -= FUN_RAW_ADDR_OFFSET;
 814 #endif
 815         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
 816 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 817         ((struct simple_fun *)native_pointer(func))->self
 818             += FUN_RAW_ADDR_OFFSET;
 819 #endif
 820         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
 821     }
 822
 823     return result;
 824 }
 825
 826 static lispobj
 827 ptrans_func(lispobj thing, lispobj header)
 828 {
 829     long nwords;
 830     lispobj code, *new, *old, result;
 831     struct simple_fun *function;
 832
 833     /* Thing can either be a function header, a closure function
 834      * header, a closure, or a funcallable-instance. If it's a closure
 835      * or a funcallable-instance, we do the same as ptrans_boxed.
 836      * Otherwise we have to do something strange, 'cause it is buried
 837      * inside a code object. */
 838
 839     if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
 840
 841         /* We can only end up here if the code object has not been
 842          * scavenged, because if it had been scavenged, forwarding pointers
 843          * would have been left behind for all the entry points. */
 844
 845         function = (struct simple_fun *)native_pointer(thing);
 846         code =
 847             make_lispobj
 848             ((native_pointer(thing) -
 849               (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
 850
 851         /* This will cause the function's header to be replaced with a
 852          * forwarding pointer. */
 853
 854         ptrans_code(code);
 855
 856         /* So we can just return that. */
 857         return function->header;
 858     }
 859     else {
 860         /* It's some kind of closure-like thing. */
 861         nwords = CEILING(1 + HeaderValue(header), 2);
 862         old = (lispobj *)native_pointer(thing);
 863
 864         /* Allocate the new one.  FINs *must* not go in read_only
 865          * space.  Closures can; they never change */
 866
 867         new = newspace_alloc
 868             (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG));
 869
 870         /* Copy it. */
 871         bcopy(old, new, nwords * sizeof(lispobj));
 872
 873         /* Deposit forwarding pointer. */
 874         result = make_lispobj(new, lowtag_of(thing));
 875         *old = result;
 876
 877         /* Scavenge it. */
 878         pscav(new, nwords, 0);
 879
 880         return result;
 881     }
 882 }
 883
 884 static lispobj
 885 ptrans_returnpc(lispobj thing, lispobj header)
 886 {
 887     lispobj code, new;
 888
 889     /* Find the corresponding code object. */
 890     code = thing - HeaderValue(header)*sizeof(lispobj);
 891
 892     /* Make sure it's been transported. */
 893     new = *(lispobj *)native_pointer(code);
 894     if (!forwarding_pointer_p(new))
 895         new = ptrans_code(code);
 896
 897     /* Maintain the offset: */
 898     return new + (thing - code);
 899 }
 900
 901 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
 902
 903 static lispobj
 904 ptrans_list(lispobj thing, boolean constant)
 905 {
 906     struct cons *old, *new, *orig;
 907     long length;
 908
 909     orig = (struct cons *) newspace_alloc(0,constant);
 910     length = 0;
 911
 912     do {
 913         /* Allocate a new cons cell. */
 914         old = (struct cons *)native_pointer(thing);
 915         new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
 916
 917         /* Copy the cons cell and keep a pointer to the cdr. */
 918         new->car = old->car;
 919         thing = new->cdr = old->cdr;
 920
 921         /* Set up the forwarding pointer. */
 922         *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
 923
 924         /* And count this cell. */
 925         length++;
 926     } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
 927              dynamic_pointer_p(thing) &&
 928              !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
 929
 930     /* Scavenge the list we just copied. */
 931     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
 932
 933     return make_lispobj(orig, LIST_POINTER_LOWTAG);
 934 }
 935
 936 static lispobj
 937 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 938 {
 939     switch (widetag_of(header)) {
 940         /* FIXME: this needs a reindent */
 941       case BIGNUM_WIDETAG:
 942       case SINGLE_FLOAT_WIDETAG:
 943       case DOUBLE_FLOAT_WIDETAG:
 944 #ifdef LONG_FLOAT_WIDETAG
 945       case LONG_FLOAT_WIDETAG:
 946 #endif
 947 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 948       case COMPLEX_SINGLE_FLOAT_WIDETAG:
 949 #endif
 950 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 951       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 952 #endif
 953 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 954       case COMPLEX_LONG_FLOAT_WIDETAG:
 955 #endif
 956       case SAP_WIDETAG:
 957           return ptrans_unboxed(thing, header);
 958
 959       case RATIO_WIDETAG:
 960       case COMPLEX_WIDETAG:
 961       case SIMPLE_ARRAY_WIDETAG:
 962       case COMPLEX_BASE_STRING_WIDETAG:
 963 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 964     case COMPLEX_CHARACTER_STRING_WIDETAG:
 965 #endif
 966       case COMPLEX_BIT_VECTOR_WIDETAG:
 967       case COMPLEX_VECTOR_NIL_WIDETAG:
 968       case COMPLEX_VECTOR_WIDETAG:
 969       case COMPLEX_ARRAY_WIDETAG:
 970         return ptrans_boxed(thing, header, constant);
 971
 972       case VALUE_CELL_HEADER_WIDETAG:
 973       case WEAK_POINTER_WIDETAG:
 974         return ptrans_boxed(thing, header, 0);
 975
 976       case SYMBOL_HEADER_WIDETAG:
 977         return ptrans_boxed(thing, header, 0);
 978
 979       case SIMPLE_ARRAY_NIL_WIDETAG:
 980         return ptrans_vector(thing, 0, 0, 0, constant);
 981
 982       case SIMPLE_BASE_STRING_WIDETAG:
 983         return ptrans_vector(thing, 8, 1, 0, constant);
 984
 985 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
 986     case SIMPLE_CHARACTER_STRING_WIDETAG:
 987         return ptrans_vector(thing, 32, 1, 0, constant);
 988 #endif
 989
 990       case SIMPLE_BIT_VECTOR_WIDETAG:
 991         return ptrans_vector(thing, 1, 0, 0, constant);
 992
 993       case SIMPLE_VECTOR_WIDETAG:
 994         return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant);
 995
 996       case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
 997         return ptrans_vector(thing, 2, 0, 0, constant);
 998
 999       case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
1000         return ptrans_vector(thing, 4, 0, 0, constant);
1001
1002       case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
1003 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1004       case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
1005       case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
1006 #endif
1007         return ptrans_vector(thing, 8, 0, 0, constant);
1008
1009       case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
1010 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1011       case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
1012       case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
1013 #endif
1014         return ptrans_vector(thing, 16, 0, 0, constant);
1015
1016       case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
1017 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1018       case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
1019       case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
1020 #endif
1021 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1022       case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
1023       case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
1024 #endif
1025         return ptrans_vector(thing, 32, 0, 0, constant);
1026
1027 #if N_WORD_BITS == 64
1028 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1029       case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
1030 #endif
1031 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1032       case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
1033 #endif
1034 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1035       case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
1036 #endif
1037 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1038       case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
1039 #endif
1040 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1041       case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
1042 #endif
1043         return ptrans_vector(thing, 64, 0, 0, constant);
1044 #endif
1045
1046       case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
1047         return ptrans_vector(thing, 32, 0, 0, constant);
1048
1049       case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
1050         return ptrans_vector(thing, 64, 0, 0, constant);
1051
1052 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1053       case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
1054 #ifdef LISP_FEATURE_X86
1055         return ptrans_vector(thing, 96, 0, 0, constant);
1056 #endif
1057 #ifdef LISP_FEATURE_SPARC
1058         return ptrans_vector(thing, 128, 0, 0, constant);
1059 #endif
1060 #endif
1061
1062 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1063       case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
1064         return ptrans_vector(thing, 64, 0, 0, constant);
1065 #endif
1066
1067 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1068       case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
1069         return ptrans_vector(thing, 128, 0, 0, constant);
1070 #endif
1071
1072 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1073       case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
1074 #ifdef LISP_FEATURE_X86
1075         return ptrans_vector(thing, 192, 0, 0, constant);
1076 #endif
1077 #ifdef LISP_FEATURE_SPARC
1078         return ptrans_vector(thing, 256, 0, 0, constant);
1079 #endif
1080 #endif
1081
1082       case CODE_HEADER_WIDETAG:
1083         return ptrans_code(thing);
1084
1085       case RETURN_PC_HEADER_WIDETAG:
1086         return ptrans_returnpc(thing, header);
1087
1088       case FDEFN_WIDETAG:
1089         return ptrans_fdefn(thing, header);
1090
1091       default:
1092         fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
1093         /* Should only come across other pointers to the above stuff. */
1094         gc_abort();
1095         return NIL;
1096     }
1097 }
1098
1099 static long
1100 pscav_fdefn(struct fdefn *fdefn)
1101 {
1102     boolean fix_func;
1103
1104     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
1105     pscav(&fdefn->name, 1, 1);
1106     pscav(&fdefn->fun, 1, 0);
1107     if (fix_func)
1108         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
1109     return sizeof(struct fdefn) / sizeof(lispobj);
1110 }
1111
1112 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1113 /* now putting code objects in static space */
1114 static long
1115 pscav_code(struct code*code)
1116 {
1117     long nwords;
1118     lispobj func;
1119     nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
1120                      2);
1121
1122     /* Arrange to scavenge the debug info later. */
1123     pscav_later(&code->debug_info, 1);
1124
1125     /* Scavenge the constants. */
1126     pscav(code->constants, HeaderValue(code->header)-5, 1);
1127
1128     /* Scavenge all the functions. */
1129     pscav(&code->entry_points, 1, 1);
1130     for (func = code->entry_points;
1131          func != NIL;
1132          func = ((struct simple_fun *)native_pointer(func))->next) {
1133         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
1134         gc_assert(!dynamic_pointer_p(func));
1135
1136 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1137         /* Temporarily convert the self pointer to a real function
1138          * pointer. */
1139         ((struct simple_fun *)native_pointer(func))->self
1140             -= FUN_RAW_ADDR_OFFSET;
1141 #endif
1142         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
1143 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1144         ((struct simple_fun *)native_pointer(func))->self
1145             += FUN_RAW_ADDR_OFFSET;
1146 #endif
1147         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
1148     }
1149
1150     return CEILING(nwords,2);
1151 }
1152 #endif
1153
1154 static lispobj *
1155 pscav(lispobj *addr, long nwords, boolean constant)
1156 {
1157     lispobj thing, *thingp, header;
1158     long count = 0; /* (0 = dummy init value to stop GCC warning) */
1159     struct vector *vector;
1160
1161     while (nwords > 0) {
1162         thing = *addr;
1163         if (is_lisp_pointer(thing)) {
1164             /* It's a pointer. Is it something we might have to move? */
1165             if (dynamic_pointer_p(thing)) {
1166                 /* Maybe. Have we already moved it? */
1167                 thingp = (lispobj *)native_pointer(thing);
1168                 header = *thingp;
1169                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
1170                     /* Yep, so just copy the forwarding pointer. */
1171                     thing = header;
1172                 else {
1173                     /* Nope, copy the object. */
1174                     switch (lowtag_of(thing)) {
1175                       case FUN_POINTER_LOWTAG:
1176                         thing = ptrans_func(thing, header);
1177                         break;
1178
1179                       case LIST_POINTER_LOWTAG:
1180                         thing = ptrans_list(thing, constant);
1181                         break;
1182
1183                       case INSTANCE_POINTER_LOWTAG:
1184                         thing = ptrans_instance(thing, header, constant);
1185                         break;
1186
1187                       case OTHER_POINTER_LOWTAG:
1188                         thing = ptrans_otherptr(thing, header, constant);
1189                         break;
1190
1191                       default:
1192                         /* It was a pointer, but not one of them? */
1193                         gc_abort();
1194                     }
1195                 }
1196                 *addr = thing;
1197             }
1198             count = 1;
1199         }
1200 #if N_WORD_BITS == 64
1201         else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) {
1202             count = 1;
1203         }
1204 #endif
1205         else if (thing & FIXNUM_TAG_MASK) {
1206             /* It's an other immediate. Maybe the header for an unboxed */
1207             /* object. */
1208             switch (widetag_of(thing)) {
1209               case BIGNUM_WIDETAG:
1210               case SINGLE_FLOAT_WIDETAG:
1211               case DOUBLE_FLOAT_WIDETAG:
1212 #ifdef LONG_FLOAT_WIDETAG
1213               case LONG_FLOAT_WIDETAG:
1214 #endif
1215               case SAP_WIDETAG:
1216                 /* It's an unboxed simple object. */
1217                 count = CEILING(HeaderValue(thing)+1, 2);
1218                 break;
1219
1220               case SIMPLE_VECTOR_WIDETAG:
1221                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
1222                     *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
1223                         SIMPLE_VECTOR_WIDETAG;
1224                   }
1225                 count = 2;
1226                 break;
1227
1228               case SIMPLE_ARRAY_NIL_WIDETAG:
1229                 count = 2;
1230                 break;
1231
1232               case SIMPLE_BASE_STRING_WIDETAG:
1233                 vector = (struct vector *)addr;
1234                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,8)+2,2);
1235                 break;
1236
1237 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1238             case SIMPLE_CHARACTER_STRING_WIDETAG:
1239                 vector = (struct vector *)addr;
1240                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,32)+2,2);
1241                 break;
1242 #endif
1243
1244               case SIMPLE_BIT_VECTOR_WIDETAG:
1245                 vector = (struct vector *)addr;
1246                 count = CEILING(NWORDS(fixnum_value(vector->length),1)+2,2);
1247                 break;
1248
1249               case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
1250                 vector = (struct vector *)addr;
1251                 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
1252                 break;
1253
1254               case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
1255                 vector = (struct vector *)addr;
1256                 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
1257                 break;
1258
1259               case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
1260 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1261               case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
1262               case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
1263 #endif
1264                 vector = (struct vector *)addr;
1265                 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
1266                 break;
1267
1268               case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
1269 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1270               case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
1271               case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
1272 #endif
1273                 vector = (struct vector *)addr;
1274                 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
1275                 break;
1276
1277               case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
1278 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1279               case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
1280               case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
1281 #endif
1282 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1283               case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
1284               case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
1285 #endif
1286                 vector = (struct vector *)addr;
1287                 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
1288                 break;
1289
1290 #if N_WORD_BITS == 64
1291               case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
1292 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1293               case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
1294               case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
1295 #endif
1296 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1297               case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
1298               case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
1299 #endif
1300                 vector = (struct vector *)addr;
1301                 count = CEILING(NWORDS(fixnum_value(vector->length),64)+2,2);
1302                 break;
1303 #endif
1304
1305               case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
1306                 vector = (struct vector *)addr;
1307                 count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2,
1308                                 2);
1309                 break;
1310
1311               case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
1312 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1313               case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
1314 #endif
1315                 vector = (struct vector *)addr;
1316                 count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2,
1317                                 2);
1318                 break;
1319
1320 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1321               case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
1322                 vector = (struct vector *)addr;
1323 #ifdef LISP_FEATURE_X86
1324                 count = fixnum_value(vector->length)*3+2;
1325 #endif
1326 #ifdef LISP_FEATURE_SPARC
1327                 count = fixnum_value(vector->length)*4+2;
1328 #endif
1329                 break;
1330 #endif
1331
1332 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1333               case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
1334                 vector = (struct vector *)addr;
1335                 count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2,
1336                                 2);
1337                 break;
1338 #endif
1339
1340 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1341               case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
1342                 vector = (struct vector *)addr;
1343 #ifdef LISP_FEATURE_X86
1344                 count = fixnum_value(vector->length)*6+2;
1345 #endif
1346 #ifdef LISP_FEATURE_SPARC
1347                 count = fixnum_value(vector->length)*8+2;
1348 #endif
1349                 break;
1350 #endif
1351
1352               case CODE_HEADER_WIDETAG:
1353 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1354                 gc_abort(); /* no code headers in static space */
1355 #else
1356                 count = pscav_code((struct code*)addr);
1357 #endif
1358                 break;
1359
1360               case SIMPLE_FUN_HEADER_WIDETAG:
1361               case RETURN_PC_HEADER_WIDETAG:
1362                 /* We should never hit any of these, 'cause they occur
1363                  * buried in the middle of code objects. */
1364                 gc_abort();
1365                 break;
1366
1367 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1368               case CLOSURE_HEADER_WIDETAG:
1369               case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
1370                 /* The function self pointer needs special care on the
1371                  * x86 because it is the real entry point. */
1372                 {
1373                   lispobj fun = ((struct closure *)addr)->fun
1374                     - FUN_RAW_ADDR_OFFSET;
1375                   pscav(&fun, 1, constant);
1376                   ((struct closure *)addr)->fun = fun + FUN_RAW_ADDR_OFFSET;
1377                 }
1378                 count = 2;
1379                 break;
1380 #endif
1381
1382               case WEAK_POINTER_WIDETAG:
1383                 /* Weak pointers get preserved during purify, 'cause I
1384                  * don't feel like figuring out how to break them. */
1385                 pscav(addr+1, 2, constant);
1386                 count = 4;
1387                 break;
1388
1389               case FDEFN_WIDETAG:
1390                 /* We have to handle fdefn objects specially, so we
1391                  * can fix up the raw function address. */
1392                 count = pscav_fdefn((struct fdefn *)addr);
1393                 break;
1394
1395               default:
1396                 count = 1;
1397                 break;
1398             }
1399         }
1400         else {
1401             /* It's a fixnum. */
1402             count = 1;
1403         }
1404
1405         addr += count;
1406         nwords -= count;
1407     }
1408
1409     return addr;
1410 }
1411
1412 int
1413 purify(lispobj static_roots, lispobj read_only_roots)
1414 {
1415     lispobj *clean;
1416     long count, i;
1417     struct later *laters, *next;
1418     struct thread *thread;
1419
1420     if(all_threads->next) {
1421         /* FIXME: there should be _some_ sensible error reporting
1422          * convention.  See following comment too */
1423         fprintf(stderr,"Can't purify when more than one thread exists\n");
1424         fflush(stderr);
1425         return 0;
1426     }
1427
1428 #ifdef PRINTNOISE
1429     printf("[doing purification:");
1430     fflush(stdout);
1431 #endif
1432 #ifdef LISP_FEATURE_GENCGC
1433     gc_alloc_update_all_page_tables();
1434 #endif
1435     for_each_thread(thread)
1436         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
1437         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
1438          * its error simply by a. printing a string b. to stdout instead
1439          * of stderr. */
1440         printf(" Ack! Can't purify interrupt contexts. ");
1441         fflush(stdout);
1442         return 0;
1443     }
1444
1445 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1446     dynamic_space_free_pointer =
1447       (lispobj*)SymbolValue(ALLOCATION_POINTER,0);
1448 #endif
1449
1450     read_only_end = read_only_free =
1451         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
1452     static_end = static_free =
1453         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
1454
1455 #ifdef PRINTNOISE
1456     printf(" roots");
1457     fflush(stdout);
1458 #endif
1459
1460 #if defined(LISP_FEATURE_GENCGC) && (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
1461     /* note this expects only one thread to be active.  We'd have to
1462      * stop all the others in the same way as GC does if we wanted
1463      * PURIFY to work when >1 thread exists */
1464     setup_i386_stack_scav(((&static_roots)-2),
1465                           ((void *)all_threads->control_stack_end));
1466 #endif
1467
1468     pscav(&static_roots, 1, 0);
1469     pscav(&read_only_roots, 1, 1);
1470
1471 #ifdef PRINTNOISE
1472     printf(" handlers");
1473     fflush(stdout);
1474 #endif
1475     pscav((lispobj *) all_threads->interrupt_data->interrupt_handlers,
1476           sizeof(all_threads->interrupt_data->interrupt_handlers)
1477           / sizeof(lispobj),
1478           0);
1479
1480 #ifdef PRINTNOISE
1481     printf(" stack");
1482     fflush(stdout);
1483 #endif
1484 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1485     pscav((lispobj *)all_threads->control_stack_start,
1486           current_control_stack_pointer -
1487           all_threads->control_stack_start,
1488           0);
1489 #else
1490 #ifdef LISP_FEATURE_GENCGC
1491     pscav_i386_stack();
1492 #endif
1493 #endif
1494
1495 #ifdef PRINTNOISE
1496     printf(" bindings");
1497     fflush(stdout);
1498 #endif
1499 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
1500     pscav( (lispobj *)all_threads->binding_stack_start,
1501           (lispobj *)current_binding_stack_pointer -
1502            all_threads->binding_stack_start,
1503           0);
1504 #else
1505     for_each_thread(thread) {
1506         pscav( (lispobj *)thread->binding_stack_start,
1507                (lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) -
1508                (lispobj *)thread->binding_stack_start,
1509           0);
1510         pscav( (lispobj *) (thread+1),
1511                fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
1512                (sizeof (struct thread))/(sizeof (lispobj)),
1513           0);
1514     }
1515
1516
1517 #endif
1518
1519     /* The original CMU CL code had scavenge-read-only-space code
1520      * controlled by the Lisp-level variable
1521      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
1522      * wasn't documented under what circumstances it was useful or
1523      * safe to turn it on, so it's been turned off in SBCL. If you
1524      * want/need this functionality, and can test and document it,
1525      * please submit a patch. */
1526 #if 0
1527     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
1528         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1529       unsigned  read_only_space_size =
1530           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1531           (lispobj *)READ_ONLY_SPACE_START;
1532       fprintf(stderr,
1533               "scavenging read only space: %d bytes\n",
1534               read_only_space_size * sizeof(lispobj));
1535       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
1536     }
1537 #endif
1538
1539 #ifdef PRINTNOISE
1540     printf(" static");
1541     fflush(stdout);
1542 #endif
1543     clean = (lispobj *)STATIC_SPACE_START;
1544     do {
1545         while (clean != static_free)
1546             clean = pscav(clean, static_free - clean, 0);
1547         laters = later_blocks;
1548         count = later_count;
1549         later_blocks = NULL;
1550         later_count = 0;
1551         while (laters != NULL) {
1552             for (i = 0; i < count; i++) {
1553                 if (laters->u[i].count == 0) {
1554                     ;
1555                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
1556                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
1557                     i++;
1558                 } else {
1559                     pscav(laters->u[i].ptr, 1, 1);
1560                 }
1561             }
1562             next = laters->next;
1563             free(laters);
1564             laters = next;
1565             count = LATERBLOCKSIZE;
1566         }
1567     } while (clean != static_free || later_blocks != NULL);
1568
1569 #ifdef PRINTNOISE
1570     printf(" cleanup");
1571     fflush(stdout);
1572 #endif
1573
1574     os_zero((os_vm_address_t) current_dynamic_space,
1575             (os_vm_size_t) DYNAMIC_SPACE_SIZE);
1576
1577     /* Zero the stack. Note that the stack is also zeroed by SUB-GC
1578      * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
1579 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1580     os_zero((os_vm_address_t) current_control_stack_pointer,
1581             (os_vm_size_t)
1582             ((all_threads->control_stack_end -
1583               current_control_stack_pointer) * sizeof(lispobj)));
1584 #endif
1585
1586     /* It helps to update the heap free pointers so that free_heap can
1587      * verify after it's done. */
1588     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
1589     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
1590
1591 #if !defined(ALLOCATION_POINTER)
1592     dynamic_space_free_pointer = current_dynamic_space;
1593     set_auto_gc_trigger(bytes_consed_between_gcs);
1594 #else
1595 #if defined LISP_FEATURE_GENCGC
1596     gc_free_heap();
1597 #else
1598 #error unsupported case /* in CMU CL, was "ibmrt using GC" */
1599 #endif
1600 #endif
1601
1602     /* Blast away instruction cache */
1603     os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
1604     os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
1605
1606 #ifdef PRINTNOISE
1607     printf(" done]\n");
1608     fflush(stdout);
1609 #endif
1610     return 0;
1611 }