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(is_lisp_pointer(object));
  83         */
  84         ptr = (lispobj *) native_pointer(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(is_lisp_pointer(object));
  96
  97         ptr = (lispobj *) native_pointer(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(is_lisp_pointer(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 *) native_pointer(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 (is_lisp_pointer(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 *)native_pointer(object));
 399                         if (is_lisp_pointer(first_word) &&
 400                             new_space_p(first_word)) {
 401                             /* Yep, there be a forwarding pointer. */
 402                             *start = first_word;
 403                             words_scavenged = 1;
 404                         }
 405                         else {
 406                             /* Scavenge that pointer. */
 407                             words_scavenged = (scavtab[type])(start, object);
 408                         }
 409                     }
 410                     else {
 411                         /* It points somewhere other than oldspace.  Leave */
 412                         /* it alone. */
 413                         words_scavenged = 1;
 414                     }
 415                 }
 416                 else if(nwords==1) {
 417                     /* there are some situations where an
 418                        other-immediate may end up in a descriptor
 419                        register.  I'm not sure whether this is
 420                        supposed to happen, but if it does then we
 421                        don't want to (a) barf or (b) scavenge over the
 422                        data-block, because there isn't one.  So, if
 423                        we're checking a single word and it's anything
 424                        other than a pointer, just hush it up */
 425
 426                     words_scavenged=1;
 427                     if((scavtab[type]==scav_lose) ||
 428                        (((scavtab[type])(start,object))>1)) {
 429                         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",
 430                                 object,start);
 431                     }
 432                 }
 433                 else if ((object & 3) == 0) {
 434                     /* It's a fixnum.  Real easy. */
 435                     words_scavenged = 1;
 436                 }
 437                 else {
 438                     /* It's some random header object. */
 439                     words_scavenged = (scavtab[type])(start, object);
 440
 441                 }
 442
 443                 start += words_scavenged;
 444                 nwords -= words_scavenged;
 445         }
 446         gc_assert(nwords == 0);
 447 }
 448
 449 static void
 450 scavenge_newspace(void)
 451 {
 452     lispobj *here, *next;
 453
 454     here = new_space;
 455     while (here < new_space_free_pointer) {
 456         /*      printf("here=%lx, new_space_free_pointer=%lx\n",
 457                 here,new_space_free_pointer); */
 458         next = new_space_free_pointer;
 459         scavenge(here, next - here);
 460         here = next;
 461     }
 462     /* printf("done with newspace\n"); */
 463 }
 464 \f
 465 /* scavenging interrupt contexts */
 466
 467 static int boxed_registers[] = BOXED_REGISTERS;
 468
 469 static void
 470 scavenge_interrupt_context(os_context_t *context)
 471 {
 472         int i;
 473 #ifdef reg_LIP
 474         unsigned long lip;
 475         unsigned long lip_offset;
 476         int lip_register_pair;
 477 #endif
 478         unsigned long pc_code_offset;
 479 #ifdef SC_NPC
 480         unsigned long npc_code_offset;
 481 #endif
 482
 483         /* Find the LIP's register pair and calculate its offset */
 484         /* before we scavenge the context. */
 485 #ifdef reg_LIP
 486         lip = *os_context_register_addr(context, reg_LIP);
 487         /*  0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
 488         lip_offset = 0x7FFFFFFF;
 489         lip_register_pair = -1;
 490         for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 491                 unsigned long reg;
 492                 long offset;
 493                 int index;
 494
 495                 index = boxed_registers[i];
 496                 reg = *os_context_register_addr(context, index);
 497                 /* would be using PTR if not for integer length issues */
 498                 if ((reg & ~((1L<<lowtag_Bits)-1)) <= lip) {
 499                         offset = lip - reg;
 500                         if (offset < lip_offset) {
 501                                 lip_offset = offset;
 502                                 lip_register_pair = index;
 503                         }
 504                 }
 505         }
 506 #endif reg_LIP
 507
 508         /* Compute the PC's offset from the start of the CODE */
 509         /* register. */
 510         pc_code_offset = *os_context_pc_addr(context) -
 511             *os_context_register_addr(context, reg_CODE);
 512 #ifdef SC_NPC
 513         npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
 514 #endif SC_NPC
 515
 516         /* Scanvenge all boxed registers in the context. */
 517         for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 518                 int index;
 519                 lispobj foo;
 520
 521                 index = boxed_registers[i];
 522                 foo = *os_context_register_addr(context,index);
 523                 scavenge((lispobj *) &foo, 1);
 524                 *os_context_register_addr(context,index) = foo;
 525
 526                 /* this is unlikely to work as intended on bigendian
 527                  * 64 bit platforms */
 528
 529                 scavenge((lispobj *)
 530                          os_context_register_addr(context, index), 1);
 531         }
 532
 533 #ifdef reg_LIP
 534         /* Fix the LIP */
 535         *os_context_register_addr(context, reg_LIP) =
 536             *os_context_register_addr(context, lip_register_pair) + lip_offset;
 537 #endif reg_LIP
 538
 539         /* Fix the PC if it was in from space */
 540         if (from_space_p(*os_context_pc_addr(context)))
 541             *os_context_pc_addr(context) =
 542                 *os_context_register_addr(context, reg_CODE) + pc_code_offset;
 543 #ifdef SC_NPC
 544         if (from_space_p(SC_NPC(context)))
 545                 SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
 546 #endif SC_NPC
 547 }
 548
 549 void scavenge_interrupt_contexts(void)
 550 {
 551     int i, index;
 552     os_context_t *context;
 553
 554     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
 555
 556     for (i = 0; i < index; i++) {
 557         context = lisp_interrupt_contexts[i];
 558         scavenge_interrupt_context(context);
 559     }
 560 }
 561
 562 \f
 563 /* debugging code */
 564
 565 void
 566 print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
 567 {
 568         lispobj *start;
 569         int total_words_not_copied;
 570
 571         printf("Scanning from space ...\n");
 572
 573         total_words_not_copied = 0;
 574         start = from_space;
 575         while (start < from_space_free_pointer) {
 576                 lispobj object;
 577                 int forwardp, type, nwords;
 578                 lispobj header;
 579
 580                 object = *start;
 581                 forwardp = is_lisp_pointer(object) && new_space_p(object);
 582
 583                 if (forwardp) {
 584                         int tag;
 585                         lispobj *pointer;
 586
 587                         tag = LowtagOf(object);
 588
 589                         switch (tag) {
 590                         case type_ListPointer:
 591                                 nwords = 2;
 592                                 break;
 593                         case type_InstancePointer:
 594                                 printf("Don't know about instances yet!\n");
 595                                 nwords = 1;
 596                                 break;
 597                         case type_FunctionPointer:
 598                                 nwords = 1;
 599                                 break;
 600                         case type_OtherPointer:
 601                                 pointer = (lispobj *) native_pointer(object);
 602                                 header = *pointer;
 603                                 type = TypeOf(header);
 604                                 nwords = (sizetab[type])(pointer);
 605                         }
 606                 } else {
 607                         type = TypeOf(object);
 608                         nwords = (sizetab[type])(start);
 609                         total_words_not_copied += nwords;
 610                         printf("%4d words not copied at 0x%16lx; ",
 611                                nwords, (unsigned long) start);
 612                         printf("Header word is 0x%08x\n",
 613                                (unsigned int) object);
 614                 }
 615                 start += nwords;
 616         }
 617         printf("%d total words not copied.\n", total_words_not_copied);
 618 }
 619
 620 \f
 621 /* code and code-related objects */
 622
 623 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
 624
 625 static lispobj trans_function_header(lispobj object);
 626 static lispobj trans_boxed(lispobj object);
 627
 628 static int
 629 scav_function_pointer(lispobj *where, lispobj object)
 630 {
 631   lispobj  *first_pointer;
 632   lispobj copy;
 633   lispobj first;
 634   int type;
 635
 636   gc_assert(is_lisp_pointer(object));
 637
 638   /* object is a pointer into from space. Not a FP */
 639   first_pointer = (lispobj *) native_pointer(object);
 640   first = *first_pointer;
 641
 642   /* must transport object -- object may point */
 643   /* to either a function header, a closure */
 644   /* function header, or to a closure header. */
 645
 646   type = TypeOf(first);
 647   switch (type) {
 648   case type_FunctionHeader:
 649   case type_ClosureFunctionHeader:
 650     copy = trans_function_header(object);
 651     break;
 652   default:
 653     copy = trans_boxed(object);
 654     break;
 655   }
 656
 657   first = *first_pointer = copy;
 658
 659   gc_assert(is_lisp_pointer(first));
 660   gc_assert(!from_space_p(first));
 661
 662   *where = first;
 663   return 1;
 664 }
 665
 666 static struct code *
 667 trans_code(struct code *code)
 668 {
 669         struct code *new_code;
 670         lispobj first, l_code, l_new_code;
 671         int nheader_words, ncode_words, nwords;
 672         unsigned long displacement;
 673         lispobj fheaderl, *prev_pointer;
 674
 675 #if defined(DEBUG_CODE_GC)
 676         printf("\nTransporting code object located at 0x%08x.\n",
 677                (unsigned long) code);
 678 #endif
 679
 680         /* if object has already been transported, just return pointer */
 681         first = code->header;
 682         if (is_lisp_pointer(first) && new_space_p(first)) {
 683 #ifdef DEBUG_CODE_GC
 684             printf("Was already transported\n");
 685 #endif
 686             return (struct code *) native_pointer(first);
 687         }
 688
 689         gc_assert(TypeOf(first) == type_CodeHeader);
 690
 691         /* prepare to transport the code vector */
 692         l_code = (lispobj) LOW_WORD(code) | type_OtherPointer;
 693
 694         ncode_words = fixnum_value(code->code_size);
 695         nheader_words = HeaderValue(code->header);
 696         nwords = ncode_words + nheader_words;
 697         nwords = CEILING(nwords, 2);
 698
 699         l_new_code = copy_object(l_code, nwords);
 700         new_code = (struct code *) native_pointer(l_new_code);
 701
 702         displacement = l_new_code - l_code;
 703
 704 #if defined(DEBUG_CODE_GC)
 705         printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 706                (unsigned long) code, (unsigned long) new_code);
 707         printf("Code object is %d words long.\n", nwords);
 708 #endif
 709
 710         /* set forwarding pointer */
 711         code->header = l_new_code;
 712
 713         /* set forwarding pointers for all the function headers in the */
 714         /* code object.  also fix all self pointers */
 715
 716         fheaderl = code->entry_points;
 717         prev_pointer = &new_code->entry_points;
 718
 719         while (fheaderl != NIL) {
 720                 struct function *fheaderp, *nfheaderp;
 721                 lispobj nfheaderl;
 722
 723                 fheaderp = (struct function *) native_pointer(fheaderl);
 724                 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 725
 726                 /* calcuate the new function pointer and the new */
 727                 /* function header */
 728                 nfheaderl = fheaderl + displacement;
 729                 nfheaderp = (struct function *) native_pointer(nfheaderl);
 730
 731                 /* set forwarding pointer */
 732 #ifdef DEBUG_CODE_GC
 733                 printf("fheaderp->header (at %x) <- %x\n",
 734                        &(fheaderp->header) , nfheaderl);
 735 #endif
 736                 fheaderp->header = nfheaderl;
 737
 738                 /* fix self pointer */
 739                 nfheaderp->self = nfheaderl;
 740
 741                 *prev_pointer = nfheaderl;
 742
 743                 fheaderl = fheaderp->next;
 744                 prev_pointer = &nfheaderp->next;
 745         }
 746
 747 #ifndef MACH
 748         os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
 749                         ncode_words * sizeof(int));
 750 #endif
 751         return new_code;
 752 }
 753
 754 static int
 755 scav_code_header(lispobj *where, lispobj object)
 756 {
 757         struct code *code;
 758         int nheader_words, ncode_words, nwords;
 759         lispobj fheaderl;
 760         struct function *fheaderp;
 761
 762         code = (struct code *) where;
 763         ncode_words = fixnum_value(code->code_size);
 764         nheader_words = HeaderValue(object);
 765         nwords = ncode_words + nheader_words;
 766         nwords = CEILING(nwords, 2);
 767
 768 #if defined(DEBUG_CODE_GC)
 769         printf("\nScavening code object at 0x%08x.\n",
 770                (unsigned long) where);
 771         printf("Code object is %d words long.\n", nwords);
 772         printf("Scavenging boxed section of code data block (%d words).\n",
 773                nheader_words - 1);
 774 #endif
 775
 776         /* Scavenge the boxed section of the code data block */
 777         scavenge(where + 1, nheader_words - 1);
 778
 779         /* Scavenge the boxed section of each function object in the */
 780         /* code data block */
 781         fheaderl = code->entry_points;
 782         while (fheaderl != NIL) {
 783                 fheaderp = (struct function *) native_pointer(fheaderl);
 784                 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 785
 786 #if defined(DEBUG_CODE_GC)
 787                 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
 788                        (unsigned long) native_pointer(fheaderl));
 789 #endif
 790                 scavenge(&fheaderp->name, 1);
 791                 scavenge(&fheaderp->arglist, 1);
 792                 scavenge(&fheaderp->type, 1);
 793
 794                 fheaderl = fheaderp->next;
 795         }
 796
 797         return nwords;
 798 }
 799
 800 static lispobj
 801 trans_code_header(lispobj object)
 802 {
 803         struct code *ncode;
 804
 805         ncode = trans_code((struct code *) native_pointer(object));
 806         return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
 807 }
 808
 809 static int
 810 size_code_header(lispobj *where)
 811 {
 812         struct code *code;
 813         int nheader_words, ncode_words, nwords;
 814
 815         code = (struct code *) where;
 816
 817         ncode_words = fixnum_value(code->code_size);
 818         nheader_words = HeaderValue(code->header);
 819         nwords = ncode_words + nheader_words;
 820         nwords = CEILING(nwords, 2);
 821
 822         return nwords;
 823 }
 824
 825
 826 static int
 827 scav_return_pc_header(lispobj *where, lispobj object)
 828 {
 829     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 830     fprintf(stderr, "Return PC Header.\n");
 831     fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
 832     lose(NULL);
 833     return 0;
 834 }
 835
 836 static lispobj
 837 trans_return_pc_header(lispobj object)
 838 {
 839         struct function *return_pc;
 840         unsigned long offset;
 841         struct code *code, *ncode;
 842         lispobj ret;
 843         return_pc = (struct function *) native_pointer(object);
 844         offset = HeaderValue(return_pc->header)  * 4 ;
 845
 846         /* Transport the whole code object */
 847         code = (struct code *) ((unsigned long) return_pc - offset);
 848 #ifdef DEBUG_CODE_GC
 849         printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
 850 #endif
 851         ncode = trans_code(code);
 852         if(object==0x304748d7) {
 853             /* monitor_or_something(); */
 854         }
 855         ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
 856 #ifdef DEBUG_CODE_GC
 857         printf("trans_return_pc_header returning %x\n",ret);
 858 #endif
 859         return ret;
 860 }
 861
 862 /* On the 386, closures hold a pointer to the raw address instead of
 863  * the function object, so we can use CALL [$FDEFN+const] to invoke
 864  * the function without loading it into a register. Given that code
 865  * objects don't move, we don't need to update anything, but we do
 866  * have to figure out that the function is still live. */
 867 #ifdef __i386__
 868 static
 869 scav_closure_header(where, object)
 870 lispobj *where, object;
 871 {
 872         struct closure *closure;
 873         lispobj fun;
 874
 875         closure = (struct closure *)where;
 876         fun = closure->function - RAW_ADDR_OFFSET;
 877         scavenge(&fun, 1);
 878
 879         return 2;
 880 }
 881 #endif
 882
 883 static int
 884 scav_function_header(lispobj *where, lispobj object)
 885 {
 886     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 887     fprintf(stderr, "Function Header.\n");
 888     fprintf(stderr, "where = 0x%p, object = 0x%08x",
 889             where, (unsigned int) object);
 890     lose(NULL);
 891     return 0;
 892 }
 893
 894 static lispobj
 895 trans_function_header(lispobj object)
 896 {
 897         struct function *fheader;
 898         unsigned long offset;
 899         struct code *code, *ncode;
 900
 901         fheader = (struct function *) native_pointer(object);
 902         offset = HeaderValue(fheader->header) * 4;
 903
 904         /* Transport the whole code object */
 905         code = (struct code *) ((unsigned long) fheader - offset);
 906         ncode = trans_code(code);
 907
 908         return ((lispobj) LOW_WORD(ncode) + offset) | type_FunctionPointer;
 909 }
 910
 911
 912 \f
 913 /* instances */
 914
 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 *) native_pointer(object);
 922
 923   *where = *first_pointer = trans_boxed(object);
 924   return 1;
 925 }
 926
 927 \f
 928 /* lists and conses */
 929
 930 static lispobj trans_list(lispobj object);
 931
 932 static int
 933 scav_list_pointer(lispobj *where, lispobj object)
 934 {
 935   lispobj first, *first_pointer;
 936
 937   gc_assert(is_lisp_pointer(object));
 938
 939   /* object is a pointer into from space.  Not a FP. */
 940   first_pointer = (lispobj *) native_pointer(object);
 941
 942   first = *first_pointer = trans_list(object);
 943
 944   gc_assert(is_lisp_pointer(first));
 945   gc_assert(!from_space_p(first));
 946
 947   *where = first;
 948   return 1;
 949 }
 950
 951 static lispobj
 952 trans_list(lispobj object)
 953 {
 954         lispobj new_list_pointer;
 955         struct cons *cons, *new_cons;
 956
 957         cons = (struct cons *) native_pointer(object);
 958
 959         /* ### Don't use copy_object here. */
 960         new_list_pointer = copy_object(object, 2);
 961         new_cons = (struct cons *) native_pointer(new_list_pointer);
 962
 963         /* Set forwarding pointer. */
 964         cons->car = new_list_pointer;
 965
 966         /* Try to linearize the list in the cdr direction to help reduce */
 967         /* paging. */
 968
 969         while (1) {
 970                 lispobj cdr, new_cdr, first;
 971                 struct cons *cdr_cons, *new_cdr_cons;
 972
 973                 cdr = cons->cdr;
 974
 975                 if (LowtagOf(cdr) != type_ListPointer ||
 976                     !from_space_p(cdr) ||
 977                     (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
 978                      && new_space_p(first)))
 979                         break;
 980
 981                 cdr_cons = (struct cons *) native_pointer(cdr);
 982
 983                 /* ### Don't use copy_object here */
 984                 new_cdr = copy_object(cdr, 2);
 985                 new_cdr_cons = (struct cons *) native_pointer(new_cdr);
 986
 987                 /* Set forwarding pointer */
 988                 cdr_cons->car = new_cdr;
 989
 990                 /* Update the cdr of the last cons copied into new */
 991                 /* space to keep the newspace scavenge from having to */
 992                 /* do it. */
 993                 new_cons->cdr = new_cdr;
 994
 995                 cons = cdr_cons;
 996                 new_cons = new_cdr_cons;
 997         }
 998
 999         return new_list_pointer;
1000 }
1001
1002 \f
1003 /* scavenging and transporting other pointers */
1004
1005 static int
1006 scav_other_pointer(lispobj *where, lispobj object)
1007 {
1008   lispobj first, *first_pointer;
1009
1010   gc_assert(is_lisp_pointer(object));
1011
1012   /* Object is a pointer into from space - not a FP */
1013   first_pointer = (lispobj *) native_pointer(object);
1014   first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
1015
1016   gc_assert(is_lisp_pointer(first));
1017   gc_assert(!from_space_p(first));
1018
1019   *where = first;
1020   return 1;
1021 }
1022
1023 \f
1024 /* immediate, boxed, and unboxed objects */
1025
1026 static int
1027 size_pointer(lispobj *where)
1028 {
1029     return 1;
1030 }
1031
1032 static int
1033 scav_immediate(lispobj *where, lispobj object)
1034 {
1035     return 1;
1036 }
1037
1038 static lispobj
1039 trans_immediate(lispobj object)
1040 {
1041     fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
1042     lose(NULL);
1043     return NIL;
1044 }
1045
1046 static int
1047 size_immediate(lispobj *where)
1048 {
1049     return 1;
1050 }
1051
1052
1053 static int
1054 scav_boxed(lispobj *where, lispobj object)
1055 {
1056     return 1;
1057 }
1058
1059 static lispobj
1060 trans_boxed(lispobj object)
1061 {
1062         lispobj header;
1063         unsigned long length;
1064
1065         gc_assert(is_lisp_pointer(object));
1066
1067         header = *((lispobj *) native_pointer(object));
1068         length = HeaderValue(header) + 1;
1069         length = CEILING(length, 2);
1070
1071         return copy_object(object, length);
1072 }
1073
1074 static int
1075 size_boxed(lispobj *where)
1076 {
1077         lispobj header;
1078         unsigned long length;
1079
1080         header = *where;
1081         length = HeaderValue(header) + 1;
1082         length = CEILING(length, 2);
1083
1084         return length;
1085 }
1086
1087 /* Note: on the sparc we don't have to do anything special for fdefns, */
1088 /* 'cause the raw-addr has a function lowtag. */
1089 #ifndef sparc
1090 static int
1091 scav_fdefn(lispobj *where, lispobj object)
1092 {
1093     struct fdefn *fdefn;
1094
1095     fdefn = (struct fdefn *)where;
1096
1097     if ((char *)(fdefn->function + RAW_ADDR_OFFSET)
1098         == (char *)((unsigned long)(fdefn->raw_addr))) {
1099         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
1100         fdefn->raw_addr = (u32)  ((char *) LOW_WORD(fdefn->function)) + RAW_ADDR_OFFSET;
1101         return sizeof(struct fdefn) / sizeof(lispobj);
1102     }
1103     else
1104         return 1;
1105 }
1106 #endif
1107
1108 static int
1109 scav_unboxed(lispobj *where, lispobj object)
1110 {
1111         unsigned long length;
1112
1113         length = HeaderValue(object) + 1;
1114         length = CEILING(length, 2);
1115
1116         return length;
1117 }
1118
1119 static lispobj
1120 trans_unboxed(lispobj object)
1121 {
1122         lispobj header;
1123         unsigned long length;
1124
1125
1126         gc_assert(is_lisp_pointer(object));
1127
1128         header = *((lispobj *) native_pointer(object));
1129         length = HeaderValue(header) + 1;
1130         length = CEILING(length, 2);
1131
1132         return copy_object(object, length);
1133 }
1134
1135 static int
1136 size_unboxed(lispobj *where)
1137 {
1138         lispobj header;
1139         unsigned long length;
1140
1141         header = *where;
1142         length = HeaderValue(header) + 1;
1143         length = CEILING(length, 2);
1144
1145         return length;
1146 }
1147
1148 \f
1149 /* vector-like objects */
1150
1151 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1152
1153 static int
1154 scav_string(lispobj *where, lispobj object)
1155 {
1156         struct vector *vector;
1157         int length, nwords;
1158
1159         /* NOTE: Strings contain one more byte of data than the length */
1160         /* slot indicates. */
1161
1162         vector = (struct vector *) where;
1163         length = fixnum_value(vector->length) + 1;
1164         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1165
1166         return nwords;
1167 }
1168
1169 static lispobj
1170 trans_string(lispobj object)
1171 {
1172         struct vector *vector;
1173         int length, nwords;
1174
1175         gc_assert(is_lisp_pointer(object));
1176
1177         /* NOTE: Strings contain one more byte of data than the length */
1178         /* slot indicates. */
1179
1180         vector = (struct vector *) native_pointer(object);
1181         length = fixnum_value(vector->length) + 1;
1182         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1183
1184         return copy_object(object, nwords);
1185 }
1186
1187 static int
1188 size_string(lispobj *where)
1189 {
1190         struct vector *vector;
1191         int length, nwords;
1192
1193         /* NOTE: Strings contain one more byte of data than the length */
1194         /* slot indicates. */
1195
1196         vector = (struct vector *) where;
1197         length = fixnum_value(vector->length) + 1;
1198         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1199
1200         return nwords;
1201 }
1202
1203 static int
1204 scav_vector(lispobj *where, lispobj object)
1205 {
1206     if (HeaderValue(object) == subtype_VectorValidHashing)
1207         *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
1208
1209     return 1;
1210 }
1211
1212
1213 static lispobj
1214 trans_vector(lispobj object)
1215 {
1216         struct vector *vector;
1217         int length, nwords;
1218
1219         gc_assert(is_lisp_pointer(object));
1220
1221         vector = (struct vector *) native_pointer(object);
1222
1223         length = fixnum_value(vector->length);
1224         nwords = CEILING(length + 2, 2);
1225
1226         return copy_object(object, nwords);
1227 }
1228
1229 static int
1230 size_vector(lispobj *where)
1231 {
1232         struct vector *vector;
1233         int length, nwords;
1234
1235         vector = (struct vector *) where;
1236         length = fixnum_value(vector->length);
1237         nwords = CEILING(length + 2, 2);
1238
1239         return nwords;
1240 }
1241
1242
1243 static int
1244 scav_vector_bit(lispobj *where, lispobj object)
1245 {
1246         struct vector *vector;
1247         int length, nwords;
1248
1249         vector = (struct vector *) where;
1250         length = fixnum_value(vector->length);
1251         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1252
1253         return nwords;
1254 }
1255
1256 static lispobj
1257 trans_vector_bit(lispobj object)
1258 {
1259         struct vector *vector;
1260         int length, nwords;
1261
1262         gc_assert(is_lisp_pointer(object));
1263
1264         vector = (struct vector *) native_pointer(object);
1265         length = fixnum_value(vector->length);
1266         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1267
1268         return copy_object(object, nwords);
1269 }
1270
1271 static int
1272 size_vector_bit(lispobj *where)
1273 {
1274         struct vector *vector;
1275         int length, nwords;
1276
1277         vector = (struct vector *) where;
1278         length = fixnum_value(vector->length);
1279         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1280
1281         return nwords;
1282 }
1283
1284
1285 static int
1286 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
1287 {
1288         struct vector *vector;
1289         int length, nwords;
1290
1291         vector = (struct vector *) where;
1292         length = fixnum_value(vector->length);
1293         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1294
1295         return nwords;
1296 }
1297
1298 static lispobj
1299 trans_vector_unsigned_byte_2(lispobj object)
1300 {
1301         struct vector *vector;
1302         int length, nwords;
1303
1304         gc_assert(is_lisp_pointer(object));
1305
1306         vector = (struct vector *) native_pointer(object);
1307         length = fixnum_value(vector->length);
1308         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1309
1310         return copy_object(object, nwords);
1311 }
1312
1313 static int
1314 size_vector_unsigned_byte_2(lispobj *where)
1315 {
1316         struct vector *vector;
1317         int length, nwords;
1318
1319         vector = (struct vector *) where;
1320         length = fixnum_value(vector->length);
1321         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1322
1323         return nwords;
1324 }
1325
1326
1327 static int
1328 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1329 {
1330         struct vector *vector;
1331         int length, nwords;
1332
1333         vector = (struct vector *) where;
1334         length = fixnum_value(vector->length);
1335         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1336
1337         return nwords;
1338 }
1339
1340 static lispobj
1341 trans_vector_unsigned_byte_4(lispobj object)
1342 {
1343         struct vector *vector;
1344         int length, nwords;
1345
1346         gc_assert(is_lisp_pointer(object));
1347
1348         vector = (struct vector *) native_pointer(object);
1349         length = fixnum_value(vector->length);
1350         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1351
1352         return copy_object(object, nwords);
1353 }
1354
1355 static int
1356 size_vector_unsigned_byte_4(lispobj *where)
1357 {
1358         struct vector *vector;
1359         int length, nwords;
1360
1361         vector = (struct vector *) where;
1362         length = fixnum_value(vector->length);
1363         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1364
1365         return nwords;
1366 }
1367
1368
1369 static int
1370 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1371 {
1372         struct vector *vector;
1373         int length, nwords;
1374
1375         vector = (struct vector *) where;
1376         length = fixnum_value(vector->length);
1377         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1378
1379         return nwords;
1380 }
1381
1382 static lispobj
1383 trans_vector_unsigned_byte_8(lispobj object)
1384 {
1385         struct vector *vector;
1386         int length, nwords;
1387
1388         gc_assert(is_lisp_pointer(object));
1389
1390         vector = (struct vector *) native_pointer(object);
1391         length = fixnum_value(vector->length);
1392         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1393
1394         return copy_object(object, nwords);
1395 }
1396
1397 static int
1398 size_vector_unsigned_byte_8(lispobj *where)
1399 {
1400         struct vector *vector;
1401         int length, nwords;
1402
1403         vector = (struct vector *) where;
1404         length = fixnum_value(vector->length);
1405         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1406
1407         return nwords;
1408 }
1409
1410
1411 static int
1412 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1413 {
1414         struct vector *vector;
1415         int length, nwords;
1416
1417         vector = (struct vector *) where;
1418         length = fixnum_value(vector->length);
1419         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1420
1421         return nwords;
1422 }
1423
1424 static lispobj
1425 trans_vector_unsigned_byte_16(lispobj object)
1426 {
1427         struct vector *vector;
1428         int length, nwords;
1429
1430         gc_assert(is_lisp_pointer(object));
1431
1432         vector = (struct vector *) native_pointer(object);
1433         length = fixnum_value(vector->length);
1434         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1435
1436         return copy_object(object, nwords);
1437 }
1438
1439 static int
1440 size_vector_unsigned_byte_16(lispobj *where)
1441 {
1442         struct vector *vector;
1443         int length, nwords;
1444
1445         vector = (struct vector *) where;
1446         length = fixnum_value(vector->length);
1447         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1448
1449         return nwords;
1450 }
1451
1452
1453 static int
1454 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1455 {
1456         struct vector *vector;
1457         int length, nwords;
1458
1459         vector = (struct vector *) where;
1460         length = fixnum_value(vector->length);
1461         nwords = CEILING(length + 2, 2);
1462
1463         return nwords;
1464 }
1465
1466 static lispobj
1467 trans_vector_unsigned_byte_32(lispobj object)
1468 {
1469         struct vector *vector;
1470         int length, nwords;
1471
1472         gc_assert(is_lisp_pointer(object));
1473
1474         vector = (struct vector *) native_pointer(object);
1475         length = fixnum_value(vector->length);
1476         nwords = CEILING(length + 2, 2);
1477
1478         return copy_object(object, nwords);
1479 }
1480
1481 static int
1482 size_vector_unsigned_byte_32(lispobj *where)
1483 {
1484         struct vector *vector;
1485         int length, nwords;
1486
1487         vector = (struct vector *) where;
1488         length = fixnum_value(vector->length);
1489         nwords = CEILING(length + 2, 2);
1490
1491         return nwords;
1492 }
1493
1494
1495 static int
1496 scav_vector_single_float(lispobj *where, lispobj object)
1497 {
1498         struct vector *vector;
1499         int length, nwords;
1500
1501         vector = (struct vector *) where;
1502         length = fixnum_value(vector->length);
1503         nwords = CEILING(length + 2, 2);
1504
1505         return nwords;
1506 }
1507
1508 static lispobj
1509 trans_vector_single_float(lispobj object)
1510 {
1511         struct vector *vector;
1512         int length, nwords;
1513
1514         gc_assert(is_lisp_pointer(object));
1515
1516         vector = (struct vector *) native_pointer(object);
1517         length = fixnum_value(vector->length);
1518         nwords = CEILING(length + 2, 2);
1519
1520         return copy_object(object, nwords);
1521 }
1522
1523 static int
1524 size_vector_single_float(lispobj *where)
1525 {
1526         struct vector *vector;
1527         int length, nwords;
1528
1529         vector = (struct vector *) where;
1530         length = fixnum_value(vector->length);
1531         nwords = CEILING(length + 2, 2);
1532
1533         return nwords;
1534 }
1535
1536
1537 static int
1538 scav_vector_double_float(lispobj *where, lispobj object)
1539 {
1540         struct vector *vector;
1541         int length, nwords;
1542
1543         vector = (struct vector *) where;
1544         length = fixnum_value(vector->length);
1545         nwords = CEILING(length * 2 + 2, 2);
1546
1547         return nwords;
1548 }
1549
1550 static lispobj
1551 trans_vector_double_float(lispobj object)
1552 {
1553         struct vector *vector;
1554         int length, nwords;
1555
1556         gc_assert(is_lisp_pointer(object));
1557
1558         vector = (struct vector *) native_pointer(object);
1559         length = fixnum_value(vector->length);
1560         nwords = CEILING(length * 2 + 2, 2);
1561
1562         return copy_object(object, nwords);
1563 }
1564
1565 static int
1566 size_vector_double_float(lispobj *where)
1567 {
1568         struct vector *vector;
1569         int length, nwords;
1570
1571         vector = (struct vector *) where;
1572         length = fixnum_value(vector->length);
1573         nwords = CEILING(length * 2 + 2, 2);
1574
1575         return nwords;
1576 }
1577
1578
1579 #ifdef type_SimpleArrayLongFloat
1580 static int
1581 scav_vector_long_float(lispobj *where, lispobj object)
1582 {
1583         struct vector *vector;
1584         int length, nwords;
1585
1586         vector = (struct vector *) where;
1587         length = fixnum_value(vector->length);
1588 #ifdef sparc
1589         nwords = CEILING(length * 4 + 2, 2);
1590 #endif
1591
1592         return nwords;
1593 }
1594
1595 static lispobj
1596 trans_vector_long_float(lispobj object)
1597 {
1598         struct vector *vector;
1599         int length, nwords;
1600
1601         gc_assert(is_lisp_pointer(object));
1602
1603         vector = (struct vector *) native_pointer(object);
1604         length = fixnum_value(vector->length);
1605 #ifdef sparc
1606         nwords = CEILING(length * 4 + 2, 2);
1607 #endif
1608
1609         return copy_object(object, nwords);
1610 }
1611
1612 static int
1613 size_vector_long_float(lispobj *where)
1614 {
1615         struct vector *vector;
1616         int length, nwords;
1617
1618         vector = (struct vector *) where;
1619         length = fixnum_value(vector->length);
1620 #ifdef sparc
1621         nwords = CEILING(length * 4 + 2, 2);
1622 #endif
1623
1624         return nwords;
1625 }
1626 #endif
1627
1628
1629 #ifdef type_SimpleArrayComplexSingleFloat
1630 static int
1631 scav_vector_complex_single_float(lispobj *where, lispobj object)
1632 {
1633         struct vector *vector;
1634         int length, nwords;
1635
1636         vector = (struct vector *) where;
1637         length = fixnum_value(vector->length);
1638         nwords = CEILING(length * 2 + 2, 2);
1639
1640         return nwords;
1641 }
1642
1643 static lispobj
1644 trans_vector_complex_single_float(lispobj object)
1645 {
1646         struct vector *vector;
1647         int length, nwords;
1648
1649         gc_assert(is_lisp_pointer(object));
1650
1651         vector = (struct vector *) native_pointer(object);
1652         length = fixnum_value(vector->length);
1653         nwords = CEILING(length * 2 + 2, 2);
1654
1655         return copy_object(object, nwords);
1656 }
1657
1658 static int
1659 size_vector_complex_single_float(lispobj *where)
1660 {
1661         struct vector *vector;
1662         int length, nwords;
1663
1664         vector = (struct vector *) where;
1665         length = fixnum_value(vector->length);
1666         nwords = CEILING(length * 2 + 2, 2);
1667
1668         return nwords;
1669 }
1670 #endif
1671
1672 #ifdef type_SimpleArrayComplexDoubleFloat
1673 static int
1674 scav_vector_complex_double_float(lispobj *where, lispobj object)
1675 {
1676         struct vector *vector;
1677         int length, nwords;
1678
1679         vector = (struct vector *) where;
1680         length = fixnum_value(vector->length);
1681         nwords = CEILING(length * 4 + 2, 2);
1682
1683         return nwords;
1684 }
1685
1686 static lispobj
1687 trans_vector_complex_double_float(lispobj object)
1688 {
1689         struct vector *vector;
1690         int length, nwords;
1691
1692         gc_assert(is_lisp_pointer(object));
1693
1694         vector = (struct vector *) native_pointer(object);
1695         length = fixnum_value(vector->length);
1696         nwords = CEILING(length * 4 + 2, 2);
1697
1698         return copy_object(object, nwords);
1699 }
1700
1701 static int
1702 size_vector_complex_double_float(lispobj *where)
1703 {
1704         struct vector *vector;
1705         int length, nwords;
1706
1707         vector = (struct vector *) where;
1708         length = fixnum_value(vector->length);
1709         nwords = CEILING(length * 4 + 2, 2);
1710
1711         return nwords;
1712 }
1713 #endif
1714
1715 #ifdef type_SimpleArrayComplexLongFloat
1716 static int
1717 scav_vector_complex_long_float(lispobj *where, lispobj object)
1718 {
1719         struct vector *vector;
1720         int length, nwords;
1721
1722         vector = (struct vector *) where;
1723         length = fixnum_value(vector->length);
1724 #ifdef sparc
1725         nwords = CEILING(length * 8 + 2, 2);
1726 #endif
1727
1728         return nwords;
1729 }
1730
1731 static lispobj
1732 trans_vector_complex_long_float(lispobj object)
1733 {
1734         struct vector *vector;
1735         int length, nwords;
1736
1737         gc_assert(is_lisp_pointer(object));
1738
1739         vector = (struct vector *) native_pointer(object);
1740         length = fixnum_value(vector->length);
1741 #ifdef sparc
1742         nwords = CEILING(length * 8 + 2, 2);
1743 #endif
1744
1745         return copy_object(object, nwords);
1746 }
1747
1748 static int
1749 size_vector_complex_long_float(lispobj *where)
1750 {
1751         struct vector *vector;
1752         int length, nwords;
1753
1754         vector = (struct vector *) where;
1755         length = fixnum_value(vector->length);
1756 #ifdef sparc
1757         nwords = CEILING(length * 8 + 2, 2);
1758 #endif
1759
1760         return nwords;
1761 }
1762 #endif
1763
1764 \f
1765 /* weak pointers */
1766
1767 #define WEAK_POINTER_NWORDS \
1768         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1769
1770 static int
1771 scav_weak_pointer(lispobj *where, lispobj object)
1772 {
1773         /* Do not let GC scavenge the value slot of the weak pointer */
1774         /* (that is why it is a weak pointer).  Note:  we could use */
1775         /* the scav_unboxed method here. */
1776
1777         return WEAK_POINTER_NWORDS;
1778 }
1779
1780 static lispobj
1781 trans_weak_pointer(lispobj object)
1782 {
1783         lispobj copy;
1784         struct weak_pointer *wp;
1785
1786         gc_assert(is_lisp_pointer(object));
1787
1788 #if defined(DEBUG_WEAK)
1789         printf("Transporting weak pointer from 0x%08x\n", object);
1790 #endif
1791
1792         /* Need to remember where all the weak pointers are that have */
1793         /* been transported so they can be fixed up in a post-GC pass. */
1794
1795         copy = copy_object(object, WEAK_POINTER_NWORDS);
1796         wp = (struct weak_pointer *) native_pointer(copy);
1797
1798
1799         /* Push the weak pointer onto the list of weak pointers. */
1800         wp->next = LOW_WORD(weak_pointers);
1801         weak_pointers = wp;
1802
1803         return copy;
1804 }
1805
1806 static int
1807 size_weak_pointer(lispobj *where)
1808 {
1809         return WEAK_POINTER_NWORDS;
1810 }
1811
1812 void scan_weak_pointers(void)
1813 {
1814         struct weak_pointer *wp;
1815
1816         for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1817              wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1818                 lispobj value;
1819                 lispobj first, *first_pointer;
1820
1821                 value = wp->value;
1822
1823 #if defined(DEBUG_WEAK)
1824                 printf("Weak pointer at 0x%p\n",  wp);
1825                 printf("Value: 0x%08x\n", (unsigned int) value);
1826 #endif
1827
1828                 if (!(is_lisp_pointer(value) && from_space_p(value)))
1829                         continue;
1830
1831                 /* Now, we need to check if the object has been */
1832                 /* forwarded.  If it has been, the weak pointer is */
1833                 /* still good and needs to be updated.  Otherwise, the */
1834                 /* weak pointer needs to be nil'ed out. */
1835
1836                 first_pointer = (lispobj *) native_pointer(value);
1837                 first = *first_pointer;
1838
1839 #if defined(DEBUG_WEAK)
1840                 printf("First: 0x%08x\n", (unsigned long) first);
1841 #endif
1842
1843                 if (is_lisp_pointer(first) && new_space_p(first))
1844                         wp->value = first;
1845                 else {
1846                         wp->value = NIL;
1847                         wp->broken = T;
1848                 }
1849         }
1850 }
1851
1852
1853 \f
1854 /* initialization */
1855
1856 static int
1857 scav_lose(lispobj *where, lispobj object)
1858 {
1859     fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x (at 0x%016lx)\n",
1860             (unsigned int) object, (unsigned long)where);
1861     lose(NULL);
1862     return 0;
1863 }
1864
1865 static lispobj
1866 trans_lose(lispobj object)
1867 {
1868     fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
1869             (unsigned int)object);
1870     lose(NULL);
1871     return NIL;
1872 }
1873
1874 static int
1875 size_lose(lispobj *where)
1876 {
1877         fprintf(stderr, "Size lossage.  No size function for object at 0x%p\n",
1878                 where);
1879         fprintf(stderr, "First word of object: 0x%08x\n",
1880                 (u32) *where);
1881         return 1;
1882 }
1883
1884 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1885  * precise generational GC is revived, it might have three. It would
1886  * be nice to share the scavtab[] data set up here, and perhaps other
1887  * things too, between all of them, rather than trying to maintain
1888  * multiple copies. -- WHN 2001-05-09 */
1889 void
1890 gc_init(void)
1891 {
1892         int i;
1893
1894         /* scavenge table */
1895         for (i = 0; i < 256; i++)
1896             scavtab[i] = scav_lose;
1897         /* scavtab[i] = scav_immediate; */
1898
1899         for (i = 0; i < 32; i++) {
1900                 scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
1901                 scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
1902                 /* OtherImmediate0 */
1903                 scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
1904                 scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
1905                 scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
1906                 /* OtherImmediate1 */
1907                 scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
1908         }
1909
1910         scavtab[type_Bignum] = scav_unboxed;
1911         scavtab[type_Ratio] = scav_boxed;
1912         scavtab[type_SingleFloat] = scav_unboxed;
1913         scavtab[type_DoubleFloat] = scav_unboxed;
1914 #ifdef type_LongFloat
1915         scavtab[type_LongFloat] = scav_unboxed;
1916 #endif
1917         scavtab[type_Complex] = scav_boxed;
1918 #ifdef type_ComplexSingleFloat
1919         scavtab[type_ComplexSingleFloat] = scav_unboxed;
1920 #endif
1921 #ifdef type_ComplexDoubleFloat
1922         scavtab[type_ComplexDoubleFloat] = scav_unboxed;
1923 #endif
1924 #ifdef type_ComplexLongFloat
1925         scavtab[type_ComplexLongFloat] = scav_unboxed;
1926 #endif
1927         scavtab[type_SimpleArray] = scav_boxed;
1928         scavtab[type_SimpleString] = scav_string;
1929         scavtab[type_SimpleBitVector] = scav_vector_bit;
1930         scavtab[type_SimpleVector] = scav_vector;
1931         scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
1932         scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
1933         scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
1934         scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
1935         scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
1936 #ifdef type_SimpleArraySignedByte8
1937         scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
1938 #endif
1939 #ifdef type_SimpleArraySignedByte16
1940         scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
1941 #endif
1942 #ifdef type_SimpleArraySignedByte30
1943         scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
1944 #endif
1945 #ifdef type_SimpleArraySignedByte32
1946         scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
1947 #endif
1948         scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
1949         scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
1950 #ifdef type_SimpleArrayLongFloat
1951         scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
1952 #endif
1953 #ifdef type_SimpleArrayComplexSingleFloat
1954         scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
1955 #endif
1956 #ifdef type_SimpleArrayComplexDoubleFloat
1957         scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
1958 #endif
1959 #ifdef type_SimpleArrayComplexLongFloat
1960         scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
1961 #endif
1962         scavtab[type_ComplexString] = scav_boxed;
1963         scavtab[type_ComplexBitVector] = scav_boxed;
1964         scavtab[type_ComplexVector] = scav_boxed;
1965         scavtab[type_ComplexArray] = scav_boxed;
1966         scavtab[type_CodeHeader] = scav_code_header;
1967         scavtab[type_FunctionHeader] = scav_function_header;
1968         scavtab[type_ClosureFunctionHeader] = scav_function_header;
1969         scavtab[type_ReturnPcHeader] = scav_return_pc_header;
1970 #ifdef __i386__
1971         scavtab[type_ClosureHeader] = scav_closure_header;
1972         scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
1973         scavtab[type_ByteCodeFunction] = scav_closure_header;
1974         scavtab[type_ByteCodeClosure] = scav_closure_header;
1975         /*      scavtab[type_DylanFunctionHeader] = scav_closure_header; */
1976 #else
1977         scavtab[type_ClosureHeader] = scav_boxed;
1978         scavtab[type_FuncallableInstanceHeader] = scav_boxed;
1979         scavtab[type_ByteCodeFunction] = scav_boxed;
1980         scavtab[type_ByteCodeClosure] = scav_boxed;
1981         /* scavtab[type_DylanFunctionHeader] = scav_boxed; */
1982 #endif
1983         scavtab[type_ValueCellHeader] = scav_boxed;
1984         scavtab[type_SymbolHeader] = scav_boxed;
1985         scavtab[type_BaseChar] = scav_immediate;
1986         scavtab[type_Sap] = scav_unboxed;
1987         scavtab[type_UnboundMarker] = scav_immediate;
1988         scavtab[type_WeakPointer] = scav_weak_pointer;
1989         scavtab[type_InstanceHeader] = scav_boxed;
1990 #ifndef sparc
1991         scavtab[type_Fdefn] = scav_fdefn;
1992 #else
1993         scavtab[type_Fdefn] = scav_boxed;
1994 #endif
1995
1996         /* Transport Other Table */
1997         for (i = 0; i < 256; i++)
1998                 transother[i] = trans_lose;
1999
2000         transother[type_Bignum] = trans_unboxed;
2001         transother[type_Ratio] = trans_boxed;
2002         transother[type_SingleFloat] = trans_unboxed;
2003         transother[type_DoubleFloat] = trans_unboxed;
2004 #ifdef type_LongFloat
2005         transother[type_LongFloat] = trans_unboxed;
2006 #endif
2007         transother[type_Complex] = trans_boxed;
2008 #ifdef type_ComplexSingleFloat
2009         transother[type_ComplexSingleFloat] = trans_unboxed;
2010 #endif
2011 #ifdef type_ComplexDoubleFloat
2012         transother[type_ComplexDoubleFloat] = trans_unboxed;
2013 #endif
2014 #ifdef type_ComplexLongFloat
2015         transother[type_ComplexLongFloat] = trans_unboxed;
2016 #endif
2017         transother[type_SimpleArray] = trans_boxed;
2018         transother[type_SimpleString] = trans_string;
2019         transother[type_SimpleBitVector] = trans_vector_bit;
2020         transother[type_SimpleVector] = trans_vector;
2021         transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2022         transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2023         transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2024         transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2025         transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
2026 #ifdef type_SimpleArraySignedByte8
2027         transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
2028 #endif
2029 #ifdef type_SimpleArraySignedByte16
2030         transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
2031 #endif
2032 #ifdef type_SimpleArraySignedByte30
2033         transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
2034 #endif
2035 #ifdef type_SimpleArraySignedByte32
2036         transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
2037 #endif
2038         transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2039         transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
2040 #ifdef type_SimpleArrayLongFloat
2041         transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
2042 #endif
2043 #ifdef type_SimpleArrayComplexSingleFloat
2044         transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
2045 #endif
2046 #ifdef type_SimpleArrayComplexDoubleFloat
2047         transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
2048 #endif
2049 #ifdef type_SimpleArrayComplexLongFloat
2050         transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
2051 #endif
2052         transother[type_ComplexString] = trans_boxed;
2053         transother[type_ComplexBitVector] = trans_boxed;
2054         transother[type_ComplexVector] = trans_boxed;
2055         transother[type_ComplexArray] = trans_boxed;
2056         transother[type_CodeHeader] = trans_code_header;
2057         transother[type_FunctionHeader] = trans_function_header;
2058         transother[type_ClosureFunctionHeader] = trans_function_header;
2059         transother[type_ReturnPcHeader] = trans_return_pc_header;
2060         transother[type_ClosureHeader] = trans_boxed;
2061         transother[type_FuncallableInstanceHeader] = trans_boxed;
2062         transother[type_ByteCodeFunction] = trans_boxed;
2063         transother[type_ByteCodeClosure] = trans_boxed;
2064         transother[type_ValueCellHeader] = trans_boxed;
2065         transother[type_SymbolHeader] = trans_boxed;
2066         transother[type_BaseChar] = trans_immediate;
2067         transother[type_Sap] = trans_unboxed;
2068         transother[type_UnboundMarker] = trans_immediate;
2069         transother[type_WeakPointer] = trans_weak_pointer;
2070         transother[type_InstanceHeader] = trans_boxed;
2071         transother[type_Fdefn] = trans_boxed;
2072
2073         /* Size table */
2074
2075         for (i = 0; i < 256; i++)
2076                 sizetab[i] = size_lose;
2077
2078         for (i = 0; i < 32; i++) {
2079                 sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
2080                 sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
2081                 /* OtherImmediate0 */
2082                 sizetab[type_ListPointer|(i<<3)] = size_pointer;
2083                 sizetab[type_OddFixnum|(i<<3)] = size_immediate;
2084                 sizetab[type_InstancePointer|(i<<3)] = size_pointer;
2085                 /* OtherImmediate1 */
2086                 sizetab[type_OtherPointer|(i<<3)] = size_pointer;
2087         }
2088
2089         sizetab[type_Bignum] = size_unboxed;
2090         sizetab[type_Ratio] = size_boxed;
2091         sizetab[type_SingleFloat] = size_unboxed;
2092         sizetab[type_DoubleFloat] = size_unboxed;
2093 #ifdef type_LongFloat
2094         sizetab[type_LongFloat] = size_unboxed;
2095 #endif
2096         sizetab[type_Complex] = size_boxed;
2097 #ifdef type_ComplexSingleFloat
2098         sizetab[type_ComplexSingleFloat] = size_unboxed;
2099 #endif
2100 #ifdef type_ComplexDoubleFloat
2101         sizetab[type_ComplexDoubleFloat] = size_unboxed;
2102 #endif
2103 #ifdef type_ComplexLongFloat
2104         sizetab[type_ComplexLongFloat] = size_unboxed;
2105 #endif
2106         sizetab[type_SimpleArray] = size_boxed;
2107         sizetab[type_SimpleString] = size_string;
2108         sizetab[type_SimpleBitVector] = size_vector_bit;
2109         sizetab[type_SimpleVector] = size_vector;
2110         sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2111         sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2112         sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2113         sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2114         sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
2115 #ifdef type_SimpleArraySignedByte8
2116         sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
2117 #endif
2118 #ifdef type_SimpleArraySignedByte16
2119         sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
2120 #endif
2121 #ifdef type_SimpleArraySignedByte30
2122         sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
2123 #endif
2124 #ifdef type_SimpleArraySignedByte32
2125         sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
2126 #endif
2127         sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2128         sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
2129 #ifdef type_SimpleArrayLongFloat
2130         sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
2131 #endif
2132 #ifdef type_SimpleArrayComplexSingleFloat
2133         sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
2134 #endif
2135 #ifdef type_SimpleArrayComplexDoubleFloat
2136         sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
2137 #endif
2138 #ifdef type_SimpleArrayComplexLongFloat
2139         sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
2140 #endif
2141         sizetab[type_ComplexString] = size_boxed;
2142         sizetab[type_ComplexBitVector] = size_boxed;
2143         sizetab[type_ComplexVector] = size_boxed;
2144         sizetab[type_ComplexArray] = size_boxed;
2145         sizetab[type_CodeHeader] = size_code_header;
2146 #if 0
2147         /* Shouldn't see these so just lose if it happens */
2148         sizetab[type_FunctionHeader] = size_function_header;
2149         sizetab[type_ClosureFunctionHeader] = size_function_header;
2150         sizetab[type_ReturnPcHeader] = size_return_pc_header;
2151 #endif
2152         sizetab[type_ClosureHeader] = size_boxed;
2153         sizetab[type_FuncallableInstanceHeader] = size_boxed;
2154         sizetab[type_ValueCellHeader] = size_boxed;
2155         sizetab[type_SymbolHeader] = size_boxed;
2156         sizetab[type_BaseChar] = size_immediate;
2157         sizetab[type_Sap] = size_unboxed;
2158         sizetab[type_UnboundMarker] = size_immediate;
2159         sizetab[type_WeakPointer] = size_weak_pointer;
2160         sizetab[type_InstanceHeader] = size_boxed;
2161         sizetab[type_Fdefn] = size_boxed;
2162 }
2163 \f
2164 /* noise to manipulate the gc trigger stuff */
2165
2166 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2167 {
2168     os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2169         dynamic_usage;
2170     long length =
2171         DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2172
2173     if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2174         fprintf(stderr,
2175            "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2176                 (unsigned int)dynamic_usage,
2177                 (os_vm_address_t)dynamic_space_free_pointer
2178                 - (os_vm_address_t)current_dynamic_space);
2179         return;
2180     }
2181     else if (length < 0) {
2182         fprintf(stderr,
2183                 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2184                 dynamic_usage);
2185         return;
2186     }
2187
2188     addr=os_round_up_to_page(addr);
2189     length=os_trunc_size_to_page(length);
2190
2191 #if defined(SUNOS) || defined(SOLARIS)
2192     os_invalidate(addr,length);
2193 #else
2194     os_protect(addr, length, 0);
2195 #endif
2196
2197     current_auto_gc_trigger = (lispobj *)addr;
2198 }
2199
2200 void clear_auto_gc_trigger(void)
2201 {
2202     if(current_auto_gc_trigger!=NULL){
2203 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2204         os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2205         os_vm_size_t length=
2206             DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2207
2208         os_validate(addr,length);
2209 #else
2210         os_protect((os_vm_address_t)current_dynamic_space,
2211                    DYNAMIC_SPACE_SIZE,
2212                    OS_VM_PROT_ALL);
2213 #endif
2214
2215         current_auto_gc_trigger = NULL;
2216     }
2217 }