src/lisp/purify.c

   1 /* Purify.
   2
   3    This code is based on public domain codes from CMUCL. It is placed
   4    in the public domain and is provided as-is.
   5
   6    Stack direction changes, the x86/CGC stack scavenging, and static
   7    blue bag feature, by Paul Werkowski, 1995, 1996.
   8
   9    Bug fixes, x86 code movement support, the scavenger hook support,
  10    and x86/GENCGC stack scavenging, by Douglas Crosher, 1996, 1997,
  11    1998.
  12
  13    */
  14 #include <stdio.h>
  15 #include <sys/types.h>
  16 #include <stdlib.h>
  17 #include <string.h>
  18
  19 #include "lisp.h"
  20 #include "arch.h"
  21 #include "os.h"
  22 #include "internals.h"
  23 #include "globals.h"
  24 #include "validate.h"
  25 #include "interrupt.h"
  26 #include "purify.h"
  27 #include "interr.h"
  28 #ifdef GENCGC
  29 #include "gencgc.h"
  30 #endif
  31
  32 #undef PRINTNOISE
  33
  34 #if (defined(i386) || defined(__x86_64))
  35 static lispobj *current_dynamic_space_free_pointer;
  36 #endif
  37
  38 #define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \
  39                         __FILE__, __LINE__)
  40
  41 #if 1
  42 #define gc_assert(ex) do { \
  43         if (!(ex)) gc_abort(); \
  44 } while (0)
  45 #else
  46 #define gc_assert(ex)
  47 #endif
  48
  49
  50 #define assert_static_space_bounds(ptr) do { \
  51    if (!((lispobj*)STATIC_SPACE_START <= ptr && ptr < (lispobj*)(STATIC_SPACE_START + static_space_size))) \
  52       lose ("static-space overflow!  File \"%s\", line %d\n", \
  53                         __FILE__, __LINE__); \
  54 } while (0)
  55
  56 #define assert_readonly_space_bounds(ptr) do { \
  57    if (!((lispobj*)READ_ONLY_SPACE_START <= ptr && ptr < (lispobj*)(READ_ONLY_SPACE_START + read_only_space_size))) \
  58       lose ("readonly-space overflow!  File \"%s\", line %d\n", \
  59                         __FILE__, __LINE__); \
  60 } while (0)
  61 \f
  62
  63
  64 /* These hold the original end of the read_only and static spaces so we can */
  65 /* tell what are forwarding pointers. */
  66
  67 static lispobj *read_only_end, *static_end;
  68
  69 static lispobj *read_only_free, *static_free;
  70 static lispobj *pscav(lispobj * addr, int nwords, boolean constant);
  71
  72 #define LATERBLOCKSIZE 1020
  73 #define LATERMAXCOUNT 10
  74
  75 static struct later {
  76     struct later *next;
  77     union {
  78         lispobj *ptr;
  79         int count;
  80     } u[LATERBLOCKSIZE];
  81 } *later_blocks = NULL;
  82 static int later_count = 0;
  83
  84 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
  85 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
  86
  87 #if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
  88 #define RAW_ADDR_OFFSET 0
  89 #else
  90 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
  91 #endif
  92 \f
  93 static boolean
  94 forwarding_pointer_p(lispobj obj)
  95 {
  96     lispobj *ptr;
  97
  98     ptr = (lispobj *) obj;
  99
 100     return ((static_end <= ptr && ptr <= static_free) ||
 101             (read_only_end <= ptr && ptr <= read_only_free));
 102 }
 103
 104 static boolean
 105 dynamic_pointer_p(lispobj ptr)
 106 {
 107 #if !(defined(i386) || defined(__x86_64))
 108     return (ptr >= (lispobj) dynamic_0_space);
 109 #else
 110     /* Be more conservative, and remember, this is a maybe */
 111     return (ptr >= (lispobj) current_dynamic_space
 112             && ptr < (lispobj) current_dynamic_space_free_pointer);
 113 #endif
 114 }
 115 \f
 116
 117 #if (defined(i386) || defined(__x86_64))
 118
 119 #ifdef WANT_CGC
 120 /* Original x86/CGC stack scavenging code by Paul Werkowski */
 121
 122 static int
 123 maybe_can_move_p(lispobj thing)
 124 {
 125     lispobj *thingp, header;
 126
 127     if (dynamic_pointer_p(thing)) {     /* in dynamic space */
 128         thingp = (lispobj *) PTR(thing);
 129         header = *thingp;
 130         if (Pointerp(header) && forwarding_pointer_p(header))
 131             return -1;          /* must change it */
 132         if (LowtagOf(thing) == type_ListPointer)
 133             return type_ListPointer;    /* can we check this somehow */
 134         else if (thing & 3) {   /* not fixnum */
 135             int kind = TypeOf(header);
 136
 137             /* printf(" %x %x",header,kind); */
 138             switch (kind) {     /* something with a header */
 139               case type_Bignum:
 140               case type_SingleFloat:
 141               case type_DoubleFloat:
 142 #ifdef type_LongFloat
 143               case type_LongFloat:
 144 #endif
 145 #ifdef type_DoubleDoubleFloat
 146               case type_DoubleDoubleFloat:
 147 #endif
 148               case type_Sap:
 149               case type_SimpleVector:
 150               case type_SimpleString:
 151               case type_SimpleBitVector:
 152               case type_SimpleArrayUnsignedByte2:
 153               case type_SimpleArrayUnsignedByte4:
 154               case type_SimpleArrayUnsignedByte8:
 155               case type_SimpleArrayUnsignedByte16:
 156               case type_SimpleArrayUnsignedByte32:
 157 #ifdef type_SimpleArraySignedByte8
 158               case type_SimpleArraySignedByte8:
 159 #endif
 160 #ifdef type_SimpleArraySignedByte16
 161               case type_SimpleArraySignedByte16:
 162 #endif
 163 #ifdef type_SimpleArraySignedByte30
 164               case type_SimpleArraySignedByte30:
 165 #endif
 166 #ifdef type_SimpleArraySignedByte32
 167               case type_SimpleArraySignedByte32:
 168 #endif
 169               case type_SimpleArraySingleFloat:
 170               case type_SimpleArrayDoubleFloat:
 171 #ifdef type_SimpleArrayLongFloat
 172               case type_SimpleArrayLongFloat:
 173 #endif
 174 #ifdef type_SimpleArrayDoubleDoubleFloat
 175               case type_SimpleArrayDoubleDoubleFloat:
 176 #endif
 177 #ifdef type_SimpleArrayComplexSingleFloat
 178               case type_SimpleArrayComplexSingleFloat:
 179 #endif
 180 #ifdef type_SimpleArrayComplexDoubleFloat
 181               case type_SimpleArrayComplexDoubleFloat:
 182 #endif
 183 #ifdef type_SimpleArrayComplexLongFloat
 184               case type_SimpleArrayComplexLongFloat:
 185 #endif
 186 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
 187               case type_SimpleArrayComplexDoubleDoubleFloat:
 188 #endif
 189               case type_CodeHeader:
 190               case type_FunctionHeader:
 191               case type_ClosureFunctionHeader:
 192               case type_ReturnPcHeader:
 193               case type_ClosureHeader:
 194               case type_FuncallableInstanceHeader:
 195               case type_InstanceHeader:
 196               case type_ValueCellHeader:
 197               case type_ByteCodeFunction:
 198               case type_ByteCodeClosure:
 199 #ifdef type_DylanFunctionHeader
 200               case type_DylanFunctionHeader:
 201 #endif
 202               case type_WeakPointer:
 203               case type_Fdefn:
 204 #ifdef type_ScavengerHook
 205               case type_ScavengerHook:
 206 #endif
 207                   return kind;
 208                   break;
 209               default:
 210                   return 0;
 211             }
 212         }
 213     }
 214     return 0;
 215 }
 216
 217 static int pverbose = 0;
 218
 219 #define PVERBOSE pverbose
 220 static void
 221 carefully_pscav_stack(lispobj * lowaddr, lispobj * base)
 222 {
 223     lispobj *sp = lowaddr;
 224
 225     while (sp < base) {
 226         int k;
 227         lispobj thing = *sp;
 228
 229         if ((unsigned) thing & 0x3) {   /* may be pointer */
 230             /* need to check for valid float/double? */
 231             k = maybe_can_move_p(thing);
 232             if (PVERBOSE)
 233                 printf("%8x %8x %d\n", sp, thing, k);
 234             if (k)
 235                 pscav(sp, 1, FALSE);
 236         }
 237         sp++;
 238     }
 239 }
 240 #endif
 241
 242 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
 243 /*
 244  * Enhanced x86/GENCGC stack scavenging by Douglas Crosher.
 245  *
 246  * Scavenging the stack on the i386 is problematic due to conservative
 247  * roots and raw return addresses. Here it is handled in two passes:
 248  * the first pass runs before any objects are moved and tries to
 249  * identify valid pointers and return address on the stack, the second
 250  * pass scavenges these.
 251  */
 252
 253 static unsigned pointer_filter_verbose = 0;
 254
 255 static int
 256 valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 257 {
 258     /* If it's not a return address then it needs to be a valid lisp
 259        pointer. */
 260     if (!Pointerp((lispobj) pointer))
 261         return FALSE;
 262
 263     /* Check that the object pointed to is consistent with the pointer
 264        low tag. */
 265     switch (LowtagOf((lispobj) pointer)) {
 266       case type_FunctionPointer:
 267           /* Start_addr should be the enclosing code object, or a closure
 268              header. */
 269           switch (TypeOf(*start_addr)) {
 270             case type_CodeHeader:
 271                 /* This case is probably caught above. */
 272                 break;
 273             case type_ClosureHeader:
 274             case type_FuncallableInstanceHeader:
 275             case type_ByteCodeFunction:
 276             case type_ByteCodeClosure:
 277 #ifdef type_DylanFunctionHeader
 278             case type_DylanFunctionHeader:
 279 #endif
 280                 if ((int) pointer != ((int) start_addr + type_FunctionPointer)) {
 281                     if (pointer_filter_verbose)
 282                         fprintf(stderr, "*Wf2: %p %p %lx\n", pointer,
 283                                 start_addr, *start_addr);
 284                     return FALSE;
 285                 }
 286                 break;
 287             default:
 288                 if (pointer_filter_verbose)
 289                     fprintf(stderr, "*Wf3: %p %p %lx\n", pointer, start_addr,
 290                             *start_addr);
 291                 return FALSE;
 292           }
 293           break;
 294       case type_ListPointer:
 295           if ((int) pointer != ((int) start_addr + type_ListPointer)) {
 296               if (pointer_filter_verbose)
 297                   fprintf(stderr, "*Wl1: %p %p %lx\n", pointer, start_addr,
 298                           *start_addr);
 299               return FALSE;
 300           }
 301           /* Is it plausible cons? */
 302           if ((Pointerp(start_addr[0])
 303                || ((start_addr[0] & 3) == 0)    /* fixnum */
 304                ||(TypeOf(start_addr[0]) == type_BaseChar)
 305                || (TypeOf(start_addr[0]) == type_UnboundMarker))
 306               && (Pointerp(start_addr[1])
 307                   || ((start_addr[1] & 3) == 0) /* fixnum */
 308                   ||(TypeOf(start_addr[1]) == type_BaseChar)
 309                   || (TypeOf(start_addr[1]) == type_UnboundMarker)))
 310               break;
 311           else {
 312               if (pointer_filter_verbose)
 313                   fprintf(stderr, "*Wl2: %p %p %lx\n", pointer, start_addr,
 314                           *start_addr);
 315               return FALSE;
 316           }
 317       case type_InstancePointer:
 318           if ((int) pointer != ((int) start_addr + type_InstancePointer)) {
 319               if (pointer_filter_verbose)
 320                   fprintf(stderr, "*Wi1: %p %p %lx\n", pointer, start_addr,
 321                           *start_addr);
 322               return FALSE;
 323           }
 324           if (TypeOf(start_addr[0]) != type_InstanceHeader) {
 325               if (pointer_filter_verbose)
 326                   fprintf(stderr, "*Wi2: %p %p %lx\n", pointer, start_addr,
 327                           *start_addr);
 328               return FALSE;
 329           }
 330           break;
 331       case type_OtherPointer:
 332           if ((int) pointer != ((int) start_addr + type_OtherPointer)) {
 333               if (pointer_filter_verbose)
 334                   fprintf(stderr, "*Wo1: %p %p %lx\n", pointer, start_addr,
 335                           *start_addr);
 336               return FALSE;
 337           }
 338           /* Is it plausible?  Not a cons. X should check the headers. */
 339           if (Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
 340               if (pointer_filter_verbose)
 341                   fprintf(stderr, "*Wo2: %p %p %lx\n", pointer, start_addr,
 342                           *start_addr);
 343               return FALSE;
 344           }
 345           switch (TypeOf(start_addr[0])) {
 346             case type_UnboundMarker:
 347             case type_BaseChar:
 348                 if (pointer_filter_verbose)
 349                     fprintf(stderr, "*Wo3: %p %p %lx\n", pointer, start_addr,
 350                             *start_addr);
 351                 return FALSE;
 352
 353                 /* Only pointed to by function pointers? */
 354             case type_ClosureHeader:
 355             case type_FuncallableInstanceHeader:
 356             case type_ByteCodeFunction:
 357             case type_ByteCodeClosure:
 358 #ifdef type_DylanFunctionHeader
 359             case type_DylanFunctionHeader:
 360 #endif
 361                 if (pointer_filter_verbose)
 362                     fprintf(stderr, "*Wo4: %p %p %lx\n", pointer, start_addr,
 363                             *start_addr);
 364                 return FALSE;
 365
 366             case type_InstanceHeader:
 367                 if (pointer_filter_verbose)
 368                     fprintf(stderr, "*Wo5: %p %p %lx\n", pointer, start_addr,
 369                             *start_addr);
 370                 return FALSE;
 371
 372                 /* The valid other immediate pointer objects */
 373             case type_SimpleVector:
 374             case type_Ratio:
 375             case type_Complex:
 376 #ifdef type_ComplexSingleFloat
 377             case type_ComplexSingleFloat:
 378 #endif
 379 #ifdef type_ComplexDoubleFloat
 380             case type_ComplexDoubleFloat:
 381 #endif
 382 #ifdef type_ComplexLongFloat
 383             case type_ComplexLongFloat:
 384 #endif
 385 #ifdef type_ComplexDoubleDoubleFloat
 386             case type_ComplexDoubleDoubleFloat:
 387 #endif
 388             case type_SimpleArray:
 389             case type_ComplexString:
 390             case type_ComplexBitVector:
 391             case type_ComplexVector:
 392             case type_ComplexArray:
 393             case type_ValueCellHeader:
 394             case type_SymbolHeader:
 395             case type_Fdefn:
 396             case type_CodeHeader:
 397             case type_Bignum:
 398             case type_SingleFloat:
 399             case type_DoubleFloat:
 400 #ifdef type_LongFloat
 401             case type_LongFloat:
 402 #endif
 403 #ifdef type_DoubleDoubleFloat
 404             case type_DoubleDoubleFloat:
 405 #endif
 406             case type_SimpleString:
 407             case type_SimpleBitVector:
 408             case type_SimpleArrayUnsignedByte2:
 409             case type_SimpleArrayUnsignedByte4:
 410             case type_SimpleArrayUnsignedByte8:
 411             case type_SimpleArrayUnsignedByte16:
 412             case type_SimpleArrayUnsignedByte32:
 413 #ifdef type_SimpleArraySignedByte8
 414             case type_SimpleArraySignedByte8:
 415 #endif
 416 #ifdef type_SimpleArraySignedByte16
 417             case type_SimpleArraySignedByte16:
 418 #endif
 419 #ifdef type_SimpleArraySignedByte30
 420             case type_SimpleArraySignedByte30:
 421 #endif
 422 #ifdef type_SimpleArraySignedByte32
 423             case type_SimpleArraySignedByte32:
 424 #endif
 425             case type_SimpleArraySingleFloat:
 426             case type_SimpleArrayDoubleFloat:
 427 #ifdef type_SimpleArrayLongFloat
 428             case type_SimpleArrayLongFloat:
 429 #endif
 430 #ifdef type_SimpleArrayDoubleDoubleFloat
 431             case type_SimpleArrayDoubleDoubleFloat:
 432 #endif
 433 #ifdef type_SimpleArrayComplexSingleFloat
 434             case type_SimpleArrayComplexSingleFloat:
 435 #endif
 436 #ifdef type_SimpleArrayComplexDoubleFloat
 437             case type_SimpleArrayComplexDoubleFloat:
 438 #endif
 439 #ifdef type_SimpleArrayComplexLongFloat
 440             case type_SimpleArrayComplexLongFloat:
 441 #endif
 442 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
 443             case type_SimpleArrayComplexDoubleDoubleFloat:
 444 #endif
 445             case type_Sap:
 446             case type_WeakPointer:
 447             case type_ScavengerHook:
 448                 break;
 449
 450             default:
 451                 if (pointer_filter_verbose)
 452                     fprintf(stderr, "*Wo6: %p %p %lx\n", pointer, start_addr,
 453                             *start_addr);
 454                 return FALSE;
 455           }
 456           break;
 457       default:
 458           if (pointer_filter_verbose)
 459               fprintf(stderr, "*W?: %p %p %lx\n", pointer, start_addr,
 460                       *start_addr);
 461           return FALSE;
 462     }
 463
 464     /* Looks good */
 465     return TRUE;
 466 }
 467
 468 #define MAX_STACK_POINTERS 1024
 469 lispobj *valid_stack_locations[MAX_STACK_POINTERS];
 470 unsigned int num_valid_stack_locations;
 471
 472 #define MAX_STACK_RETURN_ADDRESSES 128
 473 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
 474 lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
 475 unsigned int num_valid_stack_ra_locations;
 476
 477 /*
 478  * Identify valid stack slots.
 479  */
 480
 481 static void
 482 setup_i386_stack_scav(lispobj * lowaddr, lispobj * base)
 483 {
 484     lispobj *sp = lowaddr;
 485
 486     num_valid_stack_locations = 0;
 487     num_valid_stack_ra_locations = 0;
 488
 489     for (sp = lowaddr; sp < base; sp++) {
 490         lispobj thing = *sp;
 491         lispobj *start_addr;
 492
 493         /* Find the object start address */
 494         if ((start_addr = search_dynamic_space((void *) thing)) != NULL) {
 495             /*
 496              * Need to allow raw pointers into Code objects for return
 497              * addresses. This will also pickup pointers to functions in code
 498              * objects.
 499              */
 500             if (TypeOf(*start_addr) == type_CodeHeader) {
 501                 gc_assert(num_valid_stack_ra_locations <
 502                           MAX_STACK_RETURN_ADDRESSES);
 503                 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
 504                 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
 505                     (lispobj *) ((int) start_addr + type_OtherPointer);
 506             } else {
 507                 if (valid_dynamic_space_pointer((void *) thing, start_addr)) {
 508                     gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
 509                     valid_stack_locations[num_valid_stack_locations++] = sp;
 510                 }
 511             }
 512         }
 513     }
 514     if (pointer_filter_verbose) {
 515         fprintf(stderr, "Number of valid stack pointers = %d\n",
 516                 num_valid_stack_locations);
 517         fprintf(stderr, "Number of stack return addresses = %d\n",
 518                 num_valid_stack_ra_locations);
 519     }
 520 }
 521
 522 static void
 523 pscav_i386_stack(void)
 524 {
 525     int i;
 526
 527     for (i = 0; i < num_valid_stack_locations; i++)
 528         pscav(valid_stack_locations[i], 1, FALSE);
 529
 530     for (i = 0; i < num_valid_stack_ra_locations; i++) {
 531         lispobj code_obj = (lispobj) (valid_stack_ra_code_objects[i]);
 532
 533         pscav(&code_obj, 1, FALSE);
 534         if (pointer_filter_verbose)
 535             fprintf(stderr,
 536                     "*C moved RA %lx to %x; for code object %p to %lx\n",
 537                     *valid_stack_ra_locations[i],
 538                     (int) (*valid_stack_ra_locations[i])
 539                     - ((int) valid_stack_ra_code_objects[i] - (int) code_obj),
 540                     valid_stack_ra_code_objects[i], code_obj);
 541         *valid_stack_ra_locations[i] =
 542             (lispobj) ((int) (*valid_stack_ra_locations[i])
 543                        - ((int) valid_stack_ra_code_objects[i] -
 544                           (int) code_obj));
 545     }
 546 }
 547 #endif
 548 #endif
 549 \f
 550
 551 static void
 552 pscav_later(lispobj * where, int count)
 553 {
 554     struct later *new;
 555
 556     if (count > LATERMAXCOUNT) {
 557         while (count > LATERMAXCOUNT) {
 558             pscav_later(where, LATERMAXCOUNT);
 559             count -= LATERMAXCOUNT;
 560             where += LATERMAXCOUNT;
 561         }
 562     } else {
 563         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
 564             (later_count == LATERBLOCKSIZE - 1 && count > 1)) {
 565             new = (struct later *) malloc(sizeof(struct later));
 566
 567             new->next = later_blocks;
 568             if (later_blocks && later_count < LATERBLOCKSIZE)
 569                 later_blocks->u[later_count].ptr = NULL;
 570             later_blocks = new;
 571             later_count = 0;
 572         }
 573
 574         if (count != 1)
 575             later_blocks->u[later_count++].count = count;
 576         later_blocks->u[later_count++].ptr = where;
 577     }
 578 }
 579
 580 static lispobj
 581 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 582 {
 583     int nwords;
 584     lispobj result, *new, *old;
 585
 586     nwords = 1 + HeaderValue(header);
 587
 588     /* Allocate it */
 589     old = (lispobj *) PTR(thing);
 590     if (constant) {
 591         new = read_only_free;
 592         read_only_free += CEILING(nwords, 2);
 593         assert_readonly_space_bounds(read_only_free);
 594     } else {
 595         new = static_free;
 596         static_free += CEILING(nwords, 2);
 597         assert_static_space_bounds(static_free);
 598     }
 599
 600     /* Copy it. */
 601     memmove(new, old, nwords * sizeof(lispobj));
 602
 603     /* Deposit forwarding pointer. */
 604     result = (lispobj) new | LowtagOf(thing);
 605     *old = result;
 606
 607     /* Scavenge it. */
 608     pscav(new, nwords, constant);
 609
 610     return result;
 611 }
 612
 613 /* need to look at the layout to see if it is a pure structure class, and
 614    only then can we transport as constant.  If it is pure, we can
 615    ALWAYS transport as a constant */
 616
 617 static lispobj
 618 ptrans_instance(lispobj thing, lispobj header, boolean constant)
 619 {
 620     lispobj layout = ((struct instance *) PTR(thing))->slots[0];
 621     lispobj pure = ((struct instance *) PTR(layout))->slots[15];
 622
 623     switch (pure) {
 624       case T:
 625           return (ptrans_boxed(thing, header, 1));
 626       case NIL:
 627           return (ptrans_boxed(thing, header, 0));
 628       case 0:{
 629               /* Substructure: special case for the compact-info-envs, where
 630                  the instance may have a point to the dynamic space placed
 631                  into it (e.g. the cache-name slot), but the lists and arrays
 632                  at the time of a purify can be moved to the RO space. */
 633               int nwords;
 634               lispobj result, *new, *old;
 635
 636               nwords = 1 + HeaderValue(header);
 637
 638               /* Allocate it */
 639               old = (lispobj *) PTR(thing);
 640               new = static_free;
 641               static_free += CEILING(nwords, 2);
 642               assert_static_space_bounds(static_free);
 643
 644               /* Copy it. */
 645               memmove(new, old, nwords * sizeof(lispobj));
 646
 647               /* Deposit forwarding pointer. */
 648               result = (lispobj) new | LowtagOf(thing);
 649               *old = result;
 650
 651               /* Scavenge it. */
 652               pscav(new, nwords, 1);
 653
 654               return result;
 655           }
 656       default:
 657           gc_abort();
 658           return 0;             /* squelch stupid warning */
 659     }
 660 }
 661
 662 static lispobj
 663 ptrans_fdefn(lispobj thing, lispobj header)
 664 {
 665     int nwords;
 666     lispobj result, *new, *old, oldfn;
 667     struct fdefn *fdefn;
 668
 669     nwords = 1 + HeaderValue(header);
 670
 671     /* Allocate it */
 672     old = (lispobj *) PTR(thing);
 673     new = static_free;
 674     static_free += CEILING(nwords, 2);
 675     assert_static_space_bounds(static_free);
 676
 677     /* Copy it. */
 678     memmove(new, old, nwords * sizeof(lispobj));
 679
 680     /* Deposit forwarding pointer. */
 681     result = (lispobj) new | LowtagOf(thing);
 682     *old = result;
 683
 684     /* Scavenge the function. */
 685     fdefn = (struct fdefn *) new;
 686     oldfn = fdefn->function;
 687     pscav(&fdefn->function, 1, FALSE);
 688     if ((char *) oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
 689         fdefn->raw_addr = (char *) fdefn->function + RAW_ADDR_OFFSET;
 690
 691     return result;
 692 }
 693
 694 static lispobj
 695 ptrans_unboxed(lispobj thing, lispobj header)
 696 {
 697     int nwords;
 698     lispobj result, *new, *old;
 699
 700     nwords = 1 + HeaderValue(header);
 701
 702     /* Allocate it */
 703     old = (lispobj *) PTR(thing);
 704     new = read_only_free;
 705     read_only_free += CEILING(nwords, 2);
 706     assert_readonly_space_bounds(read_only_free);
 707
 708     /* Copy it. */
 709     memmove(new, old, nwords * sizeof(lispobj));
 710
 711     /* Deposit forwarding pointer. */
 712     result = (lispobj) new | LowtagOf(thing);
 713     *old = result;
 714
 715     return result;
 716 }
 717
 718 static lispobj
 719 ptrans_vector(lispobj thing, int bits, int extra,
 720               boolean boxed, boolean constant)
 721 {
 722     struct vector *vector;
 723     int nwords;
 724     lispobj result, *new;
 725
 726     vector = (struct vector *) PTR(thing);
 727 #ifdef __x86_64
 728     nwords =
 729         2 + (CEILING((fixnum_value(vector->length) + extra) * bits, 64) >> 6);
 730 #else
 731     nwords =
 732         2 + (CEILING((fixnum_value(vector->length) + extra) * bits, 32) >> 5);
 733 #endif
 734
 735     if (boxed && !constant) {
 736         new = static_free;
 737         static_free += CEILING(nwords, 2);
 738         assert_static_space_bounds(static_free);
 739     } else {
 740         new = read_only_free;
 741         read_only_free += CEILING(nwords, 2);
 742         assert_readonly_space_bounds(read_only_free);
 743     }
 744
 745     memmove(new, vector, nwords * sizeof(lispobj));
 746
 747     result = (lispobj) new | LowtagOf(thing);
 748     vector->header = result;
 749
 750     if (boxed)
 751         pscav(new, nwords, constant);
 752
 753     return result;
 754 }
 755
 756 #if (defined(i386) || defined(__x86_64))
 757 static void
 758 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
 759 {
 760     int nheader_words, ncode_words, nwords;
 761     void *code_start_addr;
 762     lispobj fixups = NIL;
 763     unsigned displacement = (unsigned) new_code - (unsigned) old_code;
 764     struct vector *fixups_vector;
 765
 766     /* Byte compiled code has no fixups. The trace table offset will be
 767        a fixnum if it's x86 compiled code - check. */
 768     if (new_code->trace_table_offset & 0x3)
 769         return;
 770
 771     /* Else it's x86 machine code. */
 772     ncode_words = fixnum_value(new_code->code_size);
 773     nheader_words = HeaderValue(*(lispobj *) new_code);
 774     nwords = ncode_words + nheader_words;
 775
 776     code_start_addr = (void *) new_code + nheader_words * sizeof(lispobj);
 777
 778     /* The first constant should be a pointer to the fixups for this
 779        code objects. Check. */
 780     fixups = new_code->constants[0];
 781
 782     /* It will be 0 or the unbound-marker if there are no fixups, and
 783        will be an other-pointer to a vector if it is valid. */
 784     if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
 785 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
 786         /* Check for a possible errors. */
 787         sniff_code_object(new_code, displacement);
 788 #endif
 789         return;
 790     }
 791
 792     fixups_vector = (struct vector *) PTR(fixups);
 793
 794     /* Could be pointing to a forwarding pointer. */
 795     if (Pointerp(fixups) && (dynamic_pointer_p(fixups))
 796         && forwarding_pointer_p(*(lispobj *) fixups_vector)) {
 797         /* If so then follow it. */
 798         fixups_vector = (struct vector *) PTR(*(lispobj *) fixups_vector);
 799     }
 800
 801     if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
 802         /* Got the fixups for the code block.  Now work through the vector,
 803            and apply a fixup at each address. */
 804         int length = fixnum_value(fixups_vector->length);
 805
 806         /* offset_vector still has 32-bit elements on amd64.
 807            Eventually we will make this consistent with internals.h */
 808         unsigned int *offset_vector = (unsigned int *) fixups_vector->data;
 809         int i;
 810
 811         for (i = 0; i < length; i++) {
 812             unsigned offset = offset_vector[i];
 813
 814             /* Now check the current value of offset. */
 815             unsigned old_value =
 816
 817                 *(unsigned *) ((unsigned) code_start_addr + offset);
 818
 819             /* If it's within the old_code object then it must be an
 820                absolute fixup (relative ones are not saved) */
 821             if ((old_value >= (unsigned) old_code)
 822                 && (old_value <
 823                     ((unsigned) old_code + nwords * sizeof(lispobj))))
 824                 /* So add the dispacement. */
 825                 *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
 826                     + displacement;
 827             else
 828                 /* It is outside the old code object so it must be a relative
 829                    fixup (absolute fixups are not saved). So subtract the
 830                    displacement. */
 831                 *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
 832                     - displacement;
 833         }
 834     }
 835
 836     /* No longer need the fixups. */
 837     new_code->constants[0] = 0;
 838
 839 #if defined(GENCGC) && (defined(i386) || defined(__x86_64))
 840     /* Check for possible errors. */
 841     sniff_code_object(new_code, displacement);
 842 #endif
 843 }
 844 #endif
 845
 846 static lispobj
 847 ptrans_code(lispobj thing)
 848 {
 849     struct code *code, *new;
 850     int nwords;
 851     lispobj func, result;
 852
 853     code = (struct code *) PTR(thing);
 854     nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
 855
 856     new = (struct code *) read_only_free;
 857     read_only_free += CEILING(nwords, 2);
 858     assert_readonly_space_bounds(read_only_free);
 859
 860     memmove(new, code, nwords * sizeof(lispobj));
 861
 862 #if (defined(i386) || defined(__x86_64))
 863     apply_code_fixups_during_purify(code, new);
 864 #endif
 865
 866     result = (lispobj) new | type_OtherPointer;
 867
 868     /* Stick in a forwarding pointer for the code object. */
 869     *(lispobj *) code = result;
 870
 871     /* Put in forwarding pointers for all the functions. */
 872     for (func = code->entry_points;
 873          func != NIL; func = ((struct function *) PTR(func))->next) {
 874
 875         gc_assert(LowtagOf(func) == type_FunctionPointer);
 876
 877         *(lispobj *) PTR(func) = result + (func - thing);
 878     }
 879
 880     /* Arrange to scavenge the debug info later. */
 881     pscav_later(&new->debug_info, 1);
 882
 883     if (new->trace_table_offset & 0x3)
 884 #if 0
 885         pscav(&new->trace_table_offset, 1, FALSE);
 886 #else
 887         new->trace_table_offset = NIL;  /* limit lifetime */
 888 #endif
 889
 890     /* Scavenge the constants. */
 891     pscav(new->constants, HeaderValue(new->header) - 5, TRUE);
 892
 893     /* Scavenge all the functions. */
 894     pscav(&new->entry_points, 1, TRUE);
 895     for (func = new->entry_points;
 896          func != NIL; func = ((struct function *) PTR(func))->next) {
 897         gc_assert(LowtagOf(func) == type_FunctionPointer);
 898         gc_assert(!dynamic_pointer_p(func));
 899
 900 #if (defined(i386) || defined(__x86_64))
 901         /* Temporarily convert the self pointer to a real function
 902            pointer. */
 903         ((struct function *) PTR(func))->self -= RAW_ADDR_OFFSET;
 904 #endif
 905         pscav(&((struct function *) PTR(func))->self, 2, TRUE);
 906 #if (defined(i386) || defined(__x86_64))
 907         ((struct function *) PTR(func))->self += RAW_ADDR_OFFSET;
 908 #endif
 909         pscav_later(&((struct function *) PTR(func))->name, 3);
 910     }
 911
 912     return result;
 913 }
 914
 915 static lispobj
 916 ptrans_func(lispobj thing, lispobj header)
 917 {
 918     int nwords;
 919     lispobj code, *new, *old, result;
 920     struct function *function;
 921
 922     /* THING can either be a function header, a closure function header, */
 923     /* a closure, or a funcallable-instance.  If it's a closure or a */
 924     /* funcallable-instance, we do the same as ptrans_boxed. */
 925     /* Otherwise we have to do something strange, 'cause it is buried inside */
 926     /* a code object. */
 927
 928     if (TypeOf(header) == type_FunctionHeader ||
 929         TypeOf(header) == type_ClosureFunctionHeader) {
 930
 931         /* We can only end up here if the code object has not been */
 932         /* scavenged, because if it had been scavenged, forwarding pointers */
 933         /* would have been left behind for all the entry points. */
 934
 935         function = (struct function *) PTR(thing);
 936         code =
 937             (PTR(thing) -
 938              (HeaderValue(function->header) *
 939               sizeof(lispobj))) | type_OtherPointer;
 940
 941         /* This will cause the function's header to be replaced with a */
 942         /* forwarding pointer. */
 943         ptrans_code(code);
 944
 945         /* So we can just return that. */
 946         return function->header;
 947     } else {
 948         /* It's some kind of closure-like thing. */
 949         nwords = 1 + HeaderValue(header);
 950         old = (lispobj *) PTR(thing);
 951
 952         /* Allocate the new one. */
 953         if (TypeOf(header) == type_FuncallableInstanceHeader) {
 954             /* FINs *must* not go in read_only space. */
 955             new = static_free;
 956             static_free += CEILING(nwords, 2);
 957             assert_static_space_bounds(static_free);
 958         } else {
 959             /* Closures can always go in read-only space, 'caues */
 960             /* they never change. */
 961
 962             new = read_only_free;
 963             read_only_free += CEILING(nwords, 2);
 964             assert_readonly_space_bounds(read_only_free);
 965         }
 966         /* Copy it. */
 967         memmove(new, old, nwords * sizeof(lispobj));
 968
 969         /* Deposit forwarding pointer. */
 970         result = (lispobj) new | LowtagOf(thing);
 971         *old = result;
 972
 973         /* Scavenge it. */
 974         pscav(new, nwords, FALSE);
 975
 976         return result;
 977     }
 978 }
 979
 980 static lispobj
 981 ptrans_returnpc(lispobj thing, lispobj header)
 982 {
 983     lispobj code, new;
 984
 985     /* Find the corresponding code object. */
 986     code = thing - HeaderValue(header) * sizeof(lispobj);
 987
 988     /* Make sure it's been transported. */
 989     new = *(lispobj *) PTR(code);
 990     if (!forwarding_pointer_p(new))
 991         new = ptrans_code(code);
 992
 993     /* Maintain the offset: */
 994     return new + (thing - code);
 995 }
 996
 997 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
 998
 999 static lispobj
1000 ptrans_list(lispobj thing, boolean constant)
1001 {
1002     struct cons *old, *new, *orig;
1003     int length;
1004
1005     if (constant)
1006         orig = (struct cons *) read_only_free;
1007     else
1008         orig = (struct cons *) static_free;
1009     length = 0;
1010
1011     do {
1012         /* Allocate a new cons cell. */
1013         old = (struct cons *) PTR(thing);
1014         if (constant) {
1015             new = (struct cons *) read_only_free;
1016             read_only_free += WORDS_PER_CONS;
1017             assert_readonly_space_bounds(read_only_free);
1018         } else {
1019             new = (struct cons *) static_free;
1020             static_free += WORDS_PER_CONS;
1021             assert_static_space_bounds(static_free);
1022         }
1023
1024         /* Copy the cons cell and keep a pointer to the cdr. */
1025         new->car = old->car;
1026         thing = new->cdr = old->cdr;
1027
1028         /* Set up the forwarding pointer. */
1029         *(lispobj *) old = ((lispobj) new) | type_ListPointer;
1030
1031         /* And count this cell. */
1032         length++;
1033     } while (LowtagOf(thing) == type_ListPointer &&
1034              dynamic_pointer_p(thing) &&
1035              !(forwarding_pointer_p(*(lispobj *) PTR(thing))));
1036
1037     /* Scavenge the list we just copied. */
1038     pscav((lispobj *) orig, length * WORDS_PER_CONS, constant);
1039
1040     return ((lispobj) orig) | type_ListPointer;
1041 }
1042
1043 static lispobj
1044 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
1045 {
1046     switch (TypeOf(header)) {
1047       case type_Bignum:
1048       case type_SingleFloat:
1049       case type_DoubleFloat:
1050 #ifdef type_LongFloat
1051       case type_LongFloat:
1052 #endif
1053 #ifdef type_DoubleDoubleFloat
1054       case type_DoubleDoubleFloat:
1055 #endif
1056 #ifdef type_ComplexSingleFloat
1057       case type_ComplexSingleFloat:
1058 #endif
1059 #ifdef type_ComplexDoubleFloat
1060       case type_ComplexDoubleFloat:
1061 #endif
1062 #ifdef type_ComplexLongFloat
1063       case type_ComplexLongFloat:
1064 #endif
1065 #ifdef type_ComplexDoubleDoubleFloat
1066       case type_ComplexDoubleDoubleFloat:
1067 #endif
1068       case type_Sap:
1069           return ptrans_unboxed(thing, header);
1070
1071       case type_Ratio:
1072       case type_Complex:
1073       case type_SimpleArray:
1074       case type_ComplexString:
1075       case type_ComplexVector:
1076       case type_ComplexArray:
1077           return ptrans_boxed(thing, header, constant);
1078
1079       case type_ValueCellHeader:
1080       case type_WeakPointer:
1081 #ifdef type_ScavengerHook
1082       case type_ScavengerHook:
1083 #endif
1084           return ptrans_boxed(thing, header, FALSE);
1085
1086       case type_SymbolHeader:
1087           return ptrans_boxed(thing, header, FALSE);
1088
1089       case type_SimpleString:
1090 #ifndef UNICODE
1091           return ptrans_vector(thing, 8, 1, FALSE, constant);
1092 #else
1093           return ptrans_vector(thing, 16, 1, FALSE, constant);
1094 #endif
1095       case type_SimpleBitVector:
1096           return ptrans_vector(thing, 1, 0, FALSE, constant);
1097
1098       case type_SimpleVector:
1099 #ifdef __x86_64
1100           return ptrans_vector(thing, 64, 0, TRUE, constant);
1101 #else
1102           return ptrans_vector(thing, 32, 0, TRUE, constant);
1103 #endif
1104
1105       case type_SimpleArrayUnsignedByte2:
1106           return ptrans_vector(thing, 2, 0, FALSE, constant);
1107
1108       case type_SimpleArrayUnsignedByte4:
1109           return ptrans_vector(thing, 4, 0, FALSE, constant);
1110
1111       case type_SimpleArrayUnsignedByte8:
1112 #ifdef type_SimpleArraySignedByte8
1113       case type_SimpleArraySignedByte8:
1114 #endif
1115           return ptrans_vector(thing, 8, 0, FALSE, constant);
1116
1117       case type_SimpleArrayUnsignedByte16:
1118 #ifdef type_SimpleArraySignedByte16
1119       case type_SimpleArraySignedByte16:
1120 #endif
1121           return ptrans_vector(thing, 16, 0, FALSE, constant);
1122
1123       case type_SimpleArrayUnsignedByte32:
1124 #ifdef type_SimpleArraySignedByte30
1125       case type_SimpleArraySignedByte30:
1126 #endif
1127 #ifdef type_SimpleArraySignedByte32
1128       case type_SimpleArraySignedByte32:
1129 #endif
1130           return ptrans_vector(thing, 32, 0, FALSE, constant);
1131
1132       case type_SimpleArraySingleFloat:
1133           return ptrans_vector(thing, 32, 0, FALSE, constant);
1134
1135       case type_SimpleArrayDoubleFloat:
1136           return ptrans_vector(thing, 64, 0, FALSE, constant);
1137
1138 #ifdef type_SimpleArrayLongFloat
1139       case type_SimpleArrayLongFloat:
1140 #if (defined(i386) || defined(__x86_64))
1141           return ptrans_vector(thing, 96, 0, FALSE, constant);
1142 #endif
1143 #ifdef sparc
1144           return ptrans_vector(thing, 128, 0, FALSE, constant);
1145 #endif
1146 #endif
1147
1148 #ifdef type_SimpleArrayDoubleDoubleFloat
1149     case type_SimpleArrayDoubleDoubleFloat:
1150       return ptrans_vector(thing, 128, 0, FALSE, constant);
1151 #endif
1152
1153 #ifdef type_SimpleArrayComplexSingleFloat
1154       case type_SimpleArrayComplexSingleFloat:
1155           return ptrans_vector(thing, 64, 0, FALSE, constant);
1156 #endif
1157
1158 #ifdef type_SimpleArrayComplexDoubleFloat
1159       case type_SimpleArrayComplexDoubleFloat:
1160           return ptrans_vector(thing, 128, 0, FALSE, constant);
1161 #endif
1162
1163 #ifdef type_SimpleArrayComplexLongFloat
1164       case type_SimpleArrayComplexLongFloat:
1165 #if (defined(i386) || defined(__x86_64))
1166           return ptrans_vector(thing, 192, 0, FALSE, constant);
1167 #endif
1168 #ifdef sparc
1169           return ptrans_vector(thing, 256, 0, FALSE, constant);
1170 #endif
1171 #endif
1172
1173 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
1174       case type_SimpleArrayComplexDoubleDoubleFloat:
1175           return ptrans_vector(thing, 256, 0, FALSE, constant);
1176 #endif
1177
1178
1179       case type_CodeHeader:
1180           return ptrans_code(thing);
1181
1182       case type_ReturnPcHeader:
1183           return ptrans_returnpc(thing, header);
1184
1185       case type_Fdefn:
1186           return ptrans_fdefn(thing, header);
1187
1188       default:
1189           /* Should only come across other pointers to the above stuff. */
1190           gc_abort();
1191           return NIL;
1192     }
1193 }
1194
1195 static int
1196 pscav_fdefn(struct fdefn *fdefn)
1197 {
1198     boolean fix_func;
1199
1200     fix_func =
1201         ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr);
1202     pscav(&fdefn->name, 1, TRUE);
1203     pscav(&fdefn->function, 1, FALSE);
1204     if (fix_func)
1205         fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
1206     return sizeof(struct fdefn) / sizeof(lispobj);
1207 }
1208
1209 #if (defined(i386) || defined(__x86_64))
1210 /* now putting code objects in static space */
1211 static int
1212 pscav_code(struct code *code)
1213 {
1214     int nwords;
1215     lispobj func;
1216
1217     nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
1218
1219     /* pw--The trace_table_offset slot can contain a list pointer. This
1220      * occurs when the code object is a top level form that initializes
1221      * a byte-compiled function. The fact that purify was ignoring this
1222      * slot may be a bug unrelated to the x86 port, except that TLF's
1223      * normally become unreachable after the loader calls them and
1224      * won't be seen by purify at all!!
1225      */
1226     if (code->trace_table_offset & 0x3)
1227 #if 0
1228         pscav(&code->trace_table_offset, 1, FALSE);
1229 #else
1230         code->trace_table_offset = NIL; /* limit lifetime */
1231 #endif
1232
1233     /* Arrange to scavenge the debug info later. */
1234     pscav_later(&code->debug_info, 1);
1235
1236     /* Scavenge the constants. */
1237     pscav(code->constants, HeaderValue(code->header) - 5, TRUE);
1238
1239     /* Scavenge all the functions. */
1240     pscav(&code->entry_points, 1, TRUE);
1241     for (func = code->entry_points;
1242          func != NIL; func = ((struct function *) PTR(func))->next) {
1243         gc_assert(LowtagOf(func) == type_FunctionPointer);
1244         gc_assert(!dynamic_pointer_p(func));
1245
1246         /* Temporarly convert the self pointer to a real function
1247            pointer. */
1248         ((struct function *) PTR(func))->self -= RAW_ADDR_OFFSET;
1249         pscav(&((struct function *) PTR(func))->self, 2, TRUE);
1250         ((struct function *) PTR(func))->self += RAW_ADDR_OFFSET;
1251         pscav_later(&((struct function *) PTR(func))->name, 3);
1252     }
1253
1254     return CEILING(nwords, 2);
1255 }
1256 #endif
1257
1258 #ifdef type_ScavengerHook
1259 static struct scavenger_hook *scavenger_hooks = (void *) NIL;
1260
1261 static int
1262 pscav_scavenger_hook(struct scavenger_hook *scav_hook)
1263 {
1264     lispobj old_value = scav_hook->value;
1265
1266     /* Scavenge the value */
1267     pscav((lispobj *) scav_hook + 1, 1, FALSE);
1268
1269     /* Did the value object move? */
1270     if (scav_hook->value != old_value) {
1271         /* Check if this hook is already noted. */
1272         if (scav_hook->next == NULL) {
1273             scav_hook->next = scavenger_hooks;
1274             scavenger_hooks =
1275                 (struct scavenger_hook *) ((unsigned long) scav_hook |
1276                                            type_OtherPointer);
1277         }
1278     }
1279
1280     /* Scavenge the function */
1281     pscav((lispobj *) scav_hook + 2, 1, FALSE);
1282
1283     return 4;
1284 }
1285 #endif
1286
1287 static lispobj *
1288 pscav(lispobj * addr, int nwords, boolean constant)
1289 {
1290     lispobj thing, *thingp, header;
1291     int count = 0;
1292     struct vector *vector;
1293
1294     while (nwords > 0) {
1295         thing = *addr;
1296         if (Pointerp(thing)) {
1297             /* It's a pointer.  Is it something we might have to move? */
1298             if (dynamic_pointer_p(thing)) {
1299                 /* Maybe.  Have we already moved it? */
1300                 thingp = (lispobj *) PTR(thing);
1301                 header = *thingp;
1302                 if (Pointerp(header) && forwarding_pointer_p(header))
1303                     /* Yep, so just copy the forwarding pointer. */
1304                     thing = header;
1305                 else {
1306                     /* Nope, copy the object. */
1307                     switch (LowtagOf(thing)) {
1308                       case type_FunctionPointer:
1309                           thing = ptrans_func(thing, header);
1310                           break;
1311
1312                       case type_ListPointer:
1313                           thing = ptrans_list(thing, constant);
1314                           break;
1315
1316                       case type_InstancePointer:
1317                           thing = ptrans_instance(thing, header, constant);
1318                           break;
1319
1320                       case type_OtherPointer:
1321                           thing = ptrans_otherptr(thing, header, constant);
1322                           break;
1323
1324                       default:
1325                           /* It was a pointer, but not one of them? */
1326                           gc_abort();
1327                     }
1328                 }
1329                 *addr = thing;
1330             }
1331             count = 1;
1332         } else if (thing & 3) {
1333             /* It's an other immediate.  Maybe the header for an unboxed */
1334             /* object. */
1335             switch (TypeOf(thing)) {
1336               case type_Bignum:
1337               case type_SingleFloat:
1338               case type_DoubleFloat:
1339 #ifdef type_LongFloat
1340               case type_LongFloat:
1341 #endif
1342 #ifdef type_DoubleDoubleFloat
1343               case type_DoubleDoubleFloat:
1344 #endif
1345               case type_Sap:
1346                   /* It's an unboxed simple object. */
1347                   count = HeaderValue(thing) + 1;
1348                   break;
1349
1350               case type_SimpleVector:
1351                   if (HeaderValue(thing) == subtype_VectorValidHashing)
1352                       *addr = (subtype_VectorMustRehash << type_Bits) |
1353                           type_SimpleVector;
1354                   count = 1;
1355                   break;
1356
1357               case type_SimpleString:
1358                   vector = (struct vector *) addr;
1359 #ifdef __x86_64
1360                   count =
1361                       CEILING(NWORDS(fixnum_value(vector->length) + 1, 8) + 2,
1362                               2);
1363 #else
1364                   count =
1365 #ifndef UNICODE
1366                       CEILING(NWORDS(fixnum_value(vector->length) + 1, 4) + 2,
1367                               2);
1368 #else
1369                       CEILING(NWORDS(fixnum_value(vector->length) + 1, 2) + 2,
1370                               2);
1371 #endif
1372 #endif
1373                   break;
1374
1375               case type_SimpleBitVector:
1376                   vector = (struct vector *) addr;
1377 #ifdef __x86_64
1378                   count =
1379                       CEILING(NWORDS(fixnum_value(vector->length), 64) + 2, 2);
1380 #else
1381                   count =
1382                       CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, 2);
1383 #endif
1384                   break;
1385
1386               case type_SimpleArrayUnsignedByte2:
1387                   vector = (struct vector *) addr;
1388 #ifdef __x86_64
1389                   count =
1390                       CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, 2);
1391 #else
1392                   count =
1393                       CEILING(NWORDS(fixnum_value(vector->length), 16) + 2, 2);
1394 #endif
1395                   break;
1396
1397               case type_SimpleArrayUnsignedByte4:
1398                   vector = (struct vector *) addr;
1399 #ifdef __x86_64
1400                   count =
1401                       CEILING(NWORDS(fixnum_value(vector->length), 16) + 2, 2);
1402 #else
1403                   count =
1404                       CEILING(NWORDS(fixnum_value(vector->length), 8) + 2, 2);
1405 #endif
1406                   break;
1407
1408               case type_SimpleArrayUnsignedByte8:
1409 #ifdef type_SimpleArraySignedByte8
1410               case type_SimpleArraySignedByte8:
1411 #endif
1412                   vector = (struct vector *) addr;
1413 #ifdef __x86_64
1414                   count =
1415                       CEILING(NWORDS(fixnum_value(vector->length), 8) + 2, 2);
1416 #else
1417                   count =
1418                       CEILING(NWORDS(fixnum_value(vector->length), 4) + 2, 2);
1419 #endif
1420                   break;
1421
1422               case type_SimpleArrayUnsignedByte16:
1423 #ifdef type_SimpleArraySignedByte16
1424               case type_SimpleArraySignedByte16:
1425 #endif
1426                   vector = (struct vector *) addr;
1427 #ifdef __x86_64
1428                   count =
1429                       CEILING(NWORDS(fixnum_value(vector->length), 4) + 2, 2);
1430 #else
1431                   count =
1432                       CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1433 #endif
1434                   break;
1435
1436               case type_SimpleArrayUnsignedByte32:
1437 #ifdef type_SimpleArraySignedByte30
1438               case type_SimpleArraySignedByte30:
1439 #endif
1440 #ifdef type_SimpleArraySignedByte32
1441               case type_SimpleArraySignedByte32:
1442 #endif
1443                   vector = (struct vector *) addr;
1444 #ifdef __x86_64
1445                   count =
1446                       CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1447 #else
1448                   count = CEILING(fixnum_value(vector->length) + 2, 2);
1449 #endif
1450                   break;
1451
1452               case type_SimpleArraySingleFloat:
1453                   vector = (struct vector *) addr;
1454 #ifdef __x86_64
1455                   count =
1456                       CEILING(NWORDS(fixnum_value(vector->length), 2) + 2, 2);
1457 #else
1458                   count = CEILING(fixnum_value(vector->length) + 2, 2);
1459 #endif
1460                   break;
1461
1462               case type_SimpleArrayDoubleFloat:
1463 #ifdef type_SimpleArrayComplexSingleFloat
1464               case type_SimpleArrayComplexSingleFloat:
1465 #endif
1466                   vector = (struct vector *) addr;
1467 #ifdef __x86_64
1468                   count = CEILING(fixnum_value(vector->length) + 2, 2);
1469 #else
1470                   count = fixnum_value(vector->length) * 2 + 2;
1471 #endif
1472                   break;
1473
1474 #ifdef type_SimpleArrayLongFloat
1475               case type_SimpleArrayLongFloat:
1476                   vector = (struct vector *) addr;
1477 #ifdef i386
1478                   count = fixnum_value(vector->length) * 3 + 2;
1479 #endif
1480 #ifdef __x86_64
1481                   count = fixnum_value(vector->length) * 2 + 2;
1482 #endif
1483 #ifdef sparc
1484                   count = fixnum_value(vector->length) * 4 + 2;
1485 #endif
1486                   break;
1487 #endif
1488
1489 #ifdef type_SimpleArrayComplexDoubleFloat
1490               case type_SimpleArrayComplexDoubleFloat:
1491                   vector = (struct vector *) addr;
1492 #ifdef __x86_64
1493                   count = fixnum_value(vector->length) * 2 + 2;
1494 #else
1495                   count = fixnum_value(vector->length) * 4 + 2;
1496 #endif
1497                   break;
1498 #endif
1499
1500 #ifdef type_SimpleArrayComplexLongFloat
1501               case type_SimpleArrayComplexLongFloat:
1502                   vector = (struct vector *) addr;
1503 #ifdef i386
1504                   count = fixnum_value(vector->length) * 6 + 2;
1505 #endif
1506 #ifdef __x86_64
1507                   count = fixnum_value(vector->length) * 4 + 2;
1508 #endif
1509 #ifdef sparc
1510                   count = fixnum_value(vector->length) * 8 + 2;
1511 #endif
1512                   break;
1513 #endif
1514
1515 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
1516               case type_SimpleArrayComplexDoubleDoubleFloat:
1517                   vector = (struct vector *) addr;
1518                   count = fixnum_value(vector->length) * 8 + 2;
1519                   break;
1520 #endif
1521
1522               case type_CodeHeader:
1523 #if !(defined(i386) || defined(__x86_64))
1524                   gc_abort();   /* No code headers in static space */
1525 #else
1526                   count = pscav_code((struct code *) addr);
1527 #endif
1528                   break;
1529
1530               case type_FunctionHeader:
1531               case type_ClosureFunctionHeader:
1532               case type_ReturnPcHeader:
1533                   /* We should never hit any of these, 'cause they occur */
1534                   /* buried in the middle of code objects. */
1535
1536                   gc_abort();
1537
1538
1539                   break;
1540
1541 #if (defined(i386) || defined(__x86_64))
1542               case type_ClosureHeader:
1543               case type_FuncallableInstanceHeader:
1544               case type_ByteCodeFunction:
1545               case type_ByteCodeClosure:
1546 #ifdef type_DylanFunctionHeader
1547               case type_DylanFunctionHeader:
1548 #endif
1549                   /* The function self pointer needs special care on the
1550                      x86 because it is the real entry point. */
1551                   {
1552                       lispobj fun = ((struct closure *) addr)->function
1553
1554                           - RAW_ADDR_OFFSET;
1555                       pscav(&fun, 1, constant);
1556                       ((struct closure *) addr)->function = fun + RAW_ADDR_OFFSET;
1557                   }
1558                   count = 2;
1559                   break;
1560 #endif
1561
1562               case type_WeakPointer:
1563                   /* Weak pointers get preserved during purify, 'cause I don't */
1564                   /* feel like figuring out how to break them. */
1565                   pscav(addr + 1, 2, constant);
1566                   count = 4;
1567                   break;
1568
1569               case type_Fdefn:
1570                   /* We have to handle fdefn objects specially, so we can fix */
1571                   /* up the raw function address. */
1572                   count = pscav_fdefn((struct fdefn *) addr);
1573                   break;
1574
1575 #ifdef type_ScavengerHook
1576               case type_ScavengerHook:
1577                   count = pscav_scavenger_hook((struct scavenger_hook *) addr);
1578                   break;
1579 #endif
1580
1581               default:
1582                   count = 1;
1583                   break;
1584             }
1585         } else {
1586             /* It's a fixnum. */
1587             count = 1;
1588         }
1589
1590         addr += count;
1591         nwords -= count;
1592     }
1593
1594     return addr;
1595 }
1596
1597 int
1598 purify(lispobj static_roots, lispobj read_only_roots)
1599 {
1600     lispobj *clean;
1601     int count, i;
1602     struct later *laters, *next;
1603
1604 #ifdef PRINTNOISE
1605     printf("[Doing purification:");
1606     fflush(stdout);
1607 #endif
1608
1609     if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
1610         printf(" Ack! Can't purify interrupt contexts. ");
1611         fflush(stdout);
1612         return 0;
1613     }
1614 #if defined(ibmrt) || defined(i386) || defined(__x86_64)
1615     current_dynamic_space_free_pointer =
1616         (lispobj *) SymbolValue(ALLOCATION_POINTER);
1617 #endif
1618
1619     read_only_end = read_only_free =
1620         (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1621     static_end = static_free =
1622         (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
1623
1624 #ifdef PRINTNOISE
1625     printf(" roots");
1626     fflush(stdout);
1627 #endif
1628
1629 #ifdef GENCGC
1630 #if (defined(i386) || defined(__x86_64))
1631     gc_assert(control_stack_end > ((&read_only_roots) + 1));
1632     setup_i386_stack_scav(((&static_roots) - 2), control_stack_end);
1633 #elif defined(sparc)
1634 #endif
1635 #endif
1636
1637     pscav(&static_roots, 1, FALSE);
1638     pscav(&read_only_roots, 1, TRUE);
1639
1640 #ifdef PRINTNOISE
1641     printf(" handlers");
1642     fflush(stdout);
1643 #endif
1644     pscav((lispobj *) interrupt_handlers,
1645           sizeof(interrupt_handlers) / sizeof(lispobj), FALSE);
1646
1647 #ifdef PRINTNOISE
1648     printf(" stack");
1649     fflush(stdout);
1650 #endif
1651 #if !(defined(i386) || defined(__x86_64))
1652     pscav(control_stack, current_control_stack_pointer - control_stack, FALSE);
1653 #else
1654 #ifdef GENCGC
1655     pscav_i386_stack();
1656 #endif
1657 #ifdef WANT_CGC
1658     gc_assert(control_stack_end > ((&read_only_roots) + 1));
1659     carefully_pscav_stack(((&read_only_roots) + 1), control_stack_end);
1660 #endif
1661 #endif
1662
1663 #ifdef PRINTNOISE
1664     printf(" bindings");
1665     fflush(stdout);
1666 #endif
1667 #if !defined(ibmrt) && !defined(i386) && !defined(__x86_64)
1668     pscav(binding_stack, current_binding_stack_pointer - binding_stack, FALSE);
1669 #else
1670     pscav(binding_stack,
1671           (lispobj *) SymbolValue(BINDING_STACK_POINTER) - binding_stack,
1672           FALSE);
1673 #endif
1674
1675 #ifdef SCAVENGE_READ_ONLY_SPACE
1676     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
1677         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1678         unsigned read_only_space_size =
1679             (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1680
1681             read_only_space;
1682         fprintf(stderr, "Scavenge read only space: %lu bytes\n",
1683                 (unsigned long) (read_only_space_size * sizeof(lispobj)));
1684         pscav(read_only_space, read_only_space_size, FALSE);
1685     }
1686 #endif
1687
1688 #ifdef PRINTNOISE
1689     printf(" static");
1690     fflush(stdout);
1691 #endif
1692     clean = static_space;
1693     do {
1694         while (clean < static_free)
1695           clean = pscav(clean, static_free - clean, FALSE);
1696         if (clean != static_free) {
1697             fprintf(stderr, "*** clean (%p) != static_free (%p)\n",
1698                     clean, static_free);
1699             fprintf(stderr, "    Possible heap corruption?\n");
1700         }
1701
1702         laters = later_blocks;
1703         count = later_count;
1704         later_blocks = NULL;
1705         later_count = 0;
1706         while (laters != NULL) {
1707             for (i = 0; i < count; i++) {
1708                 if (laters->u[i].count == 0);
1709                 else if (laters->u[i].count <= LATERMAXCOUNT) {
1710                     pscav(laters->u[i + 1].ptr, laters->u[i].count, TRUE);
1711                     i++;
1712                 } else
1713                     pscav(laters->u[i].ptr, 1, TRUE);
1714             }
1715             next = laters->next;
1716             free(laters);
1717             laters = next;
1718             count = LATERBLOCKSIZE;
1719         }
1720     } while (clean < static_free || later_blocks != NULL);
1721
1722     if (clean != static_free) {
1723         fprintf(stderr, "*** clean (%p) != static_free (%p)\n",
1724                 clean, static_free);
1725         fprintf(stderr, "    Possible heap corruption?\n");
1726     }
1727
1728
1729
1730 #ifdef PRINTNOISE
1731     printf(" cleanup");
1732     fflush(stdout);
1733 #endif
1734
1735 #if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
1736     if (SymbolValue(X86_CGC_ACTIVE_P) != T)
1737         os_zero((os_vm_address_t) current_dynamic_space,
1738                 (os_vm_size_t) dynamic_space_size);
1739 #else
1740 #if !defined(GENCGC)
1741     os_zero((os_vm_address_t) current_dynamic_space,
1742             (os_vm_size_t) dynamic_space_size);
1743 #endif
1744 #endif
1745
1746     /*
1747      * Zero stack. Note the stack is also zeroed by sub-gc calling
1748      * scrub-control-stack - this zeros the stack on the x86.
1749      */
1750 #if !(defined(i386) || defined(__x86_64))
1751     os_zero((os_vm_address_t) current_control_stack_pointer,
1752             (os_vm_size_t) (control_stack_size -
1753                             ((current_control_stack_pointer - control_stack) *
1754                              sizeof(lispobj))));
1755 #endif
1756
1757 #if defined(WANT_CGC) && defined(STATIC_BLUE_BAG)
1758     {
1759         lispobj bag = SymbolValue(STATIC_BLUE_BAG);
1760         struct cons *cons = (struct cons *) static_free;
1761         struct cons *pair = cons + 1;
1762
1763         static_free += 2 * WORDS_PER_CONS;
1764         if (bag == type_UnboundMarker)
1765             bag = NIL;
1766         cons->cdr = bag;
1767         cons->car = (lispobj) pair | type_ListPointer;
1768         pair->car = (lispobj) static_end;
1769         pair->cdr = (lispobj) static_free;
1770         bag = (lispobj) cons | type_ListPointer;
1771         SetSymbolValue(STATIC_BLUE_BAG, bag);
1772     }
1773 #endif
1774
1775     /*
1776      * It helps to update the heap free pointers so that free_heap can
1777      * verify after it's done.
1778      */
1779     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj) read_only_free);
1780     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj) static_free);
1781
1782 #if 0
1783     /*
1784      * Test the static space for validity.  This was useful in
1785      * catching some corruption problems on x86.  Should we enable
1786      * this all the time?
1787      */
1788     verify_space((lispobj *) static_space, static_free - static_space);
1789 #endif
1790
1791 #if !defined(ibmrt) && !defined(i386) && !defined(__x86_64) && !((defined(sparc) || (defined(DARWIN) && defined(__ppc__))) && defined(GENCGC))
1792     current_dynamic_space_free_pointer = current_dynamic_space;
1793 #else
1794 #if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
1795     /* X86 using CGC */
1796     if (SymbolValue(X86_CGC_ACTIVE_P) != T)
1797         SetSymbolValue(ALLOCATION_POINTER, (lispobj) current_dynamic_space);
1798     else
1799         cgc_free_heap();
1800 #else
1801 #ifdef GENCGC
1802     gc_free_heap();
1803 #else
1804     /* ibmrt using GC */
1805     SetSymbolValue(ALLOCATION_POINTER, (lispobj) current_dynamic_space);
1806 #endif
1807 #endif
1808 #endif
1809
1810 #ifdef type_ScavengerHook
1811     /* Call the scavenger hook functions */
1812     {
1813         struct scavenger_hook *sh;
1814
1815         for (sh = (struct scavenger_hook *) PTR((int) scavenger_hooks);
1816              (lispobj) sh != PTR(NIL);) {
1817             struct scavenger_hook *sh_next =
1818                 (struct scavenger_hook *) PTR((unsigned long) sh->next);
1819
1820             funcall0(sh->function);
1821             sh->next = NULL;
1822             sh = sh_next;
1823         }
1824         scavenger_hooks = (struct scavenger_hook *) NIL;
1825     }
1826 #endif
1827
1828 #ifdef PRINTNOISE
1829     printf(" Done.]\n");
1830     fflush(stdout);
1831 #endif
1832
1833     return 0;
1834 }