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