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