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