src/lisp/gc.c

   1 /*
   2  * Stop and Copy GC based on Cheney's algorithm.
   3  *
   4  * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.c,v 1.26 2007/01/01 11:53:03 cshapiro Rel $
   5  *
   6  * Written by Christopher Hoover.
   7  */
   8
   9 #include <stdio.h>
  10 #include <sys/time.h>
  11 #include <sys/resource.h>
  12 #include <signal.h>
  13 #include "lisp.h"
  14 #include "internals.h"
  15 #include "os.h"
  16 #include "gc.h"
  17 #include "globals.h"
  18 #include "interrupt.h"
  19 #include "validate.h"
  20 #include "lispregs.h"
  21 #include "interr.h"
  22
  23 static lispobj *from_space;
  24 static lispobj *from_space_free_pointer;
  25
  26 static lispobj *new_space;
  27 static lispobj *new_space_free_pointer;
  28
  29 static int (*scavtab[256]) (lispobj * where, lispobj object);
  30 static lispobj(*transother[256]) (lispobj object);
  31 static int (*sizetab[256]) (lispobj * where);
  32
  33 static struct weak_pointer *weak_pointers;
  34
  35 static void scavenge(lispobj * start, long nwords);
  36 static void scavenge_newspace(void);
  37 static void scavenge_interrupt_contexts(void);
  38 static void scan_weak_pointers(void);
  39
  40 #define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \
  41                         __FILE__, __LINE__)
  42
  43 #if DEBUG
  44 #define gc_assert(ex) do { \
  45         if (!(ex)) gc_abort(); \
  46 } while (0)
  47 #else
  48 #define gc_assert(ex)
  49 #endif
  50
  51 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
  52 \f
  53
  54 /* Predicates */
  55
  56 #if defined(DEBUG_SPACE_PREDICATES)
  57
  58 boolean
  59 from_space_p(lispobj object)
  60 {
  61     lispobj *ptr;
  62
  63     ptr = (lispobj *) PTR(object);
  64
  65     return ((from_space <= ptr) && (ptr < from_space_free_pointer));
  66 }
  67
  68 boolean
  69 new_space_p(lispobj object)
  70 {
  71     lispobj *ptr;
  72
  73     gc_assert(Pointerp(object));
  74
  75     ptr = (lispobj *) PTR(object);
  76
  77     return ((new_space <= ptr) && (ptr < new_space_free_pointer));
  78 }
  79
  80 #else
  81
  82 #define from_space_p(ptr) \
  83         ((from_space <= ((lispobj *) ptr)) && \
  84          (((lispobj *) ptr) < from_space_free_pointer))
  85
  86 #define new_space_p(ptr) \
  87         ((new_space <= ((lispobj *) ptr)) && \
  88          (((lispobj *) ptr) < new_space_free_pointer))
  89
  90 #endif
  91 \f
  92
  93 /* Copying Objects */
  94
  95 static lispobj
  96 copy_object(lispobj object, int nwords)
  97 {
  98     int tag;
  99     lispobj *new;
 100     lispobj *source, *dest;
 101
 102     gc_assert(Pointerp(object));
 103     gc_assert(from_space_p(object));
 104     gc_assert((nwords & 0x01) == 0);
 105
 106     /* get tag of object */
 107     tag = LowtagOf(object);
 108
 109     /* allocate space */
 110     new = new_space_free_pointer;
 111     new_space_free_pointer += nwords;
 112
 113     dest = new;
 114     source = (lispobj *) PTR(object);
 115
 116     /* copy the object */
 117     while (nwords > 0) {
 118         dest[0] = source[0];
 119         dest[1] = source[1];
 120         dest += 2;
 121         source += 2;
 122         nwords -= 2;
 123     }
 124
 125     /* return lisp pointer of new object */
 126     return ((lispobj) new) | tag;
 127 }
 128 \f
 129
 130 /* Collect Garbage */
 131
 132 #ifdef PRINTNOISE
 133 static double
 134 tv_diff(struct timeval *x, struct timeval *y)
 135 {
 136     return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
 137             ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
 138 }
 139 #endif
 140
 141 #define BYTES_ZERO_BEFORE_END (1<<12)
 142
 143 static void
 144 zero_stack(void)
 145 {
 146 #ifndef alpha
 147     unsigned long *ptr = (unsigned long *) current_control_stack_pointer;
 148 #else
 149     u32 *ptr = (u32 *) current_control_stack_pointer;
 150 #endif
 151   search:
 152     do {
 153         if (*ptr)
 154             goto fill;
 155         ptr++;
 156 #ifndef alpha
 157     } while (((unsigned long) ptr) & (BYTES_ZERO_BEFORE_END - 1));
 158 #else
 159     } while (((u32) ptr) & (BYTES_ZERO_BEFORE_END - 1));
 160 #endif
 161     return;
 162
 163   fill:
 164     do {
 165         *ptr++ = 0;
 166 #ifndef alpha
 167     } while (((unsigned long) ptr) & (BYTES_ZERO_BEFORE_END - 1));
 168 #else
 169     } while (((u32) ptr) & (BYTES_ZERO_BEFORE_END - 1));
 170 #endif
 171     goto search;
 172 }
 173
 174 void
 175 collect_garbage(void)
 176 {
 177 #ifdef PRINTNOISE
 178     struct timeval start_tv, stop_tv;
 179     struct rusage start_rusage, stop_rusage;
 180     double real_time, system_time, user_time;
 181     double percent_retained, gc_rate;
 182     unsigned long size_discarded;
 183     unsigned long size_retained;
 184 #endif
 185     lispobj *current_static_space_free_pointer;
 186     unsigned long static_space_size;
 187     unsigned long control_stack_size, binding_stack_size;
 188
 189     sigset_t tmp, old;
 190
 191     SAVE_CONTEXT();
 192
 193 #ifdef PRINTNOISE
 194     printf("[Collecting garbage ... \n");
 195
 196     getrusage(RUSAGE_SELF, &start_rusage);
 197     gettimeofday(&start_tv, (struct timezone *) 0);
 198 #endif
 199
 200     sigemptyset(&tmp);
 201     FILLBLOCKSET(&tmp);
 202     sigprocmask(SIG_BLOCK, &tmp, &old);
 203
 204     current_static_space_free_pointer =
 205         (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
 206
 207
 208     /* Set up from space and new space pointers. */
 209
 210     from_space = current_dynamic_space;
 211 #ifndef ibmrt
 212     from_space_free_pointer = current_dynamic_space_free_pointer;
 213 #else
 214     from_space_free_pointer = (lispobj *) SymbolValue(ALLOCATION_POINTER);
 215 #endif
 216
 217     if (current_dynamic_space == dynamic_0_space)
 218         new_space = dynamic_1_space;
 219     else if (current_dynamic_space == dynamic_1_space)
 220         new_space = dynamic_0_space;
 221     else
 222         lose("GC lossage.  Current dynamic space is bogus!\n");
 223
 224     new_space_free_pointer = new_space;
 225
 226
 227     /* Initialize the weak pointer list. */
 228     weak_pointers = (struct weak_pointer *) NULL;
 229
 230
 231     /* Scavenge all of the roots. */
 232 #ifdef PRINTNOISE
 233     printf("Scavenging interrupt contexts ...\n");
 234 #endif
 235     scavenge_interrupt_contexts();
 236
 237 #ifdef PRINTNOISE
 238     printf("Scavenging interrupt handlers (%d bytes) ...\n",
 239            sizeof(interrupt_handlers));
 240 #endif
 241     scavenge((lispobj *) interrupt_handlers,
 242              sizeof(interrupt_handlers) / sizeof(lispobj));
 243
 244     control_stack_size = current_control_stack_pointer - control_stack;
 245 #ifdef PRINTNOISE
 246     printf("Scavenging the control stack (%d bytes) ...\n",
 247            control_stack_size * sizeof(lispobj));
 248 #endif
 249     scavenge(control_stack, control_stack_size);
 250
 251 #ifndef ibmrt
 252     binding_stack_size = current_binding_stack_pointer - binding_stack;
 253 #else
 254     binding_stack_size =
 255         (lispobj *) SymbolValue(BINDING_STACK_POINTER) - binding_stack;
 256 #endif
 257 #ifdef PRINTNOISE
 258     printf("Scavenging the binding stack (%d bytes) ...\n",
 259            binding_stack_size * sizeof(lispobj));
 260 #endif
 261     scavenge(binding_stack, binding_stack_size);
 262
 263     static_space_size = current_static_space_free_pointer - static_space;
 264 #ifdef PRINTNOISE
 265     printf("Scavenging static space (%d bytes) ...\n",
 266            static_space_size * sizeof(lispobj));
 267 #endif
 268     scavenge(static_space, static_space_size);
 269
 270
 271     /* Scavenge newspace. */
 272 #ifdef PRINTNOISE
 273     printf("Scavenging new space (%d bytes) ...\n",
 274            (new_space_free_pointer - new_space) * sizeof(lispobj));
 275 #endif
 276     scavenge_newspace();
 277
 278
 279 #if defined(DEBUG_PRINT_GARBAGE)
 280     print_garbage(from_space, from_space_free_pointer);
 281 #endif
 282
 283     /* Scan the weak pointers. */
 284 #ifdef PRINTNOISE
 285     printf("Scanning weak pointers ...\n");
 286 #endif
 287     scan_weak_pointers();
 288
 289
 290     /* Flip spaces. */
 291 #ifdef PRINTNOISE
 292     printf("Flipping spaces ...\n");
 293 #endif
 294
 295     os_zero((os_vm_address_t) current_dynamic_space,
 296             (os_vm_size_t) dynamic_space_size);
 297
 298     current_dynamic_space = new_space;
 299 #ifndef ibmrt
 300     current_dynamic_space_free_pointer = new_space_free_pointer;
 301 #else
 302     SetSymbolValue(ALLOCATION_POINTER, (lispobj) new_space_free_pointer);
 303 #endif
 304
 305 #ifdef PRINTNOISE
 306     size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
 307     size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
 308 #endif
 309
 310     /* Zero stack. */
 311 #ifdef PRINTNOISE
 312     printf("Zeroing empty part of control stack ...\n");
 313 #endif
 314     zero_stack();
 315
 316     sigprocmask(SIG_SETMASK, &old, 0);
 317
 318
 319 #ifdef PRINTNOISE
 320     gettimeofday(&stop_tv, (struct timezone *) 0);
 321     getrusage(RUSAGE_SELF, &stop_rusage);
 322
 323     printf("done.]\n");
 324
 325     percent_retained = (((float) size_retained) /
 326                         ((float) size_discarded)) * 100.0;
 327
 328     printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n",
 329            size_retained, size_discarded, percent_retained);
 330
 331     real_time = tv_diff(&stop_tv, &start_tv);
 332     user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
 333     system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
 334
 335 #if 0
 336     printf("Statistics:\n");
 337     printf("%10.2f sec of real time\n", real_time);
 338     printf("%10.2f sec of user time,\n", user_time);
 339     printf("%10.2f sec of system time.\n", system_time);
 340 #else
 341     printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
 342            real_time, user_time, system_time);
 343 #endif
 344
 345     gc_rate = ((float) size_retained / (float) (1 << 20)) / real_time;
 346
 347     printf("%10.2f M bytes/sec collected.\n", gc_rate);
 348 #endif
 349 }
 350 \f
 351
 352 /* Scavenging */
 353
 354 #define DIRECT_SCAV 0
 355
 356 static void
 357 scavenge(lispobj * start, long nwords)
 358 {
 359     while (nwords > 0) {
 360         lispobj object;
 361         int type, words_scavenged;
 362
 363         object = *start;
 364         type = TypeOf(object);
 365
 366 #if defined(DEBUG_SCAVENGE_VERBOSE)
 367         printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
 368                (unsigned long) start, (unsigned long) object, type);
 369 #endif
 370
 371 #if DIRECT_SCAV
 372         words_scavenged = (scavtab[type]) (start, object);
 373 #else
 374         if (Pointerp(object)) {
 375             /* It be a pointer. */
 376             if (from_space_p(object)) {
 377                 /* It currently points to old space.  Check for a */
 378                 /* forwarding pointer. */
 379                 lispobj first_word;
 380
 381                 first_word = *((lispobj *) PTR(object));
 382                 if (Pointerp(first_word) && new_space_p(first_word)) {
 383                     /* Yep, there be a forwarding pointer. */
 384                     *start = first_word;
 385                     words_scavenged = 1;
 386                 } else {
 387                     /* Scavenge that pointer. */
 388                     words_scavenged = (scavtab[type]) (start, object);
 389                 }
 390             } else {
 391                 /* It points somewhere other than oldspace.  Leave */
 392                 /* it alone. */
 393                 words_scavenged = 1;
 394             }
 395         } else if ((object & 3) == 0) {
 396             /* It's a fixnum.  Real easy. */
 397             words_scavenged = 1;
 398         } else {
 399             /* It's some random header object. */
 400             words_scavenged = (scavtab[type]) (start, object);
 401         }
 402 #endif
 403
 404         start += words_scavenged;
 405         nwords -= words_scavenged;
 406     }
 407     gc_assert(nwords == 0);
 408 }
 409
 410 static void
 411 scavenge_newspace(void)
 412 {
 413     lispobj *here, *next;
 414
 415     here = new_space;
 416     while (here < new_space_free_pointer) {
 417         next = new_space_free_pointer;
 418         scavenge(here, next - here);
 419         here = next;
 420     }
 421 }
 422 \f
 423
 424 /* Scavenging Interrupt Contexts */
 425
 426 static int boxed_registers[] = BOXED_REGISTERS;
 427
 428 static void
 429 scavenge_interrupt_context(os_context_t * context)
 430 {
 431     int i;
 432
 433 #ifdef reg_LIP
 434     unsigned long lip;
 435     unsigned long lip_offset;
 436     int lip_register_pair;
 437 #endif
 438     unsigned long pc_code_offset;
 439
 440 #ifdef SC_NPC
 441     unsigned long npc_code_offset;
 442 #endif
 443
 444     /* Find the LIP's register pair and calculate it's offset */
 445     /* before we scavenge the context. */
 446 #ifdef reg_LIP
 447     lip = SC_REG(context, reg_LIP);
 448     lip_offset = 0x7FFFFFFF;
 449     lip_register_pair = -1;
 450     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 451         unsigned long reg;
 452         long offset;
 453         int index;
 454
 455         index = boxed_registers[i];
 456         reg = SC_REG(context, index);
 457         if (Pointerp(reg) && PTR(reg) <= lip) {
 458             offset = lip - reg;
 459             if (offset < lip_offset) {
 460                 lip_offset = offset;
 461                 lip_register_pair = index;
 462             }
 463         }
 464     }
 465 #endif /* reg_LIP */
 466
 467     /* Compute the PC's offset from the start of the CODE */
 468     /* register. */
 469     pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);
 470 #ifdef SC_NPC
 471     npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
 472 #endif /* SC_NPC */
 473
 474     /* Scanvenge all boxed registers in the context. */
 475     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 476         int index;
 477         lispobj foo;
 478
 479         index = boxed_registers[i];
 480         foo = SC_REG(context, index);
 481         scavenge((lispobj *) & foo, 1);
 482         SC_REG(context, index) = foo;
 483
 484         scavenge((lispobj *) & (SC_REG(context, index)), 1);
 485     }
 486
 487 #ifdef reg_LIP
 488     /* Fix the LIP */
 489     SC_REG(context, reg_LIP) = SC_REG(context, lip_register_pair) + lip_offset;
 490 #endif /* reg_LIP */
 491
 492     /* Fix the PC if it was in from space */
 493     if (from_space_p(SC_PC(context)))
 494         SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;
 495 #ifdef SC_NPC
 496     if (from_space_p(SC_NPC(context)))
 497         SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
 498 #endif /* SC_NPC */
 499 }
 500
 501 void
 502 scavenge_interrupt_contexts(void)
 503 {
 504     int i, index;
 505     os_context_t *context;
 506
 507     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
 508 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
 509     printf("Number of active contexts: %d\n", index);
 510 #endif
 511
 512     for (i = 0; i < index; i++) {
 513         context = lisp_interrupt_contexts[i];
 514         scavenge_interrupt_context(context);
 515     }
 516 }
 517 \f
 518
 519 /* Debugging Code */
 520
 521 void
 522 print_garbage(lispobj * from_space, lispobj * from_space_free_pointer)
 523 {
 524     lispobj *start;
 525     int total_words_not_copied;
 526
 527     printf("Scanning from space ...\n");
 528
 529     total_words_not_copied = 0;
 530     start = from_space;
 531     while (start < from_space_free_pointer) {
 532         lispobj object;
 533         int forwardp, type, nwords;
 534         lispobj header;
 535
 536         object = *start;
 537         forwardp = Pointerp(object) && new_space_p(object);
 538
 539         if (forwardp) {
 540             int tag;
 541             lispobj *pointer;
 542
 543             tag = LowtagOf(object);
 544
 545             switch (tag) {
 546               case type_ListPointer:
 547                   nwords = 2;
 548                   break;
 549               case type_InstancePointer:
 550                   printf("Don't know about instances yet!\n");
 551                   nwords = 1;
 552                   break;
 553               case type_FunctionPointer:
 554                   nwords = 1;
 555                   break;
 556               case type_OtherPointer:
 557                   pointer = (lispobj *) PTR(object);
 558                   header = *pointer;
 559                   type = TypeOf(header);
 560                   nwords = (sizetab[type]) (pointer);
 561             }
 562         } else {
 563             type = TypeOf(object);
 564             nwords = (sizetab[type]) (start);
 565             total_words_not_copied += nwords;
 566             printf("%4d words not copied at 0x%08x; ",
 567                    nwords, (unsigned long) start);
 568             printf("Header word is 0x%08x\n", (unsigned long) object);
 569         }
 570         start += nwords;
 571     }
 572     printf("%d total words not copied.\n", total_words_not_copied);
 573 }
 574 \f
 575
 576 /* Code and Code-Related Objects */
 577
 578 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
 579
 580 static lispobj trans_function_header(lispobj object);
 581 static lispobj trans_boxed(lispobj object);
 582
 583 #if DIRECT_SCAV
 584 static int
 585 scav_function_pointer(lispobj * where, lispobj object)
 586 {
 587     gc_assert(Pointerp(object));
 588
 589     if (from_space_p(object)) {
 590         lispobj first, *first_pointer;
 591
 592         /* object is a pointer into from space.  check to see */
 593         /* if it has been forwarded */
 594         first_pointer = (lispobj *) PTR(object);
 595         first = *first_pointer;
 596
 597         if (!(Pointerp(first) && new_space_p(first))) {
 598             int type;
 599             lispobj copy;
 600
 601             /* must transport object -- object may point */
 602             /* to either a function header, a closure */
 603             /* function header, or to a closure header. */
 604
 605             type = TypeOf(first);
 606             switch (type) {
 607               case type_FunctionHeader:
 608               case type_ClosureFunctionHeader:
 609                   copy = trans_function_header(object);
 610                   break;
 611               default:
 612                   copy = trans_boxed(object);
 613                   break;
 614             }
 615
 616             first = *first_pointer = copy;
 617         }
 618
 619         gc_assert(Pointerp(first));
 620         gc_assert(!from_space_p(first));
 621
 622         *where = first;
 623     }
 624     return 1;
 625 }
 626 #else
 627 static int
 628 scav_function_pointer(lispobj * where, lispobj object)
 629 {
 630     lispobj *first_pointer;
 631     lispobj copy;
 632     lispobj first;
 633     int type;
 634
 635     gc_assert(Pointerp(object));
 636
 637     /* object is a pointer into from space. Not a FP */
 638     first_pointer = (lispobj *) PTR(object);
 639     first = *first_pointer;
 640
 641     /* must transport object -- object may point */
 642     /* to either a function header, a closure */
 643     /* function header, or to a closure header. */
 644
 645     type = TypeOf(first);
 646     switch (type) {
 647       case type_FunctionHeader:
 648       case type_ClosureFunctionHeader:
 649           copy = trans_function_header(object);
 650           break;
 651       default:
 652           copy = trans_boxed(object);
 653           break;
 654     }
 655
 656     first = *first_pointer = copy;
 657
 658     gc_assert(Pointerp(first));
 659     gc_assert(!from_space_p(first));
 660
 661     *where = first;
 662     return 1;
 663 }
 664 #endif
 665
 666 static struct code *
 667 trans_code(struct code *code)
 668 {
 669     struct code *new_code;
 670     lispobj first, l_code, l_new_code;
 671     int nheader_words, ncode_words, nwords;
 672     unsigned long displacement;
 673     lispobj fheaderl, *prev_pointer;
 674
 675 #if defined(DEBUG_CODE_GC)
 676     printf("\nTransporting code object located at 0x%08x.\n",
 677            (unsigned long) code);
 678 #endif
 679
 680     /* if object has already been transported, just return pointer */
 681     first = code->header;
 682     if (Pointerp(first) && new_space_p(first))
 683         return (struct code *) PTR(first);
 684
 685     gc_assert(TypeOf(first) == type_CodeHeader);
 686
 687     /* prepare to transport the code vector */
 688     l_code = (lispobj) code | type_OtherPointer;
 689
 690     ncode_words = fixnum_value(code->code_size);
 691     nheader_words = HeaderValue(code->header);
 692     nwords = ncode_words + nheader_words;
 693     nwords = CEILING(nwords, 2);
 694
 695     l_new_code = copy_object(l_code, nwords);
 696     new_code = (struct code *) PTR(l_new_code);
 697
 698     displacement = l_new_code - l_code;
 699
 700 #if defined(DEBUG_CODE_GC)
 701     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 702            (unsigned long) code, (unsigned long) new_code);
 703     printf("Code object is %d words long.\n", nwords);
 704 #endif
 705
 706     /* set forwarding pointer */
 707     code->header = l_new_code;
 708
 709     /* set forwarding pointers for all the function headers in the */
 710     /* code object.  also fix all self pointers */
 711
 712     fheaderl = code->entry_points;
 713     prev_pointer = &new_code->entry_points;
 714
 715     while (fheaderl != NIL) {
 716         struct function *fheaderp, *nfheaderp;
 717         lispobj nfheaderl;
 718
 719         fheaderp = (struct function *) PTR(fheaderl);
 720         gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 721
 722         /* calcuate the new function pointer and the new */
 723         /* function header */
 724         nfheaderl = fheaderl + displacement;
 725         nfheaderp = (struct function *) PTR(nfheaderl);
 726
 727         /* set forwarding pointer */
 728         fheaderp->header = nfheaderl;
 729
 730         /* fix self pointer */
 731         nfheaderp->self = nfheaderl;
 732
 733         *prev_pointer = nfheaderl;
 734
 735         fheaderl = fheaderp->next;
 736         prev_pointer = &nfheaderp->next;
 737     }
 738
 739 #ifndef MACH
 740     os_flush_icache((os_vm_address_t) (((int *) new_code) + nheader_words),
 741                     ncode_words * sizeof(int));
 742 #endif
 743     return new_code;
 744 }
 745
 746 static int
 747 scav_code_header(lispobj * where, lispobj object)
 748 {
 749     struct code *code;
 750     int nheader_words, ncode_words, nwords;
 751     lispobj fheaderl;
 752     struct function *fheaderp;
 753
 754     code = (struct code *) where;
 755     ncode_words = fixnum_value(code->code_size);
 756     nheader_words = HeaderValue(object);
 757     nwords = ncode_words + nheader_words;
 758     nwords = CEILING(nwords, 2);
 759
 760 #if defined(DEBUG_CODE_GC)
 761     printf("\nScavening code object at 0x%08x.\n", (unsigned long) where);
 762     printf("Code object is %d words long.\n", nwords);
 763     printf("Scavenging boxed section of code data block (%d words).\n",
 764            nheader_words - 1);
 765 #endif
 766
 767     /* Scavenge the boxed section of the code data block */
 768     scavenge(where + 1, nheader_words - 1);
 769
 770     /* Scavenge the boxed section of each function object in the */
 771     /* code data block */
 772     fheaderl = code->entry_points;
 773     while (fheaderl != NIL) {
 774         fheaderp = (struct function *) PTR(fheaderl);
 775         gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 776
 777 #if defined(DEBUG_CODE_GC)
 778         printf("Scavenging boxed section of entry point located at 0x%08x.\n",
 779                (unsigned long) PTR(fheaderl));
 780 #endif
 781         scavenge(&fheaderp->name, 1);
 782         scavenge(&fheaderp->arglist, 1);
 783         scavenge(&fheaderp->type, 1);
 784
 785         fheaderl = fheaderp->next;
 786     }
 787
 788     return nwords;
 789 }
 790
 791 static lispobj
 792 trans_code_header(lispobj object)
 793 {
 794     struct code *ncode;
 795
 796     ncode = trans_code((struct code *) PTR(object));
 797     return (lispobj) ncode | type_OtherPointer;
 798 }
 799
 800 static int
 801 size_code_header(lispobj * where)
 802 {
 803     struct code *code;
 804     int nheader_words, ncode_words, nwords;
 805
 806     code = (struct code *) where;
 807
 808     ncode_words = fixnum_value(code->code_size);
 809     nheader_words = HeaderValue(code->header);
 810     nwords = ncode_words + nheader_words;
 811     nwords = CEILING(nwords, 2);
 812
 813     return nwords;
 814 }
 815
 816
 817 static int
 818 scav_return_pc_header(lispobj * where, lispobj object)
 819 {
 820     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 821     fprintf(stderr, "Return PC Header.\n");
 822     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
 823             (unsigned long) where, (unsigned long) object);
 824     lose(NULL);
 825     return 0;
 826 }
 827
 828 static lispobj
 829 trans_return_pc_header(lispobj object)
 830 {
 831     struct function *return_pc;
 832     unsigned long offset;
 833     struct code *code, *ncode;
 834
 835     return_pc = (struct function *) PTR(object);
 836     offset = HeaderValue(return_pc->header) * 4;
 837
 838     /* Transport the whole code object */
 839     code = (struct code *) ((unsigned long) return_pc - offset);
 840     ncode = trans_code(code);
 841
 842     return ((lispobj) ncode + offset) | type_OtherPointer;
 843 }
 844
 845 /* On the 386, closures hold a pointer to the raw address instead of the
 846    function object, so we can use CALL [$FDEFN+const] to invoke the function
 847    without loading it into a register.  Given that code objects don't move,
 848    we don't need to update anything, but we do have to figure out that the
 849    function is still live. */
 850 #ifdef i386
 851 static
 852 scav_closure_header(where, object)
 853      lispobj *where, object;
 854 {
 855     struct closure *closure;
 856     lispobj fun;
 857
 858     closure = (struct closure *) where;
 859     fun = closure->function - RAW_ADDR_OFFSET;
 860     scavenge(&fun, 1);
 861
 862     return 2;
 863 }
 864 #endif
 865
 866 static int
 867 scav_function_header(lispobj * where, lispobj object)
 868 {
 869     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 870     fprintf(stderr, "Function Header.\n");
 871     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
 872             (unsigned long) where, (unsigned long) object);
 873     lose(NULL);
 874     return 0;
 875 }
 876
 877 static lispobj
 878 trans_function_header(lispobj object)
 879 {
 880     struct function *fheader;
 881     unsigned long offset;
 882     struct code *code, *ncode;
 883
 884     fheader = (struct function *) PTR(object);
 885     offset = HeaderValue(fheader->header) * 4;
 886
 887     /* Transport the whole code object */
 888     code = (struct code *) ((unsigned long) fheader - offset);
 889     ncode = trans_code(code);
 890
 891     return ((lispobj) ncode + offset) | type_FunctionPointer;
 892 }
 893 \f
 894
 895
 896 /* Instances */
 897
 898 #if DIRECT_SCAV
 899 static int
 900 scav_instance_pointer(lispobj * where, lispobj object)
 901 {
 902     if (from_space_p(object)) {
 903         lispobj first, *first_pointer;
 904
 905         /* object is a pointer into from space.  check to see */
 906         /* if it has been forwarded */
 907         first_pointer = (lispobj *) PTR(object);
 908         first = *first_pointer;
 909
 910         if (!(Pointerp(first) && new_space_p(first)))
 911             first = *first_pointer = trans_boxed(object);
 912         *where = first;
 913     }
 914     return 1;
 915 }
 916 #else
 917 static int
 918 scav_instance_pointer(lispobj * where, lispobj object)
 919 {
 920     lispobj *first_pointer;
 921
 922     /* object is a pointer into from space.  Not a FP */
 923     first_pointer = (lispobj *) PTR(object);
 924
 925     *where = *first_pointer = trans_boxed(object);
 926     return 1;
 927 }
 928 #endif
 929 \f
 930
 931 /* Lists and Conses */
 932
 933 static lispobj trans_list(lispobj object);
 934
 935 #if DIRECT_SCAV
 936 static int
 937 scav_list_pointer(lispobj * where, lispobj object)
 938 {
 939     gc_assert(Pointerp(object));
 940
 941     if (from_space_p(object)) {
 942         lispobj first, *first_pointer;
 943
 944         /* object is a pointer into from space.  check to see */
 945         /* if it has been forwarded */
 946         first_pointer = (lispobj *) PTR(object);
 947         first = *first_pointer;
 948
 949         if (!(Pointerp(first) && new_space_p(first)))
 950             first = *first_pointer = trans_list(object);
 951
 952         gc_assert(Pointerp(first));
 953         gc_assert(!from_space_p(first));
 954
 955         *where = first;
 956     }
 957     return 1;
 958 }
 959 #else
 960 static int
 961 scav_list_pointer(lispobj * where, lispobj object)
 962 {
 963     lispobj first, *first_pointer;
 964
 965     gc_assert(Pointerp(object));
 966
 967     /* object is a pointer into from space.  Not a FP. */
 968     first_pointer = (lispobj *) PTR(object);
 969
 970     first = *first_pointer = trans_list(object);
 971
 972     gc_assert(Pointerp(first));
 973     gc_assert(!from_space_p(first));
 974
 975     *where = first;
 976     return 1;
 977 }
 978 #endif
 979
 980 static lispobj
 981 trans_list(lispobj object)
 982 {
 983     lispobj new_list_pointer;
 984     struct cons *cons, *new_cons;
 985
 986     cons = (struct cons *) PTR(object);
 987
 988     /* ### Don't use copy_object here. */
 989     new_list_pointer = copy_object(object, 2);
 990     new_cons = (struct cons *) PTR(new_list_pointer);
 991
 992     /* Set forwarding pointer. */
 993     cons->car = new_list_pointer;
 994
 995     /* Try to linearize the list in the cdr direction to help reduce */
 996     /* paging. */
 997
 998     while (1) {
 999         lispobj cdr, new_cdr, first;
1000         struct cons *cdr_cons, *new_cdr_cons;
1001
1002         cdr = cons->cdr;
1003
1004         if (LowtagOf(cdr) != type_ListPointer ||
1005             !from_space_p(cdr) ||
1006             (Pointerp(first = *(lispobj *) PTR(cdr)) && new_space_p(first)))
1007             break;
1008
1009         cdr_cons = (struct cons *) PTR(cdr);
1010
1011         /* ### Don't use copy_object here */
1012         new_cdr = copy_object(cdr, 2);
1013         new_cdr_cons = (struct cons *) PTR(new_cdr);
1014
1015         /* Set forwarding pointer */
1016         cdr_cons->car = new_cdr;
1017
1018         /* Update the cdr of the last cons copied into new */
1019         /* space to keep the newspace scavenge from having to */
1020         /* do it. */
1021         new_cons->cdr = new_cdr;
1022
1023         cons = cdr_cons;
1024         new_cons = new_cdr_cons;
1025     }
1026
1027     return new_list_pointer;
1028 }
1029 \f
1030
1031 /* Scavenging and Transporting Other Pointers */
1032
1033 #if DIRECT_SCAV
1034 static int
1035 scav_other_pointer(lispobj * where, lispobj object)
1036 {
1037     gc_assert(Pointerp(object));
1038
1039     if (from_space_p(object)) {
1040         lispobj first, *first_pointer;
1041
1042         /* object is a pointer into from space.  check to see */
1043         /* if it has been forwarded */
1044         first_pointer = (lispobj *) PTR(object);
1045         first = *first_pointer;
1046
1047         if (!(Pointerp(first) && new_space_p(first)))
1048             first = *first_pointer = (transother[TypeOf(first)]) (object);
1049
1050         gc_assert(Pointerp(first));
1051         gc_assert(!from_space_p(first));
1052
1053         *where = first;
1054     }
1055     return 1;
1056 }
1057 #else
1058 static int
1059 scav_other_pointer(lispobj * where, lispobj object)
1060 {
1061     lispobj first, *first_pointer;
1062
1063     gc_assert(Pointerp(object));
1064
1065     /* Object is a pointer into from space - not a FP */
1066     first_pointer = (lispobj *) PTR(object);
1067     first = *first_pointer = (transother[TypeOf(*first_pointer)]) (object);
1068
1069     gc_assert(Pointerp(first));
1070     gc_assert(!from_space_p(first));
1071
1072     *where = first;
1073     return 1;
1074 }
1075 #endif
1076 \f
1077
1078 /* Immediate, Boxed, and Unboxed Objects */
1079
1080 static int
1081 size_pointer(lispobj * where)
1082 {
1083     return 1;
1084 }
1085
1086 static int
1087 scav_immediate(lispobj * where, lispobj object)
1088 {
1089     return 1;
1090 }
1091
1092 static lispobj
1093 trans_immediate(lispobj object)
1094 {
1095     fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
1096     lose(NULL);
1097     return NIL;
1098 }
1099
1100 static int
1101 size_immediate(lispobj * where)
1102 {
1103     return 1;
1104 }
1105
1106
1107 static int
1108 scav_boxed(lispobj * where, lispobj object)
1109 {
1110     return 1;
1111 }
1112
1113 static lispobj
1114 trans_boxed(lispobj object)
1115 {
1116     lispobj header;
1117     unsigned long length;
1118
1119     gc_assert(Pointerp(object));
1120
1121     header = *((lispobj *) PTR(object));
1122     length = HeaderValue(header) + 1;
1123     length = CEILING(length, 2);
1124
1125     return copy_object(object, length);
1126 }
1127
1128 static int
1129 size_boxed(lispobj * where)
1130 {
1131     lispobj header;
1132     unsigned long length;
1133
1134     header = *where;
1135     length = HeaderValue(header) + 1;
1136     length = CEILING(length, 2);
1137
1138     return length;
1139 }
1140
1141 /* Note: on the sparc we don't have to do anything special for fdefns, */
1142 /* cause the raw-addr has a function lowtag. */
1143 #if !(defined(sparc) || defined(DARWIN))
1144 static int
1145 scav_fdefn(lispobj * where, lispobj object)
1146 {
1147     struct fdefn *fdefn;
1148
1149     fdefn = (struct fdefn *) where;
1150
1151     if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
1152         scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);
1153
1154         fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
1155         return sizeof(struct fdefn) / sizeof(lispobj);
1156     } else
1157         return 1;
1158 }
1159 #endif
1160
1161 static int
1162 scav_unboxed(lispobj * where, lispobj object)
1163 {
1164     unsigned long length;
1165
1166     length = HeaderValue(object) + 1;
1167     length = CEILING(length, 2);
1168
1169     return length;
1170 }
1171
1172 static lispobj
1173 trans_unboxed(lispobj object)
1174 {
1175     lispobj header;
1176     unsigned long length;
1177
1178
1179     gc_assert(Pointerp(object));
1180
1181     header = *((lispobj *) PTR(object));
1182     length = HeaderValue(header) + 1;
1183     length = CEILING(length, 2);
1184
1185     return copy_object(object, length);
1186 }
1187
1188 static int
1189 size_unboxed(lispobj * where)
1190 {
1191     lispobj header;
1192     unsigned long length;
1193
1194     header = *where;
1195     length = HeaderValue(header) + 1;
1196     length = CEILING(length, 2);
1197
1198     return length;
1199 }
1200 \f
1201
1202 /* Vector-Like Objects */
1203
1204 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1205
1206 static int
1207 scav_string(lispobj * where, lispobj object)
1208 {
1209     struct vector *vector;
1210     int length, nwords;
1211
1212     /* NOTE: Strings contain one more byte of data than the length */
1213     /* slot indicates. */
1214
1215     vector = (struct vector *) where;
1216     length = fixnum_value(vector->length) + 1;
1217     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1218
1219     return nwords;
1220 }
1221
1222 static lispobj
1223 trans_string(lispobj object)
1224 {
1225     struct vector *vector;
1226     int length, nwords;
1227
1228     gc_assert(Pointerp(object));
1229
1230     /* NOTE: Strings contain one more byte of data than the length */
1231     /* slot indicates. */
1232
1233     vector = (struct vector *) PTR(object);
1234     length = fixnum_value(vector->length) + 1;
1235     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1236
1237     return copy_object(object, nwords);
1238 }
1239
1240 static int
1241 size_string(lispobj * where)
1242 {
1243     struct vector *vector;
1244     int length, nwords;
1245
1246     /* NOTE: Strings contain one more byte of data than the length */
1247     /* slot indicates. */
1248
1249     vector = (struct vector *) where;
1250     length = fixnum_value(vector->length) + 1;
1251     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1252
1253     return nwords;
1254 }
1255
1256 static int
1257 scav_vector(lispobj * where, lispobj object)
1258 {
1259     if (HeaderValue(object) == subtype_VectorValidHashing)
1260         *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
1261
1262     return 1;
1263 }
1264
1265
1266 static lispobj
1267 trans_vector(lispobj object)
1268 {
1269     struct vector *vector;
1270     int length, nwords;
1271
1272     gc_assert(Pointerp(object));
1273
1274     vector = (struct vector *) PTR(object);
1275
1276     length = fixnum_value(vector->length);
1277     nwords = CEILING(length + 2, 2);
1278
1279     return copy_object(object, nwords);
1280 }
1281
1282 static int
1283 size_vector(lispobj * where)
1284 {
1285     struct vector *vector;
1286     int length, nwords;
1287
1288     vector = (struct vector *) where;
1289     length = fixnum_value(vector->length);
1290     nwords = CEILING(length + 2, 2);
1291
1292     return nwords;
1293 }
1294
1295
1296 static int
1297 scav_vector_bit(lispobj * where, lispobj object)
1298 {
1299     struct vector *vector;
1300     int length, nwords;
1301
1302     vector = (struct vector *) where;
1303     length = fixnum_value(vector->length);
1304     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1305
1306     return nwords;
1307 }
1308
1309 static lispobj
1310 trans_vector_bit(lispobj object)
1311 {
1312     struct vector *vector;
1313     int length, nwords;
1314
1315     gc_assert(Pointerp(object));
1316
1317     vector = (struct vector *) PTR(object);
1318     length = fixnum_value(vector->length);
1319     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1320
1321     return copy_object(object, nwords);
1322 }
1323
1324 static int
1325 size_vector_bit(lispobj * where)
1326 {
1327     struct vector *vector;
1328     int length, nwords;
1329
1330     vector = (struct vector *) where;
1331     length = fixnum_value(vector->length);
1332     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1333
1334     return nwords;
1335 }
1336
1337
1338 static int
1339 scav_vector_unsigned_byte_2(lispobj * where, lispobj object)
1340 {
1341     struct vector *vector;
1342     int length, nwords;
1343
1344     vector = (struct vector *) where;
1345     length = fixnum_value(vector->length);
1346     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1347
1348     return nwords;
1349 }
1350
1351 static lispobj
1352 trans_vector_unsigned_byte_2(lispobj object)
1353 {
1354     struct vector *vector;
1355     int length, nwords;
1356
1357     gc_assert(Pointerp(object));
1358
1359     vector = (struct vector *) PTR(object);
1360     length = fixnum_value(vector->length);
1361     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1362
1363     return copy_object(object, nwords);
1364 }
1365
1366 static int
1367 size_vector_unsigned_byte_2(lispobj * where)
1368 {
1369     struct vector *vector;
1370     int length, nwords;
1371
1372     vector = (struct vector *) where;
1373     length = fixnum_value(vector->length);
1374     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1375
1376     return nwords;
1377 }
1378
1379
1380 static int
1381 scav_vector_unsigned_byte_4(lispobj * where, lispobj object)
1382 {
1383     struct vector *vector;
1384     int length, nwords;
1385
1386     vector = (struct vector *) where;
1387     length = fixnum_value(vector->length);
1388     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1389
1390     return nwords;
1391 }
1392
1393 static lispobj
1394 trans_vector_unsigned_byte_4(lispobj object)
1395 {
1396     struct vector *vector;
1397     int length, nwords;
1398
1399     gc_assert(Pointerp(object));
1400
1401     vector = (struct vector *) PTR(object);
1402     length = fixnum_value(vector->length);
1403     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1404
1405     return copy_object(object, nwords);
1406 }
1407
1408 static int
1409 size_vector_unsigned_byte_4(lispobj * where)
1410 {
1411     struct vector *vector;
1412     int length, nwords;
1413
1414     vector = (struct vector *) where;
1415     length = fixnum_value(vector->length);
1416     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1417
1418     return nwords;
1419 }
1420
1421
1422 static int
1423 scav_vector_unsigned_byte_8(lispobj * where, lispobj object)
1424 {
1425     struct vector *vector;
1426     int length, nwords;
1427
1428     vector = (struct vector *) where;
1429     length = fixnum_value(vector->length);
1430     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1431
1432     return nwords;
1433 }
1434
1435 static lispobj
1436 trans_vector_unsigned_byte_8(lispobj object)
1437 {
1438     struct vector *vector;
1439     int length, nwords;
1440
1441     gc_assert(Pointerp(object));
1442
1443     vector = (struct vector *) PTR(object);
1444     length = fixnum_value(vector->length);
1445     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1446
1447     return copy_object(object, nwords);
1448 }
1449
1450 static int
1451 size_vector_unsigned_byte_8(lispobj * where)
1452 {
1453     struct vector *vector;
1454     int length, nwords;
1455
1456     vector = (struct vector *) where;
1457     length = fixnum_value(vector->length);
1458     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1459
1460     return nwords;
1461 }
1462
1463
1464 static int
1465 scav_vector_unsigned_byte_16(lispobj * where, lispobj object)
1466 {
1467     struct vector *vector;
1468     int length, nwords;
1469
1470     vector = (struct vector *) where;
1471     length = fixnum_value(vector->length);
1472     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1473
1474     return nwords;
1475 }
1476
1477 static lispobj
1478 trans_vector_unsigned_byte_16(lispobj object)
1479 {
1480     struct vector *vector;
1481     int length, nwords;
1482
1483     gc_assert(Pointerp(object));
1484
1485     vector = (struct vector *) PTR(object);
1486     length = fixnum_value(vector->length);
1487     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1488
1489     return copy_object(object, nwords);
1490 }
1491
1492 static int
1493 size_vector_unsigned_byte_16(lispobj * where)
1494 {
1495     struct vector *vector;
1496     int length, nwords;
1497
1498     vector = (struct vector *) where;
1499     length = fixnum_value(vector->length);
1500     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1501
1502     return nwords;
1503 }
1504
1505
1506 static int
1507 scav_vector_unsigned_byte_32(lispobj * where, lispobj object)
1508 {
1509     struct vector *vector;
1510     int length, nwords;
1511
1512     vector = (struct vector *) where;
1513     length = fixnum_value(vector->length);
1514     nwords = CEILING(length + 2, 2);
1515
1516     return nwords;
1517 }
1518
1519 static lispobj
1520 trans_vector_unsigned_byte_32(lispobj object)
1521 {
1522     struct vector *vector;
1523     int length, nwords;
1524
1525     gc_assert(Pointerp(object));
1526
1527     vector = (struct vector *) PTR(object);
1528     length = fixnum_value(vector->length);
1529     nwords = CEILING(length + 2, 2);
1530
1531     return copy_object(object, nwords);
1532 }
1533
1534 static int
1535 size_vector_unsigned_byte_32(lispobj * where)
1536 {
1537     struct vector *vector;
1538     int length, nwords;
1539
1540     vector = (struct vector *) where;
1541     length = fixnum_value(vector->length);
1542     nwords = CEILING(length + 2, 2);
1543
1544     return nwords;
1545 }
1546
1547
1548 static int
1549 scav_vector_single_float(lispobj * where, lispobj object)
1550 {
1551     struct vector *vector;
1552     int length, nwords;
1553
1554     vector = (struct vector *) where;
1555     length = fixnum_value(vector->length);
1556     nwords = CEILING(length + 2, 2);
1557
1558     return nwords;
1559 }
1560
1561 static lispobj
1562 trans_vector_single_float(lispobj object)
1563 {
1564     struct vector *vector;
1565     int length, nwords;
1566
1567     gc_assert(Pointerp(object));
1568
1569     vector = (struct vector *) PTR(object);
1570     length = fixnum_value(vector->length);
1571     nwords = CEILING(length + 2, 2);
1572
1573     return copy_object(object, nwords);
1574 }
1575
1576 static int
1577 size_vector_single_float(lispobj * where)
1578 {
1579     struct vector *vector;
1580     int length, nwords;
1581
1582     vector = (struct vector *) where;
1583     length = fixnum_value(vector->length);
1584     nwords = CEILING(length + 2, 2);
1585
1586     return nwords;
1587 }
1588
1589
1590 static int
1591 scav_vector_double_float(lispobj * where, lispobj object)
1592 {
1593     struct vector *vector;
1594     int length, nwords;
1595
1596     vector = (struct vector *) where;
1597     length = fixnum_value(vector->length);
1598     nwords = CEILING(length * 2 + 2, 2);
1599
1600     return nwords;
1601 }
1602
1603 static lispobj
1604 trans_vector_double_float(lispobj object)
1605 {
1606     struct vector *vector;
1607     int length, nwords;
1608
1609     gc_assert(Pointerp(object));
1610
1611     vector = (struct vector *) PTR(object);
1612     length = fixnum_value(vector->length);
1613     nwords = CEILING(length * 2 + 2, 2);
1614
1615     return copy_object(object, nwords);
1616 }
1617
1618 static int
1619 size_vector_double_float(lispobj * where)
1620 {
1621     struct vector *vector;
1622     int length, nwords;
1623
1624     vector = (struct vector *) where;
1625     length = fixnum_value(vector->length);
1626     nwords = CEILING(length * 2 + 2, 2);
1627
1628     return nwords;
1629 }
1630
1631
1632 #ifdef type_SimpleArrayLongFloat
1633 static int
1634 scav_vector_long_float(lispobj * where, lispobj object)
1635 {
1636     struct vector *vector;
1637     int length, nwords;
1638
1639     vector = (struct vector *) where;
1640     length = fixnum_value(vector->length);
1641 #ifdef sparc
1642     nwords = CEILING(length * 4 + 2, 2);
1643 #endif
1644
1645     return nwords;
1646 }
1647
1648 static lispobj
1649 trans_vector_long_float(lispobj object)
1650 {
1651     struct vector *vector;
1652     int length, nwords;
1653
1654     gc_assert(Pointerp(object));
1655
1656     vector = (struct vector *) PTR(object);
1657     length = fixnum_value(vector->length);
1658 #ifdef sparc
1659     nwords = CEILING(length * 4 + 2, 2);
1660 #endif
1661
1662     return copy_object(object, nwords);
1663 }
1664
1665 static int
1666 size_vector_long_float(lispobj * where)
1667 {
1668     struct vector *vector;
1669     int length, nwords;
1670
1671     vector = (struct vector *) where;
1672     length = fixnum_value(vector->length);
1673 #ifdef sparc
1674     nwords = CEILING(length * 4 + 2, 2);
1675 #endif
1676
1677     return nwords;
1678 }
1679 #endif
1680
1681
1682 #ifdef type_SimpleArrayDoubleDoubleFloat
1683 static int
1684 size_vector_double_double_float(lispobj * where)
1685 {
1686     struct vector *vector;
1687     int length, nwords;
1688
1689     vector = (struct vector *) where;
1690     length = fixnum_value(vector->length);
1691     nwords = CEILING(length * 4 + 2, 2);
1692
1693     return nwords;
1694 }
1695
1696 static int
1697 scav_vector_double_double_float(lispobj * where, lispobj object)
1698 {
1699     return size_vector_double_double_float(where);
1700 }
1701
1702 static lispobj
1703 trans_vector_double_double_float(lispobj object)
1704 {
1705     gc_assert(Pointerp(object));
1706     return copy_object(object, size_vector_double_double_float((lispobj *)
1707                                                             PTR(object)));
1708 }
1709 #endif
1710
1711
1712 #ifdef type_SimpleArrayComplexSingleFloat
1713 static int
1714 scav_vector_complex_single_float(lispobj * where, lispobj object)
1715 {
1716     struct vector *vector;
1717     int length, nwords;
1718
1719     vector = (struct vector *) where;
1720     length = fixnum_value(vector->length);
1721     nwords = CEILING(length * 2 + 2, 2);
1722
1723     return nwords;
1724 }
1725
1726 static lispobj
1727 trans_vector_complex_single_float(lispobj object)
1728 {
1729     struct vector *vector;
1730     int length, nwords;
1731
1732     gc_assert(Pointerp(object));
1733
1734     vector = (struct vector *) PTR(object);
1735     length = fixnum_value(vector->length);
1736     nwords = CEILING(length * 2 + 2, 2);
1737
1738     return copy_object(object, nwords);
1739 }
1740
1741 static int
1742 size_vector_complex_single_float(lispobj * where)
1743 {
1744     struct vector *vector;
1745     int length, nwords;
1746
1747     vector = (struct vector *) where;
1748     length = fixnum_value(vector->length);
1749     nwords = CEILING(length * 2 + 2, 2);
1750
1751     return nwords;
1752 }
1753 #endif
1754
1755 #ifdef type_SimpleArrayComplexDoubleFloat
1756 static int
1757 scav_vector_complex_double_float(lispobj * where, lispobj object)
1758 {
1759     struct vector *vector;
1760     int length, nwords;
1761
1762     vector = (struct vector *) where;
1763     length = fixnum_value(vector->length);
1764     nwords = CEILING(length * 4 + 2, 2);
1765
1766     return nwords;
1767 }
1768
1769 static lispobj
1770 trans_vector_complex_double_float(lispobj object)
1771 {
1772     struct vector *vector;
1773     int length, nwords;
1774
1775     gc_assert(Pointerp(object));
1776
1777     vector = (struct vector *) PTR(object);
1778     length = fixnum_value(vector->length);
1779     nwords = CEILING(length * 4 + 2, 2);
1780
1781     return copy_object(object, nwords);
1782 }
1783
1784 static int
1785 size_vector_complex_double_float(lispobj * where)
1786 {
1787     struct vector *vector;
1788     int length, nwords;
1789
1790     vector = (struct vector *) where;
1791     length = fixnum_value(vector->length);
1792     nwords = CEILING(length * 4 + 2, 2);
1793
1794     return nwords;
1795 }
1796 #endif
1797
1798 #ifdef type_SimpleArrayComplexLongFloat
1799 static int
1800 scav_vector_complex_long_float(lispobj * where, lispobj object)
1801 {
1802     struct vector *vector;
1803     int length, nwords;
1804
1805     vector = (struct vector *) where;
1806     length = fixnum_value(vector->length);
1807 #ifdef sparc
1808     nwords = CEILING(length * 8 + 2, 2);
1809 #endif
1810
1811     return nwords;
1812 }
1813
1814 static lispobj
1815 trans_vector_complex_long_float(lispobj object)
1816 {
1817     struct vector *vector;
1818     int length, nwords;
1819
1820     gc_assert(Pointerp(object));
1821
1822     vector = (struct vector *) PTR(object);
1823     length = fixnum_value(vector->length);
1824 #ifdef sparc
1825     nwords = CEILING(length * 8 + 2, 2);
1826 #endif
1827
1828     return copy_object(object, nwords);
1829 }
1830
1831 static int
1832 size_vector_complex_long_float(lispobj * where)
1833 {
1834     struct vector *vector;
1835     int length, nwords;
1836
1837     vector = (struct vector *) where;
1838     length = fixnum_value(vector->length);
1839 #ifdef sparc
1840     nwords = CEILING(length * 8 + 2, 2);
1841 #endif
1842
1843     return nwords;
1844 }
1845 #endif
1846
1847 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
1848 static int
1849 size_vector_complex_double_double_float(lispobj * where)
1850 {
1851     struct vector *vector;
1852     int length, nwords;
1853
1854     vector = (struct vector *) where;
1855     length = fixnum_value(vector->length);
1856     nwords = length * 8 + 2;
1857
1858     return nwords;
1859 }
1860
1861 static int
1862 scav_vector_complex_double_double_float(lispobj * where, lispobj object)
1863 {
1864     return size_vector_complex_double_double_float(where);
1865 }
1866
1867 static lispobj
1868 trans_vector_complex_double_double_float(lispobj object)
1869 {
1870     gc_assert(Pointerp(object));
1871     return copy_object(object,
1872                        size_vector_complex_double_double_float((lispobj *)
1873                                                                        PTR(object)));
1874 }
1875 #endif
1876 \f
1877
1878 /* Weak Pointers */
1879
1880 #define WEAK_POINTER_NWORDS \
1881         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1882
1883 static int
1884 scav_weak_pointer(lispobj * where, lispobj object)
1885 {
1886     /* Do not let GC scavenge the value slot of the weak pointer */
1887     /* (that is why it is a weak pointer).  Note:  we could use */
1888     /* the scav_unboxed method here. */
1889
1890     return WEAK_POINTER_NWORDS;
1891 }
1892
1893 static lispobj
1894 trans_weak_pointer(lispobj object)
1895 {
1896     lispobj copy;
1897     struct weak_pointer *wp;
1898
1899     gc_assert(Pointerp(object));
1900
1901 #if defined(DEBUG_WEAK)
1902     printf("Transporting weak pointer from 0x%08x\n", object);
1903 #endif
1904
1905     /* Need to remember where all the weak pointers are that have */
1906     /* been transported so they can be fixed up in a post-GC pass. */
1907
1908     copy = copy_object(object, WEAK_POINTER_NWORDS);
1909     wp = (struct weak_pointer *) PTR(copy);
1910
1911
1912     /* Push the weak pointer onto the list of weak pointers. */
1913     wp->next = weak_pointers;
1914     weak_pointers = wp;
1915
1916     return copy;
1917 }
1918
1919 static int
1920 size_weak_pointer(lispobj * where)
1921 {
1922     return WEAK_POINTER_NWORDS;
1923 }
1924
1925 void
1926 scan_weak_pointers(void)
1927 {
1928     struct weak_pointer *wp;
1929
1930     for (wp = weak_pointers; wp != (struct weak_pointer *) NULL; wp = wp->next) {
1931         lispobj value;
1932         lispobj first, *first_pointer;
1933
1934         value = wp->value;
1935
1936 #if defined(DEBUG_WEAK)
1937         printf("Weak pointer at 0x%08x\n", (unsigned long) wp);
1938         printf("Value: 0x%08x\n", (unsigned long) value);
1939 #endif
1940
1941         if (!(Pointerp(value) && from_space_p(value)))
1942             continue;
1943
1944         /* Now, we need to check if the object has been */
1945         /* forwarded.  If it has been, the weak pointer is */
1946         /* still good and needs to be updated.  Otherwise, the */
1947         /* weak pointer needs to be nil'ed out. */
1948
1949         first_pointer = (lispobj *) PTR(value);
1950         first = *first_pointer;
1951
1952 #if defined(DEBUG_WEAK)
1953         printf("First: 0x%08x\n", (unsigned long) first);
1954 #endif
1955
1956         if (Pointerp(first) && new_space_p(first))
1957             wp->value = first;
1958         else {
1959             wp->value = NIL;
1960             wp->broken = T;
1961         }
1962     }
1963 }
1964 \f
1965
1966
1967 /* Initialization */
1968
1969 static int
1970 scav_lose(lispobj * where, lispobj object)
1971 {
1972     fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x\n",
1973             (unsigned long) object);
1974     lose(NULL);
1975     return 0;
1976 }
1977
1978 static lispobj
1979 trans_lose(lispobj object)
1980 {
1981     fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
1982             (unsigned long) object);
1983     lose(NULL);
1984     return NIL;
1985 }
1986
1987 static int
1988 size_lose(lispobj * where)
1989 {
1990     fprintf(stderr, "Size lossage.  No size function for object at 0x%08x\n",
1991             (unsigned long) where);
1992     fprintf(stderr, "First word of object: 0x%08x\n", (unsigned long) *where);
1993     return 1;
1994 }
1995
1996 void
1997 gc_init(void)
1998 {
1999     int i;
2000
2001     /* Scavenge Table */
2002     for (i = 0; i < 256; i++)
2003         scavtab[i] = scav_lose;
2004
2005     for (i = 0; i < 32; i++) {
2006         scavtab[type_EvenFixnum | (i << 3)] = scav_immediate;
2007         scavtab[type_FunctionPointer | (i << 3)] = scav_function_pointer;
2008         /* OtherImmediate0 */
2009         scavtab[type_ListPointer | (i << 3)] = scav_list_pointer;
2010         scavtab[type_OddFixnum | (i << 3)] = scav_immediate;
2011         scavtab[type_InstancePointer | (i << 3)] = scav_instance_pointer;
2012         /* OtherImmediate1 */
2013         scavtab[type_OtherPointer | (i << 3)] = scav_other_pointer;
2014     }
2015
2016     scavtab[type_Bignum] = scav_unboxed;
2017     scavtab[type_Ratio] = scav_boxed;
2018     scavtab[type_SingleFloat] = scav_unboxed;
2019     scavtab[type_DoubleFloat] = scav_unboxed;
2020 #ifdef type_LongFloat
2021     scavtab[type_LongFloat] = scav_unboxed;
2022 #endif
2023 #ifdef type_DoubleDoubleFloat
2024     scavtab[type_DoubleDoubleFloat] = scav_unboxed;
2025 #endif
2026     scavtab[type_Complex] = scav_boxed;
2027 #ifdef type_ComplexSingleFloat
2028     scavtab[type_ComplexSingleFloat] = scav_unboxed;
2029 #endif
2030 #ifdef type_ComplexDoubleFloat
2031     scavtab[type_ComplexDoubleFloat] = scav_unboxed;
2032 #endif
2033 #ifdef type_ComplexLongFloat
2034     scavtab[type_ComplexLongFloat] = scav_unboxed;
2035 #endif
2036 #ifdef type_ComplexDoubleDoubleFloat
2037     scavtab[type_ComplexDoubleDoubleFloat] = scav_unboxed;
2038 #endif
2039     scavtab[type_SimpleArray] = scav_boxed;
2040     scavtab[type_SimpleString] = scav_string;
2041     scavtab[type_SimpleBitVector] = scav_vector_bit;
2042     scavtab[type_SimpleVector] = scav_vector;
2043     scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
2044     scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
2045     scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
2046     scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
2047     scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
2048 #ifdef type_SimpleArraySignedByte8
2049     scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
2050 #endif
2051 #ifdef type_SimpleArraySignedByte16
2052     scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
2053 #endif
2054 #ifdef type_SimpleArraySignedByte30
2055     scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
2056 #endif
2057 #ifdef type_SimpleArraySignedByte32
2058     scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
2059 #endif
2060     scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
2061     scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
2062 #ifdef type_SimpleArrayLongFloat
2063     scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
2064 #endif
2065 #ifdef type_SimpleArrayDoubleDoubleFloat
2066     scavtab[type_SimpleArrayDoubleDoubleFloat] = scav_vector_double_double_float;
2067 #endif
2068 #ifdef type_SimpleArrayComplexSingleFloat
2069     scavtab[type_SimpleArrayComplexSingleFloat] =
2070         scav_vector_complex_single_float;
2071 #endif
2072 #ifdef type_SimpleArrayComplexDoubleFloat
2073     scavtab[type_SimpleArrayComplexDoubleFloat] =
2074         scav_vector_complex_double_float;
2075 #endif
2076 #ifdef type_SimpleArrayComplexLongFloat
2077     scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
2078 #endif
2079 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
2080     scavtab[type_SimpleArrayComplexDoubleDoubleFloat] =
2081         scav_vector_complex_double_double_float;
2082 #endif
2083     scavtab[type_ComplexString] = scav_boxed;
2084     scavtab[type_ComplexBitVector] = scav_boxed;
2085     scavtab[type_ComplexVector] = scav_boxed;
2086     scavtab[type_ComplexArray] = scav_boxed;
2087     scavtab[type_CodeHeader] = scav_code_header;
2088     scavtab[type_FunctionHeader] = scav_function_header;
2089     scavtab[type_ClosureFunctionHeader] = scav_function_header;
2090     scavtab[type_ReturnPcHeader] = scav_return_pc_header;
2091 #ifdef i386
2092     scavtab[type_ClosureHeader] = scav_closure_header;
2093     scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
2094     scavtab[type_ByteCodeFunction] = scav_closure_header;
2095     scavtab[type_ByteCodeClosure] = scav_closure_header;
2096     scavtab[type_DylanFunctionHeader] = scav_closure_header;
2097 #else
2098     scavtab[type_ClosureHeader] = scav_boxed;
2099     scavtab[type_FuncallableInstanceHeader] = scav_boxed;
2100     scavtab[type_ByteCodeFunction] = scav_boxed;
2101     scavtab[type_ByteCodeClosure] = scav_boxed;
2102 #ifdef type_DylanFunctionHeader
2103     scavtab[type_DylanFunctionHeader] = scav_boxed;
2104 #endif
2105 #endif
2106     scavtab[type_ValueCellHeader] = scav_boxed;
2107     scavtab[type_SymbolHeader] = scav_boxed;
2108     scavtab[type_BaseChar] = scav_immediate;
2109     scavtab[type_Sap] = scav_unboxed;
2110     scavtab[type_UnboundMarker] = scav_immediate;
2111     scavtab[type_WeakPointer] = scav_weak_pointer;
2112     scavtab[type_InstanceHeader] = scav_boxed;
2113 #if !(defined(sparc) || defined(DARWIN))
2114     scavtab[type_Fdefn] = scav_fdefn;
2115 #else
2116     scavtab[type_Fdefn] = scav_boxed;
2117 #endif
2118
2119     /* Transport Other Table */
2120     for (i = 0; i < 256; i++)
2121         transother[i] = trans_lose;
2122
2123     transother[type_Bignum] = trans_unboxed;
2124     transother[type_Ratio] = trans_boxed;
2125     transother[type_SingleFloat] = trans_unboxed;
2126     transother[type_DoubleFloat] = trans_unboxed;
2127 #ifdef type_LongFloat
2128     transother[type_LongFloat] = trans_unboxed;
2129 #endif
2130 #ifdef type_DoubleDoubleFloat
2131     transother[type_DoubleDoubleFloat] = trans_unboxed;
2132 #endif
2133     transother[type_Complex] = trans_boxed;
2134 #ifdef type_ComplexSingleFloat
2135     transother[type_ComplexSingleFloat] = trans_unboxed;
2136 #endif
2137 #ifdef type_ComplexDoubleFloat
2138     transother[type_ComplexDoubleFloat] = trans_unboxed;
2139 #endif
2140 #ifdef type_ComplexLongFloat
2141     transother[type_ComplexLongFloat] = trans_unboxed;
2142 #endif
2143 #ifdef type_ComplexDoubleDoubleFloat
2144     transother[type_ComplexDoubleDoubleFloat] = trans_unboxed;
2145 #endif
2146     transother[type_SimpleArray] = trans_boxed;
2147     transother[type_SimpleString] = trans_string;
2148     transother[type_SimpleBitVector] = trans_vector_bit;
2149     transother[type_SimpleVector] = trans_vector;
2150     transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2151     transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2152     transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2153     transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2154     transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
2155 #ifdef type_SimpleArraySignedByte8
2156     transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
2157 #endif
2158 #ifdef type_SimpleArraySignedByte16
2159     transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
2160 #endif
2161 #ifdef type_SimpleArraySignedByte30
2162     transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
2163 #endif
2164 #ifdef type_SimpleArraySignedByte32
2165     transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
2166 #endif
2167     transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2168     transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
2169 #ifdef type_SimpleArrayLongFloat
2170     transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
2171 #endif
2172 #ifdef type_SimpleArrayDoubleDoubleFloat
2173     transother[type_SimpleArrayDoubleDoubleFloat] = trans_vector_double_double_float;
2174 #endif
2175 #ifdef type_SimpleArrayComplexSingleFloat
2176     transother[type_SimpleArrayComplexSingleFloat] =
2177         trans_vector_complex_single_float;
2178 #endif
2179 #ifdef type_SimpleArrayComplexDoubleFloat
2180     transother[type_SimpleArrayComplexDoubleFloat] =
2181         trans_vector_complex_double_float;
2182 #endif
2183 #ifdef type_SimpleArrayComplexLongFloat
2184     transother[type_SimpleArrayComplexLongFloat] =
2185         trans_vector_complex_long_float;
2186 #endif
2187 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
2188     transother[type_SimpleArrayComplexDoubleDoubleFloat] =
2189         trans_vector_complex_double_double_float;
2190 #endif
2191     transother[type_ComplexString] = trans_boxed;
2192     transother[type_ComplexBitVector] = trans_boxed;
2193     transother[type_ComplexVector] = trans_boxed;
2194     transother[type_ComplexArray] = trans_boxed;
2195     transother[type_CodeHeader] = trans_code_header;
2196     transother[type_FunctionHeader] = trans_function_header;
2197     transother[type_ClosureFunctionHeader] = trans_function_header;
2198     transother[type_ReturnPcHeader] = trans_return_pc_header;
2199     transother[type_ClosureHeader] = trans_boxed;
2200     transother[type_FuncallableInstanceHeader] = trans_boxed;
2201     transother[type_ByteCodeFunction] = trans_boxed;
2202     transother[type_ByteCodeClosure] = trans_boxed;
2203     transother[type_ValueCellHeader] = trans_boxed;
2204     transother[type_SymbolHeader] = trans_boxed;
2205     transother[type_BaseChar] = trans_immediate;
2206     transother[type_Sap] = trans_unboxed;
2207     transother[type_UnboundMarker] = trans_immediate;
2208     transother[type_WeakPointer] = trans_weak_pointer;
2209     transother[type_InstanceHeader] = trans_boxed;
2210     transother[type_Fdefn] = trans_boxed;
2211
2212     /* Size table */
2213
2214     for (i = 0; i < 256; i++)
2215         sizetab[i] = size_lose;
2216
2217     for (i = 0; i < 32; i++) {
2218         sizetab[type_EvenFixnum | (i << 3)] = size_immediate;
2219         sizetab[type_FunctionPointer | (i << 3)] = size_pointer;
2220         /* OtherImmediate0 */
2221         sizetab[type_ListPointer | (i << 3)] = size_pointer;
2222         sizetab[type_OddFixnum | (i << 3)] = size_immediate;
2223         sizetab[type_InstancePointer | (i << 3)] = size_pointer;
2224         /* OtherImmediate1 */
2225         sizetab[type_OtherPointer | (i << 3)] = size_pointer;
2226     }
2227
2228     sizetab[type_Bignum] = size_unboxed;
2229     sizetab[type_Ratio] = size_boxed;
2230     sizetab[type_SingleFloat] = size_unboxed;
2231     sizetab[type_DoubleFloat] = size_unboxed;
2232 #ifdef type_LongFloat
2233     sizetab[type_LongFloat] = size_unboxed;
2234 #endif
2235 #ifdef type_DoubleDoubleFloat
2236     sizetab[type_DoubleDoubleFloat] = size_unboxed;
2237 #endif
2238     sizetab[type_Complex] = size_boxed;
2239 #ifdef type_ComplexSingleFloat
2240     sizetab[type_ComplexSingleFloat] = size_unboxed;
2241 #endif
2242 #ifdef type_ComplexDoubleFloat
2243     sizetab[type_ComplexDoubleFloat] = size_unboxed;
2244 #endif
2245 #ifdef type_ComplexLongFloat
2246     sizetab[type_ComplexLongFloat] = size_unboxed;
2247 #endif
2248 #ifdef type_ComplexDoubleDoubleFloat
2249     sizetab[type_ComplexDoubleDoubleFloat] = size_unboxed;
2250 #endif
2251     sizetab[type_SimpleArray] = size_boxed;
2252     sizetab[type_SimpleString] = size_string;
2253     sizetab[type_SimpleBitVector] = size_vector_bit;
2254     sizetab[type_SimpleVector] = size_vector;
2255     sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2256     sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2257     sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2258     sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2259     sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
2260 #ifdef type_SimpleArraySignedByte8
2261     sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
2262 #endif
2263 #ifdef type_SimpleArraySignedByte16
2264     sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
2265 #endif
2266 #ifdef type_SimpleArraySignedByte30
2267     sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
2268 #endif
2269 #ifdef type_SimpleArraySignedByte32
2270     sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
2271 #endif
2272     sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2273     sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
2274 #ifdef type_SimpleArrayLongFloat
2275     sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
2276 #endif
2277 #ifdef type_SimpleArrayDoubleDoubleFloat
2278     sizetab[type_SimpleArrayDoubleDoubleFloat] = size_vector_double_double_float;
2279 #endif
2280 #ifdef type_SimpleArrayComplexSingleFloat
2281     sizetab[type_SimpleArrayComplexSingleFloat] =
2282         size_vector_complex_single_float;
2283 #endif
2284 #ifdef type_SimpleArrayComplexDoubleFloat
2285     sizetab[type_SimpleArrayComplexDoubleFloat] =
2286         size_vector_complex_double_float;
2287 #endif
2288 #ifdef type_SimpleArrayComplexLongFloat
2289     sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
2290 #endif
2291 #ifdef type_SimpleArrayComplexDoubleDoubleFloat
2292     sizetab[type_SimpleArrayComplexDoubleDoubleFloat] =
2293         size_vector_complex_double_double_float;
2294 #endif
2295     sizetab[type_ComplexString] = size_boxed;
2296     sizetab[type_ComplexBitVector] = size_boxed;
2297     sizetab[type_ComplexVector] = size_boxed;
2298     sizetab[type_ComplexArray] = size_boxed;
2299     sizetab[type_CodeHeader] = size_code_header;
2300 #if 0
2301     /* Shouldn't see these so just lose if it happens */
2302     sizetab[type_FunctionHeader] = size_function_header;
2303     sizetab[type_ClosureFunctionHeader] = size_function_header;
2304     sizetab[type_ReturnPcHeader] = size_return_pc_header;
2305 #endif
2306     sizetab[type_ClosureHeader] = size_boxed;
2307     sizetab[type_FuncallableInstanceHeader] = size_boxed;
2308     sizetab[type_ValueCellHeader] = size_boxed;
2309     sizetab[type_SymbolHeader] = size_boxed;
2310     sizetab[type_BaseChar] = size_immediate;
2311     sizetab[type_Sap] = size_unboxed;
2312     sizetab[type_UnboundMarker] = size_immediate;
2313     sizetab[type_WeakPointer] = size_weak_pointer;
2314     sizetab[type_InstanceHeader] = size_boxed;
2315     sizetab[type_Fdefn] = size_boxed;
2316 }
2317 \f
2318
2319
2320 /* Noise to manipulate the gc trigger stuff. */
2321
2322 #ifndef ibmrt
2323
2324 void
2325 set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2326 {
2327     os_vm_address_t addr = (os_vm_address_t) current_dynamic_space +
2328
2329         dynamic_usage;
2330     long length =
2331
2332         dynamic_space_size + (os_vm_address_t) current_dynamic_space - addr;
2333
2334     if (addr < (os_vm_address_t) current_dynamic_space_free_pointer) {
2335         fprintf(stderr,
2336                 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %d)\n",
2337                 dynamic_usage,
2338                 (os_vm_address_t) current_dynamic_space_free_pointer
2339                 - (os_vm_address_t) current_dynamic_space);
2340         return;
2341     } else if (length < 0) {
2342         fprintf(stderr,
2343                 "set_auto_gc_trigger: tried to set gc trigger too high! (%d)\n",
2344                 dynamic_usage);
2345         return;
2346     }
2347
2348     addr = os_round_up_to_page(addr);
2349     length = os_trunc_size_to_page(length);
2350
2351 #if defined(SUNOS) || defined(SOLARIS)
2352     os_invalidate(addr, length);
2353 #else
2354     os_protect(addr, length, 0);
2355 #endif
2356
2357     current_auto_gc_trigger = (lispobj *) addr;
2358
2359 #ifdef PRINTNOISE
2360     fprintf(stderr, "current_auto_gc_trigger set to %p\n",
2361             current_auto_gc_trigger);
2362 #endif
2363
2364 }
2365
2366 void
2367 clear_auto_gc_trigger(void)
2368 {
2369     if (current_auto_gc_trigger != NULL) {
2370 #if defined(SUNOS) || defined(SOLARIS)  /* don't want to force whole space into swapping mode... */
2371         os_vm_address_t addr = (os_vm_address_t) current_auto_gc_trigger;
2372         os_vm_size_t length =
2373             dynamic_space_size + (os_vm_address_t) current_dynamic_space - addr;
2374
2375         os_validate(addr, length);
2376 #else
2377         os_protect((os_vm_address_t) current_dynamic_space,
2378                    dynamic_space_size, OS_VM_PROT_ALL);
2379 #endif
2380
2381         current_auto_gc_trigger = NULL;
2382     }
2383 }
2384
2385 #endif