src/runtime/gc.c

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