src/lisp/gc.c

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