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