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         /* Calculate 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 static int
1499 scav_vector_single_float(lispobj *where, lispobj object)
1500 {
1501     struct vector *vector;
1502     int length, nwords;
1503
1504     vector = (struct vector *) where;
1505     length = fixnum_value(vector->length);
1506     nwords = CEILING(length + 2, 2);
1507
1508     return nwords;
1509 }
1510
1511 static lispobj
1512 trans_vector_single_float(lispobj object)
1513 {
1514     struct vector *vector;
1515     int length, nwords;
1516
1517     gc_assert(is_lisp_pointer(object));
1518
1519     vector = (struct vector *) native_pointer(object);
1520     length = fixnum_value(vector->length);
1521     nwords = CEILING(length + 2, 2);
1522
1523     return copy_object(object, nwords);
1524 }
1525
1526 static int
1527 size_vector_single_float(lispobj *where)
1528 {
1529     struct vector *vector;
1530     int length, nwords;
1531
1532     vector = (struct vector *) where;
1533     length = fixnum_value(vector->length);
1534     nwords = CEILING(length + 2, 2);
1535
1536     return nwords;
1537 }
1538
1539
1540 static int
1541 scav_vector_double_float(lispobj *where, lispobj object)
1542 {
1543     struct vector *vector;
1544     int length, nwords;
1545
1546     vector = (struct vector *) where;
1547     length = fixnum_value(vector->length);
1548     nwords = CEILING(length * 2 + 2, 2);
1549
1550     return nwords;
1551 }
1552
1553 static lispobj
1554 trans_vector_double_float(lispobj object)
1555 {
1556     struct vector *vector;
1557     int length, nwords;
1558
1559     gc_assert(is_lisp_pointer(object));
1560
1561     vector = (struct vector *) native_pointer(object);
1562     length = fixnum_value(vector->length);
1563     nwords = CEILING(length * 2 + 2, 2);
1564
1565     return copy_object(object, nwords);
1566 }
1567
1568 static int
1569 size_vector_double_float(lispobj *where)
1570 {
1571     struct vector *vector;
1572     int length, nwords;
1573
1574     vector = (struct vector *) where;
1575     length = fixnum_value(vector->length);
1576     nwords = CEILING(length * 2 + 2, 2);
1577
1578     return nwords;
1579 }
1580
1581
1582 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1583 static int
1584 scav_vector_long_float(lispobj *where, lispobj object)
1585 {
1586     struct vector *vector;
1587     int length, nwords;
1588
1589     vector = (struct vector *) where;
1590     length = fixnum_value(vector->length);
1591 #ifdef sparc
1592     nwords = CEILING(length * 4 + 2, 2);
1593 #endif
1594
1595     return nwords;
1596 }
1597
1598 static lispobj
1599 trans_vector_long_float(lispobj object)
1600 {
1601     struct vector *vector;
1602     int length, nwords;
1603
1604     gc_assert(is_lisp_pointer(object));
1605
1606     vector = (struct vector *) native_pointer(object);
1607     length = fixnum_value(vector->length);
1608 #ifdef sparc
1609     nwords = CEILING(length * 4 + 2, 2);
1610 #endif
1611
1612     return copy_object(object, nwords);
1613 }
1614
1615 static int
1616 size_vector_long_float(lispobj *where)
1617 {
1618     struct vector *vector;
1619     int length, nwords;
1620
1621     vector = (struct vector *) where;
1622     length = fixnum_value(vector->length);
1623 #ifdef sparc
1624     nwords = CEILING(length * 4 + 2, 2);
1625 #endif
1626
1627     return nwords;
1628 }
1629 #endif
1630
1631
1632 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1633 static int
1634 scav_vector_complex_single_float(lispobj *where, lispobj object)
1635 {
1636     struct vector *vector;
1637     int length, nwords;
1638
1639     vector = (struct vector *) where;
1640     length = fixnum_value(vector->length);
1641     nwords = CEILING(length * 2 + 2, 2);
1642
1643     return nwords;
1644 }
1645
1646 static lispobj
1647 trans_vector_complex_single_float(lispobj object)
1648 {
1649     struct vector *vector;
1650     int length, nwords;
1651
1652     gc_assert(is_lisp_pointer(object));
1653
1654     vector = (struct vector *) native_pointer(object);
1655     length = fixnum_value(vector->length);
1656     nwords = CEILING(length * 2 + 2, 2);
1657
1658     return copy_object(object, nwords);
1659 }
1660
1661 static int
1662 size_vector_complex_single_float(lispobj *where)
1663 {
1664     struct vector *vector;
1665     int length, nwords;
1666
1667     vector = (struct vector *) where;
1668     length = fixnum_value(vector->length);
1669     nwords = CEILING(length * 2 + 2, 2);
1670
1671     return nwords;
1672 }
1673 #endif
1674
1675 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1676 static int
1677 scav_vector_complex_double_float(lispobj *where, lispobj object)
1678 {
1679     struct vector *vector;
1680     int length, nwords;
1681
1682     vector = (struct vector *) where;
1683     length = fixnum_value(vector->length);
1684     nwords = CEILING(length * 4 + 2, 2);
1685
1686     return nwords;
1687 }
1688
1689 static lispobj
1690 trans_vector_complex_double_float(lispobj object)
1691 {
1692     struct vector *vector;
1693     int length, nwords;
1694
1695     gc_assert(is_lisp_pointer(object));
1696
1697     vector = (struct vector *) native_pointer(object);
1698     length = fixnum_value(vector->length);
1699     nwords = CEILING(length * 4 + 2, 2);
1700
1701     return copy_object(object, nwords);
1702 }
1703
1704 static int
1705 size_vector_complex_double_float(lispobj *where)
1706 {
1707     struct vector *vector;
1708     int length, nwords;
1709
1710     vector = (struct vector *) where;
1711     length = fixnum_value(vector->length);
1712     nwords = CEILING(length * 4 + 2, 2);
1713
1714     return nwords;
1715 }
1716 #endif
1717
1718 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1719 static int
1720 scav_vector_complex_long_float(lispobj *where, lispobj object)
1721 {
1722     struct vector *vector;
1723     int length, nwords;
1724
1725     vector = (struct vector *) where;
1726     length = fixnum_value(vector->length);
1727 #ifdef sparc
1728     nwords = CEILING(length * 8 + 2, 2);
1729 #endif
1730
1731     return nwords;
1732 }
1733
1734 static lispobj
1735 trans_vector_complex_long_float(lispobj object)
1736 {
1737     struct vector *vector;
1738     int length, nwords;
1739
1740     gc_assert(is_lisp_pointer(object));
1741
1742     vector = (struct vector *) native_pointer(object);
1743     length = fixnum_value(vector->length);
1744 #ifdef sparc
1745     nwords = CEILING(length * 8 + 2, 2);
1746 #endif
1747
1748     return copy_object(object, nwords);
1749 }
1750
1751 static int
1752 size_vector_complex_long_float(lispobj *where)
1753 {
1754     struct vector *vector;
1755     int length, nwords;
1756
1757     vector = (struct vector *) where;
1758     length = fixnum_value(vector->length);
1759 #ifdef sparc
1760     nwords = CEILING(length * 8 + 2, 2);
1761 #endif
1762
1763     return nwords;
1764 }
1765 #endif
1766
1767 \f
1768 /* weak pointers */
1769
1770 #define WEAK_POINTER_NWORDS \
1771         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1772
1773 static int
1774 scav_weak_pointer(lispobj *where, lispobj object)
1775 {
1776     /* Do not let GC scavenge the value slot of the weak pointer */
1777     /* (that is why it is a weak pointer).  Note:  we could use */
1778     /* the scav_unboxed method here. */
1779
1780     return WEAK_POINTER_NWORDS;
1781 }
1782
1783 static lispobj
1784 trans_weak_pointer(lispobj object)
1785 {
1786     lispobj copy;
1787     struct weak_pointer *wp;
1788
1789     gc_assert(is_lisp_pointer(object));
1790
1791 #if defined(DEBUG_WEAK)
1792     printf("Transporting weak pointer from 0x%08x\n", object);
1793 #endif
1794
1795     /* Need to remember where all the weak pointers are that have */
1796     /* been transported so they can be fixed up in a post-GC pass. */
1797
1798     copy = copy_object(object, WEAK_POINTER_NWORDS);
1799     wp = (struct weak_pointer *) native_pointer(copy);
1800
1801
1802     /* Push the weak pointer onto the list of weak pointers. */
1803     wp->next = LOW_WORD(weak_pointers);
1804     weak_pointers = wp;
1805
1806     return copy;
1807 }
1808
1809 static int
1810 size_weak_pointer(lispobj *where)
1811 {
1812     return WEAK_POINTER_NWORDS;
1813 }
1814
1815 void scan_weak_pointers(void)
1816 {
1817     struct weak_pointer *wp;
1818
1819     for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1820          wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1821         lispobj value;
1822         lispobj first, *first_pointer;
1823
1824         value = wp->value;
1825
1826 #if defined(DEBUG_WEAK)
1827         printf("Weak pointer at 0x%p\n",  wp);
1828         printf("Value: 0x%08x\n", (unsigned int) value);
1829 #endif
1830
1831         if (!(is_lisp_pointer(value) && from_space_p(value)))
1832             continue;
1833
1834         /* Now, we need to check if the object has been */
1835         /* forwarded.  If it has been, the weak pointer is */
1836         /* still good and needs to be updated.  Otherwise, the */
1837         /* weak pointer needs to be nil'ed out. */
1838
1839         first_pointer = (lispobj *) native_pointer(value);
1840         first = *first_pointer;
1841
1842 #if defined(DEBUG_WEAK)
1843         printf("First: 0x%08x\n", (unsigned long) first);
1844 #endif
1845
1846         if (is_lisp_pointer(first) && new_space_p(first))
1847             wp->value = first;
1848         else {
1849             wp->value = NIL;
1850             wp->broken = T;
1851         }
1852     }
1853 }
1854
1855
1856 \f
1857 /* initialization */
1858
1859 static int
1860 scav_lose(lispobj *where, lispobj object)
1861 {
1862     fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x (at 0x%016lx)\n",
1863             (unsigned int) object, (unsigned long)where);
1864     lose(NULL);
1865     return 0;
1866 }
1867
1868 static lispobj
1869 trans_lose(lispobj object)
1870 {
1871     fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
1872             (unsigned int)object);
1873     lose(NULL);
1874     return NIL;
1875 }
1876
1877 static int
1878 size_lose(lispobj *where)
1879 {
1880     fprintf(stderr, "Size lossage.  No size function for object at 0x%p\n",
1881             where);
1882     fprintf(stderr, "First word of object: 0x%08x\n",
1883             (u32) *where);
1884     return 1;
1885 }
1886
1887 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1888  * precise generational GC is revived, it might have three. It would
1889  * be nice to share the scavtab[] data set up here, and perhaps other
1890  * things too, between all of them, rather than trying to maintain
1891  * multiple copies. -- WHN 2001-05-09 */
1892 void
1893 gc_init(void)
1894 {
1895     int i;
1896
1897     /* scavenge table */
1898     for (i = 0; i < 256; i++)
1899         scavtab[i] = scav_lose;
1900     /* scavtab[i] = scav_immediate; */
1901
1902     for (i = 0; i < 32; i++) {
1903         scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1904         scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
1905         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1906         scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
1907         scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1908         scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer;
1909         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1910         scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
1911     }
1912
1913     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1914     scavtab[RATIO_WIDETAG] = scav_boxed;
1915     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1916     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1917 #ifdef LONG_FLOAT_WIDETAG
1918     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1919 #endif
1920     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1921 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1922     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1923 #endif
1924 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1925     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1926 #endif
1927 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1928     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1929 #endif
1930     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1931     scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
1932     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1933     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
1934     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1935         scav_vector_unsigned_byte_2;
1936     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1937         scav_vector_unsigned_byte_4;
1938     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1939         scav_vector_unsigned_byte_8;
1940     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1941         scav_vector_unsigned_byte_16;
1942     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1943         scav_vector_unsigned_byte_32;
1944 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1945     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1946         scav_vector_unsigned_byte_8;
1947 #endif
1948 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1949     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1950         scav_vector_unsigned_byte_16;
1951 #endif
1952 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1953     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1954         scav_vector_unsigned_byte_32;
1955 #endif
1956 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1957     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1958         scav_vector_unsigned_byte_32;
1959 #endif
1960     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
1961     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
1962 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1963     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
1964 #endif
1965 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1966     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1967         scav_vector_complex_single_float;
1968 #endif
1969 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1970     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1971         scav_vector_complex_double_float;
1972 #endif
1973 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1974     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1975         scav_vector_complex_long_float;
1976 #endif
1977     scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
1978     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
1979     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
1980     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
1981     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
1982     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
1983     scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;
1984     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
1985 #ifdef __i386__
1986     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
1987     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
1988 #else
1989     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
1990     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
1991 #endif
1992     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
1993     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
1994     scavtab[BASE_CHAR_WIDETAG] = scav_immediate;
1995     scavtab[SAP_WIDETAG] = scav_unboxed;
1996     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
1997     scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
1998     scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
1999 #ifndef sparc
2000     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2001 #else
2002     scavtab[FDEFN_WIDETAG] = scav_boxed;
2003 #endif
2004
2005     /* Transport Other Table */
2006     for (i = 0; i < 256; i++)
2007         transother[i] = trans_lose;
2008
2009     transother[BIGNUM_WIDETAG] = trans_unboxed;
2010     transother[RATIO_WIDETAG] = trans_boxed;
2011     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2012     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2013 #ifdef LONG_FLOAT_WIDETAG
2014     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2015 #endif
2016     transother[COMPLEX_WIDETAG] = trans_boxed;
2017 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2018     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2019 #endif
2020 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2021     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2022 #endif
2023 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2024     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2025 #endif
2026     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed;
2027     transother[SIMPLE_STRING_WIDETAG] = trans_string;
2028     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2029     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2030     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2031         trans_vector_unsigned_byte_2;
2032     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2033         trans_vector_unsigned_byte_4;
2034     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2035         trans_vector_unsigned_byte_8;
2036     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2037         trans_vector_unsigned_byte_16;
2038     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2039         trans_vector_unsigned_byte_32;
2040 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2041     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2042         trans_vector_unsigned_byte_8;
2043 #endif
2044 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2045     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2046         trans_vector_unsigned_byte_16;
2047 #endif
2048 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2049     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2050         trans_vector_unsigned_byte_32;
2051 #endif
2052 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2053     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2054         trans_vector_unsigned_byte_32;
2055 #endif
2056     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2057         trans_vector_single_float;
2058     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2059         trans_vector_double_float;
2060 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2061     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2062         trans_vector_long_float;
2063 #endif
2064 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2065     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2066         trans_vector_complex_single_float;
2067 #endif
2068 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2069     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2070         trans_vector_complex_double_float;
2071 #endif
2072 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2073     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2074         trans_vector_complex_long_float;
2075 #endif
2076     transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
2077     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2078     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2079     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2080     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2081     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2082     transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header;
2083     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2084     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2085     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2086     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2087     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2088     transother[BASE_CHAR_WIDETAG] = trans_immediate;
2089     transother[SAP_WIDETAG] = trans_unboxed;
2090     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2091     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2092     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2093     transother[FDEFN_WIDETAG] = trans_boxed;
2094
2095     /* Size table */
2096
2097     for (i = 0; i < 256; i++)
2098         sizetab[i] = size_lose;
2099
2100     for (i = 0; i < 32; i++) {
2101         sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2102         sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
2103         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2104         sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
2105         sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2106         sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
2107         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2108         sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
2109     }
2110
2111     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2112     sizetab[RATIO_WIDETAG] = size_boxed;
2113     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2114     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2115 #ifdef LONG_FLOAT_WIDETAG
2116     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2117 #endif
2118     sizetab[COMPLEX_WIDETAG] = size_boxed;
2119 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2120     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2121 #endif
2122 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2123     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2124 #endif
2125 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2126     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2127 #endif
2128     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2129     sizetab[SIMPLE_STRING_WIDETAG] = size_string;
2130     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2131     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2132     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2133         size_vector_unsigned_byte_2;
2134     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2135         size_vector_unsigned_byte_4;
2136     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2137         size_vector_unsigned_byte_8;
2138     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2139         size_vector_unsigned_byte_16;
2140     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2141         size_vector_unsigned_byte_32;
2142 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2143     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2144         size_vector_unsigned_byte_8;
2145 #endif
2146 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2147     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2148         size_vector_unsigned_byte_16;
2149 #endif
2150 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2151     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2152         size_vector_unsigned_byte_32;
2153 #endif
2154 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2155     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2156         size_vector_unsigned_byte_32;
2157 #endif
2158     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2159     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2160 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2161     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2162 #endif
2163 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2164     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2165         size_vector_complex_single_float;
2166 #endif
2167 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2168     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2169         size_vector_complex_double_float;
2170 #endif
2171 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2172     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2173         size_vector_complex_long_float;
2174 #endif
2175     sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
2176     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2177     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2178     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2179     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2180 #if 0
2181     /* Shouldn't see these so just lose if it happens */
2182     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2183     sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header;
2184     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2185 #endif
2186     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2187     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2188     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2189     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2190     sizetab[BASE_CHAR_WIDETAG] = size_immediate;
2191     sizetab[SAP_WIDETAG] = size_unboxed;
2192     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2193     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2194     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2195     sizetab[FDEFN_WIDETAG] = size_boxed;
2196 }
2197 \f
2198 /* noise to manipulate the gc trigger stuff */
2199
2200 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2201 {
2202     os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2203         dynamic_usage;
2204     long length =
2205         DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2206
2207     if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2208         fprintf(stderr,
2209            "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2210                 (unsigned int)dynamic_usage,
2211                 (os_vm_address_t)dynamic_space_free_pointer
2212                 - (os_vm_address_t)current_dynamic_space);
2213         return;
2214     }
2215     else if (length < 0) {
2216         fprintf(stderr,
2217                 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2218                 dynamic_usage);
2219         return;
2220     }
2221
2222     addr=os_round_up_to_page(addr);
2223     length=os_trunc_size_to_page(length);
2224
2225 #if defined(SUNOS) || defined(SOLARIS)
2226     os_invalidate(addr,length);
2227 #else
2228     os_protect(addr, length, 0);
2229 #endif
2230
2231     current_auto_gc_trigger = (lispobj *)addr;
2232 }
2233
2234 void clear_auto_gc_trigger(void)
2235 {
2236     if(current_auto_gc_trigger!=NULL){
2237 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2238         os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2239         os_vm_size_t length=
2240             DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2241
2242         os_validate(addr,length);
2243 #else
2244         os_protect((os_vm_address_t)current_dynamic_space,
2245                    DYNAMIC_SPACE_SIZE,
2246                    OS_VM_PROT_ALL);
2247 #endif
2248
2249         current_auto_gc_trigger = NULL;
2250     }
2251 }