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