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