src/runtime/gc-common.c

   1 /*
   2  * Garbage Collection common functions for scavenging, moving and sizing
   3  * objects.  These are for use with both GC (stop & copy GC) and GENCGC
   4  */
   5
   6 /*
   7  * This software is part of the SBCL system. See the README file for
   8  * more information.
   9  *
  10  * This software is derived from the CMU CL system, which was
  11  * written at Carnegie Mellon University and released into the
  12  * public domain. The software is in the public domain and is
  13  * provided with absolutely no warranty. See the COPYING and CREDITS
  14  * files for more information.
  15  */
  16
  17 /*
  18  * For a review of garbage collection techniques (e.g. generational
  19  * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
  20  * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
  21  * had been accepted for _ACM Computing Surveys_ and was available
  22  * as a PostScript preprint through
  23  *   <http://www.cs.utexas.edu/users/oops/papers.html>
  24  * as
  25  *   <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
  26  */
  27
  28 #include <stdio.h>
  29 #include <signal.h>
  30 #include <string.h>
  31 #include "sbcl.h"
  32 #include "runtime.h"
  33 #include "os.h"
  34 #include "interr.h"
  35 #include "globals.h"
  36 #include "interrupt.h"
  37 #include "validate.h"
  38 #include "lispregs.h"
  39 #include "arch.h"
  40 #include "fixnump.h"
  41 #include "gc.h"
  42 #include "genesis/primitive-objects.h"
  43 #include "genesis/static-symbols.h"
  44 #include "genesis/layout.h"
  45 #include "gc-internal.h"
  46
  47 #ifdef LISP_FEATURE_SPARC
  48 #define LONG_FLOAT_SIZE 4
  49 #else
  50 #ifdef LISP_FEATURE_X86
  51 #define LONG_FLOAT_SIZE 3
  52 #endif
  53 #endif
  54
  55 inline static boolean
  56 forwarding_pointer_p(lispobj *pointer) {
  57     lispobj first_word=*pointer;
  58 #ifdef LISP_FEATURE_GENCGC
  59     return (first_word == 0x01);
  60 #else
  61     return (is_lisp_pointer(first_word)
  62             && new_space_p(first_word));
  63 #endif
  64 }
  65
  66 static inline lispobj *
  67 forwarding_pointer_value(lispobj *pointer) {
  68 #ifdef LISP_FEATURE_GENCGC
  69     return (lispobj *) ((pointer_sized_uint_t) pointer[1]);
  70 #else
  71     return (lispobj *) ((pointer_sized_uint_t) pointer[0]);
  72 #endif
  73 }
  74 static inline lispobj
  75 set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) {
  76 #ifdef LISP_FEATURE_GENCGC
  77     pointer[0]=0x01;
  78     pointer[1]=newspace_copy;
  79 #else
  80     pointer[0]=newspace_copy;
  81 #endif
  82     return newspace_copy;
  83 }
  84
  85 long (*scavtab[256])(lispobj *where, lispobj object);
  86 lispobj (*transother[256])(lispobj object);
  87 long (*sizetab[256])(lispobj *where);
  88 struct weak_pointer *weak_pointers;
  89
  90 unsigned long bytes_consed_between_gcs = 12*1024*1024;
  91
  92
  93 /*
  94  * copying objects
  95  */
  96
  97 /* to copy a boxed object */
  98 lispobj
  99 copy_object(lispobj object, long nwords)
 100 {
 101     int tag;
 102     lispobj *new;
 103
 104     gc_assert(is_lisp_pointer(object));
 105     gc_assert(from_space_p(object));
 106     gc_assert((nwords & 0x01) == 0);
 107
 108     /* Get tag of object. */
 109     tag = lowtag_of(object);
 110
 111     /* Allocate space. */
 112     new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK);
 113
 114     /* Copy the object. */
 115     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
 116     return make_lispobj(new,tag);
 117 }
 118
 119 static long scav_lose(lispobj *where, lispobj object); /* forward decl */
 120
 121 /* FIXME: Most calls end up going to some trouble to compute an
 122  * 'n_words' value for this function. The system might be a little
 123  * simpler if this function used an 'end' parameter instead. */
 124 void
 125 scavenge(lispobj *start, long n_words)
 126 {
 127     lispobj *end = start + n_words;
 128     lispobj *object_ptr;
 129     long n_words_scavenged;
 130
 131     for (object_ptr = start;
 132          object_ptr < end;
 133          object_ptr += n_words_scavenged) {
 134
 135         lispobj object = *object_ptr;
 136 #ifdef LISP_FEATURE_GENCGC
 137         gc_assert(!forwarding_pointer_p(object_ptr));
 138 #endif
 139         if (is_lisp_pointer(object)) {
 140             if (from_space_p(object)) {
 141                 /* It currently points to old space. Check for a
 142                  * forwarding pointer. */
 143                 lispobj *ptr = native_pointer(object);
 144                 if (forwarding_pointer_p(ptr)) {
 145                     /* Yes, there's a forwarding pointer. */
 146                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 147                     n_words_scavenged = 1;
 148                 } else {
 149                     /* Scavenge that pointer. */
 150                     n_words_scavenged =
 151                         (scavtab[widetag_of(object)])(object_ptr, object);
 152                 }
 153             } else {
 154                 /* It points somewhere other than oldspace. Leave it
 155                  * alone. */
 156                 n_words_scavenged = 1;
 157             }
 158         }
 159 #ifndef LISP_FEATURE_GENCGC
 160         /* this workaround is probably not necessary for gencgc; at least, the
 161          * behaviour it describes has never been reported */
 162         else if (n_words==1) {
 163             /* there are some situations where an
 164                other-immediate may end up in a descriptor
 165                register.  I'm not sure whether this is
 166                supposed to happen, but if it does then we
 167                don't want to (a) barf or (b) scavenge over the
 168                data-block, because there isn't one.  So, if
 169                we're checking a single word and it's anything
 170                other than a pointer, just hush it up */
 171             int type=widetag_of(object);
 172             n_words_scavenged=1;
 173
 174             if ((scavtab[type]==scav_lose) ||
 175                 (((scavtab[type])(start,object))>1)) {
 176                 fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p.  If you can\nreproduce this warning, send a bug report (see manual page for details)\n",
 177                         object,start);
 178             }
 179         }
 180 #endif
 181         else if (fixnump(object)) {
 182             /* It's a fixnum: really easy.. */
 183             n_words_scavenged = 1;
 184         } else {
 185             /* It's some sort of header object or another. */
 186             n_words_scavenged =
 187                 (scavtab[widetag_of(object)])(object_ptr, object);
 188         }
 189     }
 190     gc_assert_verbose(object_ptr == end, "Final object pointer %p, end %p\n",
 191                       object_ptr, end);
 192 }
 193
 194 static lispobj trans_fun_header(lispobj object); /* forward decls */
 195 static lispobj trans_boxed(lispobj object);
 196
 197 static long
 198 scav_fun_pointer(lispobj *where, lispobj object)
 199 {
 200     lispobj *first_pointer;
 201     lispobj copy;
 202
 203     gc_assert(is_lisp_pointer(object));
 204
 205     /* Object is a pointer into from_space - not a FP. */
 206     first_pointer = (lispobj *) native_pointer(object);
 207
 208     /* must transport object -- object may point to either a function
 209      * header, a closure function header, or to a closure header. */
 210
 211     switch (widetag_of(*first_pointer)) {
 212     case SIMPLE_FUN_HEADER_WIDETAG:
 213         copy = trans_fun_header(object);
 214         break;
 215     default:
 216         copy = trans_boxed(object);
 217         break;
 218     }
 219
 220     if (copy != object) {
 221         /* Set forwarding pointer */
 222         set_forwarding_pointer(first_pointer,copy);
 223     }
 224
 225     gc_assert(is_lisp_pointer(copy));
 226     gc_assert(!from_space_p(copy));
 227
 228     *where = copy;
 229
 230     return 1;
 231 }
 232
 233
 234 static struct code *
 235 trans_code(struct code *code)
 236 {
 237     struct code *new_code;
 238     lispobj first, l_code, l_new_code;
 239     long nheader_words, ncode_words, nwords;
 240     unsigned long displacement;
 241     lispobj fheaderl, *prev_pointer;
 242
 243     /* if object has already been transported, just return pointer */
 244     first = code->header;
 245     if (forwarding_pointer_p((lispobj *)code)) {
 246 #ifdef DEBUG_CODE_GC
 247         printf("Was already transported\n");
 248 #endif
 249         return (struct code *) forwarding_pointer_value
 250             ((lispobj *)((pointer_sized_uint_t) code));
 251     }
 252
 253     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 254
 255     /* prepare to transport the code vector */
 256     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 257
 258     ncode_words = fixnum_value(code->code_size);
 259     nheader_words = HeaderValue(code->header);
 260     nwords = ncode_words + nheader_words;
 261     nwords = CEILING(nwords, 2);
 262
 263     l_new_code = copy_object(l_code, nwords);
 264     new_code = (struct code *) native_pointer(l_new_code);
 265
 266 #if defined(DEBUG_CODE_GC)
 267     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 268            (unsigned long) code, (unsigned long) new_code);
 269     printf("Code object is %d words long.\n", nwords);
 270 #endif
 271
 272 #ifdef LISP_FEATURE_GENCGC
 273     if (new_code == code)
 274         return new_code;
 275 #endif
 276
 277     displacement = l_new_code - l_code;
 278
 279     set_forwarding_pointer((lispobj *)code, l_new_code);
 280
 281     /* set forwarding pointers for all the function headers in the */
 282     /* code object.  also fix all self pointers */
 283
 284     fheaderl = code->entry_points;
 285     prev_pointer = &new_code->entry_points;
 286
 287     while (fheaderl != NIL) {
 288         struct simple_fun *fheaderp, *nfheaderp;
 289         lispobj nfheaderl;
 290
 291         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 292         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 293
 294         /* Calculate the new function pointer and the new */
 295         /* function header. */
 296         nfheaderl = fheaderl + displacement;
 297         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 298
 299 #ifdef DEBUG_CODE_GC
 300         printf("fheaderp->header (at %x) <- %x\n",
 301                &(fheaderp->header) , nfheaderl);
 302 #endif
 303         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 304
 305         /* fix self pointer. */
 306         nfheaderp->self =
 307 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 308             FUN_RAW_ADDR_OFFSET +
 309 #endif
 310             nfheaderl;
 311
 312         *prev_pointer = nfheaderl;
 313
 314         fheaderl = fheaderp->next;
 315         prev_pointer = &nfheaderp->next;
 316     }
 317     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
 318                     ncode_words * sizeof(long));
 319 #ifdef LISP_FEATURE_GENCGC
 320     gencgc_apply_code_fixups(code, new_code);
 321 #endif
 322     return new_code;
 323 }
 324
 325 static long
 326 scav_code_header(lispobj *where, lispobj object)
 327 {
 328     struct code *code;
 329     long n_header_words, n_code_words, n_words;
 330     lispobj entry_point;        /* tagged pointer to entry point */
 331     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 332
 333     code = (struct code *) where;
 334     n_code_words = fixnum_value(code->code_size);
 335     n_header_words = HeaderValue(object);
 336     n_words = n_code_words + n_header_words;
 337     n_words = CEILING(n_words, 2);
 338
 339     /* Scavenge the boxed section of the code data block. */
 340     scavenge(where + 1, n_header_words - 1);
 341
 342     /* Scavenge the boxed section of each function object in the
 343      * code data block. */
 344     for (entry_point = code->entry_points;
 345          entry_point != NIL;
 346          entry_point = function_ptr->next) {
 347
 348         gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n",
 349                           (long)entry_point);
 350
 351         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 352         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 353
 354         scavenge(&function_ptr->name, 1);
 355         scavenge(&function_ptr->arglist, 1);
 356         scavenge(&function_ptr->type, 1);
 357     }
 358
 359     return n_words;
 360 }
 361
 362 static lispobj
 363 trans_code_header(lispobj object)
 364 {
 365     struct code *ncode;
 366
 367     ncode = trans_code((struct code *) native_pointer(object));
 368     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 369 }
 370
 371
 372 static long
 373 size_code_header(lispobj *where)
 374 {
 375     struct code *code;
 376     long nheader_words, ncode_words, nwords;
 377
 378     code = (struct code *) where;
 379
 380     ncode_words = fixnum_value(code->code_size);
 381     nheader_words = HeaderValue(code->header);
 382     nwords = ncode_words + nheader_words;
 383     nwords = CEILING(nwords, 2);
 384
 385     return nwords;
 386 }
 387
 388 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 389 static long
 390 scav_return_pc_header(lispobj *where, lispobj object)
 391 {
 392     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
 393          (unsigned long) where,
 394          (unsigned long) object);
 395     return 0; /* bogus return value to satisfy static type checking */
 396 }
 397 #endif /* LISP_FEATURE_X86 */
 398
 399 static lispobj
 400 trans_return_pc_header(lispobj object)
 401 {
 402     struct simple_fun *return_pc;
 403     unsigned long offset;
 404     struct code *code, *ncode;
 405
 406     return_pc = (struct simple_fun *) native_pointer(object);
 407     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 408     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 409
 410     /* Transport the whole code object */
 411     code = (struct code *) ((unsigned long) return_pc - offset);
 412     ncode = trans_code(code);
 413
 414     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 415 }
 416
 417 /* On the 386, closures hold a pointer to the raw address instead of the
 418  * function object, so we can use CALL [$FDEFN+const] to invoke
 419  * the function without loading it into a register. Given that code
 420  * objects don't move, we don't need to update anything, but we do
 421  * have to figure out that the function is still live. */
 422
 423 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 424 static long
 425 scav_closure_header(lispobj *where, lispobj object)
 426 {
 427     struct closure *closure;
 428     lispobj fun;
 429
 430     closure = (struct closure *)where;
 431     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 432     scavenge(&fun, 1);
 433 #ifdef LISP_FEATURE_GENCGC
 434     /* The function may have moved so update the raw address. But
 435      * don't write unnecessarily. */
 436     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 437         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 438 #endif
 439     return 2;
 440 }
 441 #endif
 442
 443 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 444 static long
 445 scav_fun_header(lispobj *where, lispobj object)
 446 {
 447     lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
 448          (unsigned long) where,
 449          (unsigned long) object);
 450     return 0; /* bogus return value to satisfy static type checking */
 451 }
 452 #endif /* LISP_FEATURE_X86 */
 453
 454 static lispobj
 455 trans_fun_header(lispobj object)
 456 {
 457     struct simple_fun *fheader;
 458     unsigned long offset;
 459     struct code *code, *ncode;
 460
 461     fheader = (struct simple_fun *) native_pointer(object);
 462     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 463     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 464
 465     /* Transport the whole code object */
 466     code = (struct code *) ((unsigned long) fheader - offset);
 467     ncode = trans_code(code);
 468
 469     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 470 }
 471
 472 \f
 473 /*
 474  * instances
 475  */
 476
 477 static long
 478 scav_instance_pointer(lispobj *where, lispobj object)
 479 {
 480     lispobj copy, *first_pointer;
 481
 482     /* Object is a pointer into from space - not a FP. */
 483     copy = trans_boxed(object);
 484
 485 #ifdef LISP_FEATURE_GENCGC
 486     gc_assert(copy != object);
 487 #endif
 488
 489     first_pointer = (lispobj *) native_pointer(object);
 490     set_forwarding_pointer(first_pointer,copy);
 491     *where = copy;
 492
 493     return 1;
 494 }
 495
 496 \f
 497 /*
 498  * lists and conses
 499  */
 500
 501 static lispobj trans_list(lispobj object);
 502
 503 static long
 504 scav_list_pointer(lispobj *where, lispobj object)
 505 {
 506     lispobj first, *first_pointer;
 507
 508     gc_assert(is_lisp_pointer(object));
 509
 510     /* Object is a pointer into from space - not FP. */
 511     first_pointer = (lispobj *) native_pointer(object);
 512
 513     first = trans_list(object);
 514     gc_assert(first != object);
 515
 516     /* Set forwarding pointer */
 517     set_forwarding_pointer(first_pointer, first);
 518
 519     gc_assert(is_lisp_pointer(first));
 520     gc_assert(!from_space_p(first));
 521
 522     *where = first;
 523     return 1;
 524 }
 525
 526
 527 static lispobj
 528 trans_list(lispobj object)
 529 {
 530     lispobj new_list_pointer;
 531     struct cons *cons, *new_cons;
 532     lispobj cdr;
 533
 534     cons = (struct cons *) native_pointer(object);
 535
 536     /* Copy 'object'. */
 537     new_cons = (struct cons *)
 538         gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 539     new_cons->car = cons->car;
 540     new_cons->cdr = cons->cdr; /* updated later */
 541     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 542
 543     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 544     cdr = cons->cdr;
 545
 546     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 547
 548     /* Try to linearize the list in the cdr direction to help reduce
 549      * paging. */
 550     while (1) {
 551         lispobj  new_cdr;
 552         struct cons *cdr_cons, *new_cdr_cons;
 553
 554         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 555            !from_space_p(cdr) ||
 556            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 557             break;
 558
 559         cdr_cons = (struct cons *) native_pointer(cdr);
 560
 561         /* Copy 'cdr'. */
 562         new_cdr_cons = (struct cons*)
 563             gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 564         new_cdr_cons->car = cdr_cons->car;
 565         new_cdr_cons->cdr = cdr_cons->cdr;
 566         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 567
 568         /* Grab the cdr before it is clobbered. */
 569         cdr = cdr_cons->cdr;
 570         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 571
 572         /* Update the cdr of the last cons copied into new space to
 573          * keep the newspace scavenge from having to do it. */
 574         new_cons->cdr = new_cdr;
 575
 576         new_cons = new_cdr_cons;
 577     }
 578
 579     return new_list_pointer;
 580 }
 581
 582 \f
 583 /*
 584  * scavenging and transporting other pointers
 585  */
 586
 587 static long
 588 scav_other_pointer(lispobj *where, lispobj object)
 589 {
 590     lispobj first, *first_pointer;
 591
 592     gc_assert(is_lisp_pointer(object));
 593
 594     /* Object is a pointer into from space - not FP. */
 595     first_pointer = (lispobj *) native_pointer(object);
 596     first = (transother[widetag_of(*first_pointer)])(object);
 597
 598     if (first != object) {
 599         set_forwarding_pointer(first_pointer, first);
 600 #ifdef LISP_FEATURE_GENCGC
 601         *where = first;
 602 #endif
 603     }
 604 #ifndef LISP_FEATURE_GENCGC
 605     *where = first;
 606 #endif
 607     gc_assert(is_lisp_pointer(first));
 608     gc_assert(!from_space_p(first));
 609
 610     return 1;
 611 }
 612 \f
 613 /*
 614  * immediate, boxed, and unboxed objects
 615  */
 616
 617 static long
 618 size_pointer(lispobj *where)
 619 {
 620     return 1;
 621 }
 622
 623 static long
 624 scav_immediate(lispobj *where, lispobj object)
 625 {
 626     return 1;
 627 }
 628
 629 static lispobj
 630 trans_immediate(lispobj object)
 631 {
 632     lose("trying to transport an immediate\n");
 633     return NIL; /* bogus return value to satisfy static type checking */
 634 }
 635
 636 static long
 637 size_immediate(lispobj *where)
 638 {
 639     return 1;
 640 }
 641
 642
 643 static long
 644 scav_boxed(lispobj *where, lispobj object)
 645 {
 646     return 1;
 647 }
 648
 649 static long
 650 scav_instance(lispobj *where, lispobj object)
 651 {
 652     lispobj nuntagged;
 653     long ntotal = HeaderValue(object);
 654     lispobj layout = ((struct instance *)where)->slots[0];
 655
 656     if (!layout)
 657         return 1;
 658     if (forwarding_pointer_p(native_pointer(layout)))
 659         layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
 660
 661     nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
 662     scavenge(where + 1, ntotal - fixnum_value(nuntagged));
 663
 664     return ntotal + 1;
 665 }
 666
 667 static lispobj
 668 trans_boxed(lispobj object)
 669 {
 670     lispobj header;
 671     unsigned long length;
 672
 673     gc_assert(is_lisp_pointer(object));
 674
 675     header = *((lispobj *) native_pointer(object));
 676     length = HeaderValue(header) + 1;
 677     length = CEILING(length, 2);
 678
 679     return copy_object(object, length);
 680 }
 681
 682
 683 static long
 684 size_boxed(lispobj *where)
 685 {
 686     lispobj header;
 687     unsigned long length;
 688
 689     header = *where;
 690     length = HeaderValue(header) + 1;
 691     length = CEILING(length, 2);
 692
 693     return length;
 694 }
 695
 696 /* Note: on the sparc we don't have to do anything special for fdefns, */
 697 /* 'cause the raw-addr has a function lowtag. */
 698 #ifndef LISP_FEATURE_SPARC
 699 static long
 700 scav_fdefn(lispobj *where, lispobj object)
 701 {
 702     struct fdefn *fdefn;
 703
 704     fdefn = (struct fdefn *)where;
 705
 706     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 707        fdefn->fun, fdefn->raw_addr)); */
 708
 709     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
 710         == (char *)((unsigned long)(fdefn->raw_addr))) {
 711         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 712
 713         /* Don't write unnecessarily. */
 714         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 715             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 716         /* gc.c has more casts here, which may be relevant or alternatively
 717            may be compiler warning defeaters.  try
 718         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 719         */
 720         return sizeof(struct fdefn) / sizeof(lispobj);
 721     } else {
 722         return 1;
 723     }
 724 }
 725 #endif
 726
 727 static long
 728 scav_unboxed(lispobj *where, lispobj object)
 729 {
 730     unsigned long length;
 731
 732     length = HeaderValue(object) + 1;
 733     length = CEILING(length, 2);
 734
 735     return length;
 736 }
 737
 738 static lispobj
 739 trans_unboxed(lispobj object)
 740 {
 741     lispobj header;
 742     unsigned long length;
 743
 744
 745     gc_assert(is_lisp_pointer(object));
 746
 747     header = *((lispobj *) native_pointer(object));
 748     length = HeaderValue(header) + 1;
 749     length = CEILING(length, 2);
 750
 751     return copy_unboxed_object(object, length);
 752 }
 753
 754 static long
 755 size_unboxed(lispobj *where)
 756 {
 757     lispobj header;
 758     unsigned long length;
 759
 760     header = *where;
 761     length = HeaderValue(header) + 1;
 762     length = CEILING(length, 2);
 763
 764     return length;
 765 }
 766
 767 \f
 768 /* vector-like objects */
 769 static long
 770 scav_base_string(lispobj *where, lispobj object)
 771 {
 772     struct vector *vector;
 773     long length, nwords;
 774
 775     /* NOTE: Strings contain one more byte of data than the length */
 776     /* slot indicates. */
 777
 778     vector = (struct vector *) where;
 779     length = fixnum_value(vector->length) + 1;
 780     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 781
 782     return nwords;
 783 }
 784 static lispobj
 785 trans_base_string(lispobj object)
 786 {
 787     struct vector *vector;
 788     long length, nwords;
 789
 790     gc_assert(is_lisp_pointer(object));
 791
 792     /* NOTE: A string contains one more byte of data (a terminating
 793      * '\0' to help when interfacing with C functions) than indicated
 794      * by the length slot. */
 795
 796     vector = (struct vector *) native_pointer(object);
 797     length = fixnum_value(vector->length) + 1;
 798     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 799
 800     return copy_large_unboxed_object(object, nwords);
 801 }
 802
 803 static long
 804 size_base_string(lispobj *where)
 805 {
 806     struct vector *vector;
 807     long length, nwords;
 808
 809     /* NOTE: A string contains one more byte of data (a terminating
 810      * '\0' to help when interfacing with C functions) than indicated
 811      * by the length slot. */
 812
 813     vector = (struct vector *) where;
 814     length = fixnum_value(vector->length) + 1;
 815     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 816
 817     return nwords;
 818 }
 819
 820 static long
 821 scav_character_string(lispobj *where, lispobj object)
 822 {
 823     struct vector *vector;
 824     int length, nwords;
 825
 826     /* NOTE: Strings contain one more byte of data than the length */
 827     /* slot indicates. */
 828
 829     vector = (struct vector *) where;
 830     length = fixnum_value(vector->length) + 1;
 831     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 832
 833     return nwords;
 834 }
 835 static lispobj
 836 trans_character_string(lispobj object)
 837 {
 838     struct vector *vector;
 839     int length, nwords;
 840
 841     gc_assert(is_lisp_pointer(object));
 842
 843     /* NOTE: A string contains one more byte of data (a terminating
 844      * '\0' to help when interfacing with C functions) than indicated
 845      * by the length slot. */
 846
 847     vector = (struct vector *) native_pointer(object);
 848     length = fixnum_value(vector->length) + 1;
 849     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 850
 851     return copy_large_unboxed_object(object, nwords);
 852 }
 853
 854 static long
 855 size_character_string(lispobj *where)
 856 {
 857     struct vector *vector;
 858     int length, nwords;
 859
 860     /* NOTE: A string contains one more byte of data (a terminating
 861      * '\0' to help when interfacing with C functions) than indicated
 862      * by the length slot. */
 863
 864     vector = (struct vector *) where;
 865     length = fixnum_value(vector->length) + 1;
 866     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 867
 868     return nwords;
 869 }
 870
 871 static lispobj
 872 trans_vector(lispobj object)
 873 {
 874     struct vector *vector;
 875     long length, nwords;
 876
 877     gc_assert(is_lisp_pointer(object));
 878
 879     vector = (struct vector *) native_pointer(object);
 880
 881     length = fixnum_value(vector->length);
 882     nwords = CEILING(length + 2, 2);
 883
 884     return copy_large_object(object, nwords);
 885 }
 886
 887 static long
 888 size_vector(lispobj *where)
 889 {
 890     struct vector *vector;
 891     long length, nwords;
 892
 893     vector = (struct vector *) where;
 894     length = fixnum_value(vector->length);
 895     nwords = CEILING(length + 2, 2);
 896
 897     return nwords;
 898 }
 899
 900 static long
 901 scav_vector_nil(lispobj *where, lispobj object)
 902 {
 903     return 2;
 904 }
 905
 906 static lispobj
 907 trans_vector_nil(lispobj object)
 908 {
 909     gc_assert(is_lisp_pointer(object));
 910     return copy_unboxed_object(object, 2);
 911 }
 912
 913 static long
 914 size_vector_nil(lispobj *where)
 915 {
 916     /* Just the header word and the length word */
 917     return 2;
 918 }
 919
 920 static long
 921 scav_vector_bit(lispobj *where, lispobj object)
 922 {
 923     struct vector *vector;
 924     long length, nwords;
 925
 926     vector = (struct vector *) where;
 927     length = fixnum_value(vector->length);
 928     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 929
 930     return nwords;
 931 }
 932
 933 static lispobj
 934 trans_vector_bit(lispobj object)
 935 {
 936     struct vector *vector;
 937     long length, nwords;
 938
 939     gc_assert(is_lisp_pointer(object));
 940
 941     vector = (struct vector *) native_pointer(object);
 942     length = fixnum_value(vector->length);
 943     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 944
 945     return copy_large_unboxed_object(object, nwords);
 946 }
 947
 948 static long
 949 size_vector_bit(lispobj *where)
 950 {
 951     struct vector *vector;
 952     long length, nwords;
 953
 954     vector = (struct vector *) where;
 955     length = fixnum_value(vector->length);
 956     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 957
 958     return nwords;
 959 }
 960
 961 static long
 962 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 963 {
 964     struct vector *vector;
 965     long length, nwords;
 966
 967     vector = (struct vector *) where;
 968     length = fixnum_value(vector->length);
 969     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 970
 971     return nwords;
 972 }
 973
 974 static lispobj
 975 trans_vector_unsigned_byte_2(lispobj object)
 976 {
 977     struct vector *vector;
 978     long length, nwords;
 979
 980     gc_assert(is_lisp_pointer(object));
 981
 982     vector = (struct vector *) native_pointer(object);
 983     length = fixnum_value(vector->length);
 984     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 985
 986     return copy_large_unboxed_object(object, nwords);
 987 }
 988
 989 static long
 990 size_vector_unsigned_byte_2(lispobj *where)
 991 {
 992     struct vector *vector;
 993     long length, nwords;
 994
 995     vector = (struct vector *) where;
 996     length = fixnum_value(vector->length);
 997     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 998
 999     return nwords;
1000 }
1001
1002 static long
1003 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1004 {
1005     struct vector *vector;
1006     long length, nwords;
1007
1008     vector = (struct vector *) where;
1009     length = fixnum_value(vector->length);
1010     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1011
1012     return nwords;
1013 }
1014
1015 static lispobj
1016 trans_vector_unsigned_byte_4(lispobj object)
1017 {
1018     struct vector *vector;
1019     long length, nwords;
1020
1021     gc_assert(is_lisp_pointer(object));
1022
1023     vector = (struct vector *) native_pointer(object);
1024     length = fixnum_value(vector->length);
1025     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1026
1027     return copy_large_unboxed_object(object, nwords);
1028 }
1029 static long
1030 size_vector_unsigned_byte_4(lispobj *where)
1031 {
1032     struct vector *vector;
1033     long length, nwords;
1034
1035     vector = (struct vector *) where;
1036     length = fixnum_value(vector->length);
1037     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1038
1039     return nwords;
1040 }
1041
1042
1043 static long
1044 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1045 {
1046     struct vector *vector;
1047     long length, nwords;
1048
1049     vector = (struct vector *) where;
1050     length = fixnum_value(vector->length);
1051     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1052
1053     return nwords;
1054 }
1055
1056 /*********************/
1057
1058
1059
1060 static lispobj
1061 trans_vector_unsigned_byte_8(lispobj object)
1062 {
1063     struct vector *vector;
1064     long length, nwords;
1065
1066     gc_assert(is_lisp_pointer(object));
1067
1068     vector = (struct vector *) native_pointer(object);
1069     length = fixnum_value(vector->length);
1070     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1071
1072     return copy_large_unboxed_object(object, nwords);
1073 }
1074
1075 static long
1076 size_vector_unsigned_byte_8(lispobj *where)
1077 {
1078     struct vector *vector;
1079     long length, nwords;
1080
1081     vector = (struct vector *) where;
1082     length = fixnum_value(vector->length);
1083     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1084
1085     return nwords;
1086 }
1087
1088
1089 static long
1090 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1091 {
1092     struct vector *vector;
1093     long length, nwords;
1094
1095     vector = (struct vector *) where;
1096     length = fixnum_value(vector->length);
1097     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1098
1099     return nwords;
1100 }
1101
1102 static lispobj
1103 trans_vector_unsigned_byte_16(lispobj object)
1104 {
1105     struct vector *vector;
1106     long length, nwords;
1107
1108     gc_assert(is_lisp_pointer(object));
1109
1110     vector = (struct vector *) native_pointer(object);
1111     length = fixnum_value(vector->length);
1112     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1113
1114     return copy_large_unboxed_object(object, nwords);
1115 }
1116
1117 static long
1118 size_vector_unsigned_byte_16(lispobj *where)
1119 {
1120     struct vector *vector;
1121     long length, nwords;
1122
1123     vector = (struct vector *) where;
1124     length = fixnum_value(vector->length);
1125     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1126
1127     return nwords;
1128 }
1129
1130 static long
1131 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1132 {
1133     struct vector *vector;
1134     long length, nwords;
1135
1136     vector = (struct vector *) where;
1137     length = fixnum_value(vector->length);
1138     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1139
1140     return nwords;
1141 }
1142
1143 static lispobj
1144 trans_vector_unsigned_byte_32(lispobj object)
1145 {
1146     struct vector *vector;
1147     long length, nwords;
1148
1149     gc_assert(is_lisp_pointer(object));
1150
1151     vector = (struct vector *) native_pointer(object);
1152     length = fixnum_value(vector->length);
1153     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1154
1155     return copy_large_unboxed_object(object, nwords);
1156 }
1157
1158 static long
1159 size_vector_unsigned_byte_32(lispobj *where)
1160 {
1161     struct vector *vector;
1162     long length, nwords;
1163
1164     vector = (struct vector *) where;
1165     length = fixnum_value(vector->length);
1166     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1167
1168     return nwords;
1169 }
1170
1171 #if N_WORD_BITS == 64
1172 static long
1173 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1174 {
1175     struct vector *vector;
1176     long length, nwords;
1177
1178     vector = (struct vector *) where;
1179     length = fixnum_value(vector->length);
1180     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1181
1182     return nwords;
1183 }
1184
1185 static lispobj
1186 trans_vector_unsigned_byte_64(lispobj object)
1187 {
1188     struct vector *vector;
1189     long length, nwords;
1190
1191     gc_assert(is_lisp_pointer(object));
1192
1193     vector = (struct vector *) native_pointer(object);
1194     length = fixnum_value(vector->length);
1195     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1196
1197     return copy_large_unboxed_object(object, nwords);
1198 }
1199
1200 static long
1201 size_vector_unsigned_byte_64(lispobj *where)
1202 {
1203     struct vector *vector;
1204     long length, nwords;
1205
1206     vector = (struct vector *) where;
1207     length = fixnum_value(vector->length);
1208     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1209
1210     return nwords;
1211 }
1212 #endif
1213
1214 static long
1215 scav_vector_single_float(lispobj *where, lispobj object)
1216 {
1217     struct vector *vector;
1218     long length, nwords;
1219
1220     vector = (struct vector *) where;
1221     length = fixnum_value(vector->length);
1222     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1223
1224     return nwords;
1225 }
1226
1227 static lispobj
1228 trans_vector_single_float(lispobj object)
1229 {
1230     struct vector *vector;
1231     long length, nwords;
1232
1233     gc_assert(is_lisp_pointer(object));
1234
1235     vector = (struct vector *) native_pointer(object);
1236     length = fixnum_value(vector->length);
1237     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1238
1239     return copy_large_unboxed_object(object, nwords);
1240 }
1241
1242 static long
1243 size_vector_single_float(lispobj *where)
1244 {
1245     struct vector *vector;
1246     long length, nwords;
1247
1248     vector = (struct vector *) where;
1249     length = fixnum_value(vector->length);
1250     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1251
1252     return nwords;
1253 }
1254
1255 static long
1256 scav_vector_double_float(lispobj *where, lispobj object)
1257 {
1258     struct vector *vector;
1259     long length, nwords;
1260
1261     vector = (struct vector *) where;
1262     length = fixnum_value(vector->length);
1263     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1264
1265     return nwords;
1266 }
1267
1268 static lispobj
1269 trans_vector_double_float(lispobj object)
1270 {
1271     struct vector *vector;
1272     long length, nwords;
1273
1274     gc_assert(is_lisp_pointer(object));
1275
1276     vector = (struct vector *) native_pointer(object);
1277     length = fixnum_value(vector->length);
1278     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1279
1280     return copy_large_unboxed_object(object, nwords);
1281 }
1282
1283 static long
1284 size_vector_double_float(lispobj *where)
1285 {
1286     struct vector *vector;
1287     long length, nwords;
1288
1289     vector = (struct vector *) where;
1290     length = fixnum_value(vector->length);
1291     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1292
1293     return nwords;
1294 }
1295
1296 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1297 static long
1298 scav_vector_long_float(lispobj *where, lispobj object)
1299 {
1300     struct vector *vector;
1301     long length, nwords;
1302
1303     vector = (struct vector *) where;
1304     length = fixnum_value(vector->length);
1305     nwords = CEILING(length *
1306                      LONG_FLOAT_SIZE
1307                      + 2, 2);
1308     return nwords;
1309 }
1310
1311 static lispobj
1312 trans_vector_long_float(lispobj object)
1313 {
1314     struct vector *vector;
1315     long 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(length * LONG_FLOAT_SIZE + 2, 2);
1322
1323     return copy_large_unboxed_object(object, nwords);
1324 }
1325
1326 static long
1327 size_vector_long_float(lispobj *where)
1328 {
1329     struct vector *vector;
1330     long length, nwords;
1331
1332     vector = (struct vector *) where;
1333     length = fixnum_value(vector->length);
1334     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1335
1336     return nwords;
1337 }
1338 #endif
1339
1340
1341 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1342 static long
1343 scav_vector_complex_single_float(lispobj *where, lispobj object)
1344 {
1345     struct vector *vector;
1346     long length, nwords;
1347
1348     vector = (struct vector *) where;
1349     length = fixnum_value(vector->length);
1350     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1351
1352     return nwords;
1353 }
1354
1355 static lispobj
1356 trans_vector_complex_single_float(lispobj object)
1357 {
1358     struct vector *vector;
1359     long length, nwords;
1360
1361     gc_assert(is_lisp_pointer(object));
1362
1363     vector = (struct vector *) native_pointer(object);
1364     length = fixnum_value(vector->length);
1365     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1366
1367     return copy_large_unboxed_object(object, nwords);
1368 }
1369
1370 static long
1371 size_vector_complex_single_float(lispobj *where)
1372 {
1373     struct vector *vector;
1374     long length, nwords;
1375
1376     vector = (struct vector *) where;
1377     length = fixnum_value(vector->length);
1378     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1379
1380     return nwords;
1381 }
1382 #endif
1383
1384 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1385 static long
1386 scav_vector_complex_double_float(lispobj *where, lispobj object)
1387 {
1388     struct vector *vector;
1389     long length, nwords;
1390
1391     vector = (struct vector *) where;
1392     length = fixnum_value(vector->length);
1393     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1394
1395     return nwords;
1396 }
1397
1398 static lispobj
1399 trans_vector_complex_double_float(lispobj object)
1400 {
1401     struct vector *vector;
1402     long 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, 128) + 2, 2);
1409
1410     return copy_large_unboxed_object(object, nwords);
1411 }
1412
1413 static long
1414 size_vector_complex_double_float(lispobj *where)
1415 {
1416     struct vector *vector;
1417     long length, nwords;
1418
1419     vector = (struct vector *) where;
1420     length = fixnum_value(vector->length);
1421     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1422
1423     return nwords;
1424 }
1425 #endif
1426
1427
1428 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1429 static long
1430 scav_vector_complex_long_float(lispobj *where, lispobj object)
1431 {
1432     struct vector *vector;
1433     long length, nwords;
1434
1435     vector = (struct vector *) where;
1436     length = fixnum_value(vector->length);
1437     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1438
1439     return nwords;
1440 }
1441
1442 static lispobj
1443 trans_vector_complex_long_float(lispobj object)
1444 {
1445     struct vector *vector;
1446     long length, nwords;
1447
1448     gc_assert(is_lisp_pointer(object));
1449
1450     vector = (struct vector *) native_pointer(object);
1451     length = fixnum_value(vector->length);
1452     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1453
1454     return copy_large_unboxed_object(object, nwords);
1455 }
1456
1457 static long
1458 size_vector_complex_long_float(lispobj *where)
1459 {
1460     struct vector *vector;
1461     long length, nwords;
1462
1463     vector = (struct vector *) where;
1464     length = fixnum_value(vector->length);
1465     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1466
1467     return nwords;
1468 }
1469 #endif
1470
1471 #define WEAK_POINTER_NWORDS \
1472         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1473
1474 static lispobj
1475 trans_weak_pointer(lispobj object)
1476 {
1477     lispobj copy;
1478 #ifndef LISP_FEATURE_GENCGC
1479     struct weak_pointer *wp;
1480 #endif
1481     gc_assert(is_lisp_pointer(object));
1482
1483 #if defined(DEBUG_WEAK)
1484     printf("Transporting weak pointer from 0x%08x\n", object);
1485 #endif
1486
1487     /* Need to remember where all the weak pointers are that have */
1488     /* been transported so they can be fixed up in a post-GC pass. */
1489
1490     copy = copy_object(object, WEAK_POINTER_NWORDS);
1491 #ifndef LISP_FEATURE_GENCGC
1492     wp = (struct weak_pointer *) native_pointer(copy);
1493
1494     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1495     /* Push the weak pointer onto the list of weak pointers. */
1496     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1497     weak_pointers = wp;
1498 #endif
1499     return copy;
1500 }
1501
1502 static long
1503 size_weak_pointer(lispobj *where)
1504 {
1505     return WEAK_POINTER_NWORDS;
1506 }
1507
1508
1509 void scan_weak_pointers(void)
1510 {
1511     struct weak_pointer *wp;
1512     for (wp = weak_pointers; wp != NULL; wp=wp->next) {
1513         lispobj value = wp->value;
1514         lispobj *first_pointer;
1515         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1516         if (!(is_lisp_pointer(value) && from_space_p(value)))
1517             continue;
1518
1519         /* Now, we need to check whether the object has been forwarded. If
1520          * it has been, the weak pointer is still good and needs to be
1521          * updated. Otherwise, the weak pointer needs to be nil'ed
1522          * out. */
1523
1524         first_pointer = (lispobj *)native_pointer(value);
1525
1526         if (forwarding_pointer_p(first_pointer)) {
1527             wp->value=
1528                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1529         } else {
1530             /* Break it. */
1531             wp->value = NIL;
1532             wp->broken = T;
1533         }
1534     }
1535 }
1536
1537
1538 \f
1539 /*
1540  * initialization
1541  */
1542
1543 static long
1544 scav_lose(lispobj *where, lispobj object)
1545 {
1546     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1547          (unsigned long)object,
1548          widetag_of(*(lispobj*)native_pointer(object)));
1549
1550     return 0; /* bogus return value to satisfy static type checking */
1551 }
1552
1553 static lispobj
1554 trans_lose(lispobj object)
1555 {
1556     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1557          (unsigned long)object,
1558          widetag_of(*(lispobj*)native_pointer(object)));
1559     return NIL; /* bogus return value to satisfy static type checking */
1560 }
1561
1562 static long
1563 size_lose(lispobj *where)
1564 {
1565     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1566          (unsigned long)where,
1567          widetag_of(LOW_WORD(where)));
1568     return 1; /* bogus return value to satisfy static type checking */
1569 }
1570
1571 \f
1572 /*
1573  * initialization
1574  */
1575
1576 void
1577 gc_init_tables(void)
1578 {
1579     long i;
1580
1581     /* Set default value in all slots of scavenge table.  FIXME
1582      * replace this gnarly sizeof with something based on
1583      * N_WIDETAG_BITS */
1584     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1585         scavtab[i] = scav_lose;
1586     }
1587
1588     /* For each type which can be selected by the lowtag alone, set
1589      * multiple entries in our widetag scavenge table (one for each
1590      * possible value of the high bits).
1591      */
1592
1593     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1594         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1595         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1596         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1597         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1598         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1599         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1600         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1601         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1602     }
1603
1604     /* Other-pointer types (those selected by all eight bits of the
1605      * tag) get one entry each in the scavenge table. */
1606     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1607     scavtab[RATIO_WIDETAG] = scav_boxed;
1608 #if N_WORD_BITS == 64
1609     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1610 #else
1611     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1612 #endif
1613     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1614 #ifdef LONG_FLOAT_WIDETAG
1615     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1616 #endif
1617     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1618 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1619     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1620 #endif
1621 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1622     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1623 #endif
1624 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1625     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1626 #endif
1627     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1628     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1629 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1630     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1631 #endif
1632     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1633     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1634     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1635         scav_vector_unsigned_byte_2;
1636     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1637         scav_vector_unsigned_byte_4;
1638     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1639         scav_vector_unsigned_byte_8;
1640     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1641         scav_vector_unsigned_byte_8;
1642     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1643         scav_vector_unsigned_byte_16;
1644     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1645         scav_vector_unsigned_byte_16;
1646 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1647     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1648         scav_vector_unsigned_byte_32;
1649 #endif
1650     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1651         scav_vector_unsigned_byte_32;
1652     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1653         scav_vector_unsigned_byte_32;
1654 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1655     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1656         scav_vector_unsigned_byte_64;
1657 #endif
1658 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1659     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1660         scav_vector_unsigned_byte_64;
1661 #endif
1662 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1663     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1664         scav_vector_unsigned_byte_64;
1665 #endif
1666 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1667     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1668 #endif
1669 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1670     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1671         scav_vector_unsigned_byte_16;
1672 #endif
1673 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1674     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1675         scav_vector_unsigned_byte_32;
1676 #endif
1677 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1678     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1679         scav_vector_unsigned_byte_32;
1680 #endif
1681 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1682     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1683         scav_vector_unsigned_byte_64;
1684 #endif
1685 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1686     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1687         scav_vector_unsigned_byte_64;
1688 #endif
1689     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
1690     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
1691 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1692     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
1693 #endif
1694 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1695     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1696         scav_vector_complex_single_float;
1697 #endif
1698 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1699     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1700         scav_vector_complex_double_float;
1701 #endif
1702 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1703     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1704         scav_vector_complex_long_float;
1705 #endif
1706     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
1707 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1708     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
1709 #endif
1710     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
1711     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
1712     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
1713     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
1714     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
1715 #ifndef LISP_FEATURE_GENCGC     /* FIXME ..._X86 ? */
1716     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
1717     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
1718 #endif
1719 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1720     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
1721     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
1722 #else
1723     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
1724     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
1725 #endif
1726     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
1727     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
1728     scavtab[CHARACTER_WIDETAG] = scav_immediate;
1729     scavtab[SAP_WIDETAG] = scav_unboxed;
1730     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
1731     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
1732     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
1733 #ifdef LISP_FEATURE_SPARC
1734     scavtab[FDEFN_WIDETAG] = scav_boxed;
1735 #else
1736     scavtab[FDEFN_WIDETAG] = scav_fdefn;
1737 #endif
1738
1739     /* transport other table, initialized same way as scavtab */
1740     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
1741         transother[i] = trans_lose;
1742     transother[BIGNUM_WIDETAG] = trans_unboxed;
1743     transother[RATIO_WIDETAG] = trans_boxed;
1744
1745 #if N_WORD_BITS == 64
1746     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
1747 #else
1748     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1749 #endif
1750     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1751 #ifdef LONG_FLOAT_WIDETAG
1752     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
1753 #endif
1754     transother[COMPLEX_WIDETAG] = trans_boxed;
1755 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1756     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1757 #endif
1758 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1759     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1760 #endif
1761 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1762     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
1763 #endif
1764     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
1765     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
1766 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1767     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
1768 #endif
1769     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
1770     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
1771     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
1772     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1773         trans_vector_unsigned_byte_2;
1774     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1775         trans_vector_unsigned_byte_4;
1776     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1777         trans_vector_unsigned_byte_8;
1778     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1779         trans_vector_unsigned_byte_8;
1780     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1781         trans_vector_unsigned_byte_16;
1782     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1783         trans_vector_unsigned_byte_16;
1784 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1785     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1786         trans_vector_unsigned_byte_32;
1787 #endif
1788     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1789         trans_vector_unsigned_byte_32;
1790     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1791         trans_vector_unsigned_byte_32;
1792 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1793     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1794         trans_vector_unsigned_byte_64;
1795 #endif
1796 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1797     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1798         trans_vector_unsigned_byte_64;
1799 #endif
1800 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1801     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1802         trans_vector_unsigned_byte_64;
1803 #endif
1804 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1805     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1806         trans_vector_unsigned_byte_8;
1807 #endif
1808 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1809     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1810         trans_vector_unsigned_byte_16;
1811 #endif
1812 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1813     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1814         trans_vector_unsigned_byte_32;
1815 #endif
1816 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1817     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1818         trans_vector_unsigned_byte_32;
1819 #endif
1820 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1821     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1822         trans_vector_unsigned_byte_64;
1823 #endif
1824 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1825     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1826         trans_vector_unsigned_byte_64;
1827 #endif
1828     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
1829         trans_vector_single_float;
1830     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
1831         trans_vector_double_float;
1832 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1833     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
1834         trans_vector_long_float;
1835 #endif
1836 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1837     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1838         trans_vector_complex_single_float;
1839 #endif
1840 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1841     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1842         trans_vector_complex_double_float;
1843 #endif
1844 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1845     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1846         trans_vector_complex_long_float;
1847 #endif
1848     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
1849 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1850     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
1851 #endif
1852     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
1853     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
1854     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
1855     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
1856     transother[CODE_HEADER_WIDETAG] = trans_code_header;
1857     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
1858     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
1859     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
1860     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
1861     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
1862     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
1863     transother[CHARACTER_WIDETAG] = trans_immediate;
1864     transother[SAP_WIDETAG] = trans_unboxed;
1865     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
1866     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
1867     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
1868     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
1869     transother[FDEFN_WIDETAG] = trans_boxed;
1870
1871     /* size table, initialized the same way as scavtab */
1872     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
1873         sizetab[i] = size_lose;
1874     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1875         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
1876         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1877         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1878         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1879         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
1880         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1881         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1882         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1883     }
1884     sizetab[BIGNUM_WIDETAG] = size_unboxed;
1885     sizetab[RATIO_WIDETAG] = size_boxed;
1886 #if N_WORD_BITS == 64
1887     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
1888 #else
1889     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
1890 #endif
1891     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1892 #ifdef LONG_FLOAT_WIDETAG
1893     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
1894 #endif
1895     sizetab[COMPLEX_WIDETAG] = size_boxed;
1896 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1897     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
1898 #endif
1899 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1900     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1901 #endif
1902 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1903     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
1904 #endif
1905     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
1906     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
1907 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1908     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
1909 #endif
1910     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
1911     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
1912     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
1913     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1914         size_vector_unsigned_byte_2;
1915     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1916         size_vector_unsigned_byte_4;
1917     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1918         size_vector_unsigned_byte_8;
1919     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1920         size_vector_unsigned_byte_8;
1921     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1922         size_vector_unsigned_byte_16;
1923     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1924         size_vector_unsigned_byte_16;
1925 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1926     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1927         size_vector_unsigned_byte_32;
1928 #endif
1929     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1930         size_vector_unsigned_byte_32;
1931     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1932         size_vector_unsigned_byte_32;
1933 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1934     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1935         size_vector_unsigned_byte_64;
1936 #endif
1937 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1938     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1939         size_vector_unsigned_byte_64;
1940 #endif
1941 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1942     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1943         size_vector_unsigned_byte_64;
1944 #endif
1945 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1946     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
1947 #endif
1948 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1949     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1950         size_vector_unsigned_byte_16;
1951 #endif
1952 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1953     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1954         size_vector_unsigned_byte_32;
1955 #endif
1956 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1957     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1958         size_vector_unsigned_byte_32;
1959 #endif
1960 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1961     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1962         size_vector_unsigned_byte_64;
1963 #endif
1964 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1965     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1966         size_vector_unsigned_byte_64;
1967 #endif
1968     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
1969     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
1970 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1971     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
1972 #endif
1973 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1974     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1975         size_vector_complex_single_float;
1976 #endif
1977 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1978     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1979         size_vector_complex_double_float;
1980 #endif
1981 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1982     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1983         size_vector_complex_long_float;
1984 #endif
1985     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
1986 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1987     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
1988 #endif
1989     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
1990     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
1991     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
1992     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
1993     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
1994 #if 0
1995     /* We shouldn't see these, so just lose if it happens. */
1996     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
1997     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
1998 #endif
1999     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2000     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2001     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2002     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2003     sizetab[CHARACTER_WIDETAG] = size_immediate;
2004     sizetab[SAP_WIDETAG] = size_unboxed;
2005     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2006     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2007     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2008     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2009     sizetab[FDEFN_WIDETAG] = size_boxed;
2010 }
2011
2012 \f
2013 /* Find the code object for the given pc, or return NULL on
2014    failure. */
2015 lispobj *
2016 component_ptr_from_pc(lispobj *pc)
2017 {
2018     lispobj *object = NULL;
2019
2020     if ( (object = search_read_only_space(pc)) )
2021         ;
2022     else if ( (object = search_static_space(pc)) )
2023         ;
2024     else
2025         object = search_dynamic_space(pc);
2026
2027     if (object) /* if we found something */
2028         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2029             return(object);
2030
2031     return (NULL);
2032 }
2033
2034 /* Scan an area looking for an object which encloses the given pointer.
2035  * Return the object start on success or NULL on failure. */
2036 lispobj *
2037 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2038 {
2039     while (words > 0) {
2040         size_t count = 1;
2041         lispobj thing = *start;
2042
2043         /* If thing is an immediate then this is a cons. */
2044         if (is_lisp_pointer(thing)
2045             || (fixnump(thing))
2046             || (widetag_of(thing) == CHARACTER_WIDETAG)
2047 #if N_WORD_BITS == 64
2048             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2049 #endif
2050             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2051             count = 2;
2052         else
2053             count = (sizetab[widetag_of(thing)])(start);
2054
2055         /* Check whether the pointer is within this object. */
2056         if ((pointer >= start) && (pointer < (start+count))) {
2057             /* found it! */
2058             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2059             return(start);
2060         }
2061
2062         /* Round up the count. */
2063         count = CEILING(count,2);
2064
2065         start += count;
2066         words -= count;
2067     }
2068     return (NULL);
2069 }