src/runtime/gc.c

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