src/runtime/gc.c

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