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