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