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