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