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