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 "genesis/hash-table.h"
  46 #include "gc-internal.h"
  47
  48 #ifdef LISP_FEATURE_SPARC
  49 #define LONG_FLOAT_SIZE 4
  50 #else
  51 #ifdef LISP_FEATURE_X86
  52 #define LONG_FLOAT_SIZE 3
  53 #endif
  54 #endif
  55
  56 inline static boolean
  57 forwarding_pointer_p(lispobj *pointer) {
  58     lispobj first_word=*pointer;
  59 #ifdef LISP_FEATURE_GENCGC
  60     return (first_word == 0x01);
  61 #else
  62     return (is_lisp_pointer(first_word)
  63             && new_space_p(first_word));
  64 #endif
  65 }
  66
  67 static inline lispobj *
  68 forwarding_pointer_value(lispobj *pointer) {
  69 #ifdef LISP_FEATURE_GENCGC
  70     return (lispobj *) ((pointer_sized_uint_t) pointer[1]);
  71 #else
  72     return (lispobj *) ((pointer_sized_uint_t) pointer[0]);
  73 #endif
  74 }
  75 static inline lispobj
  76 set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) {
  77 #ifdef LISP_FEATURE_GENCGC
  78     pointer[0]=0x01;
  79     pointer[1]=newspace_copy;
  80 #else
  81     pointer[0]=newspace_copy;
  82 #endif
  83     return newspace_copy;
  84 }
  85
  86 long (*scavtab[256])(lispobj *where, lispobj object);
  87 lispobj (*transother[256])(lispobj object);
  88 long (*sizetab[256])(lispobj *where);
  89 struct weak_pointer *weak_pointers;
  90
  91 unsigned long bytes_consed_between_gcs = 12*1024*1024;
  92
  93
  94 /*
  95  * copying objects
  96  */
  97
  98 /* to copy a boxed object */
  99 lispobj
 100 copy_object(lispobj object, long nwords)
 101 {
 102     int tag;
 103     lispobj *new;
 104
 105     gc_assert(is_lisp_pointer(object));
 106     gc_assert(from_space_p(object));
 107     gc_assert((nwords & 0x01) == 0);
 108
 109     /* Get tag of object. */
 110     tag = lowtag_of(object);
 111
 112     /* Allocate space. */
 113     new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK);
 114
 115     /* Copy the object. */
 116     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
 117     return make_lispobj(new,tag);
 118 }
 119
 120 static long scav_lose(lispobj *where, lispobj object); /* forward decl */
 121
 122 /* FIXME: Most calls end up going to some trouble to compute an
 123  * 'n_words' value for this function. The system might be a little
 124  * simpler if this function used an 'end' parameter instead. */
 125 void
 126 scavenge(lispobj *start, long n_words)
 127 {
 128     lispobj *end = start + n_words;
 129     lispobj *object_ptr;
 130     long n_words_scavenged;
 131
 132     for (object_ptr = start;
 133          object_ptr < end;
 134          object_ptr += n_words_scavenged) {
 135
 136         lispobj object = *object_ptr;
 137 #ifdef LISP_FEATURE_GENCGC
 138         gc_assert(!forwarding_pointer_p(object_ptr));
 139 #endif
 140         if (is_lisp_pointer(object)) {
 141             if (from_space_p(object)) {
 142                 /* It currently points to old space. Check for a
 143                  * forwarding pointer. */
 144                 lispobj *ptr = native_pointer(object);
 145                 if (forwarding_pointer_p(ptr)) {
 146                     /* Yes, there's a forwarding pointer. */
 147                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 148                     n_words_scavenged = 1;
 149                 } else {
 150                     /* Scavenge that pointer. */
 151                     n_words_scavenged =
 152                         (scavtab[widetag_of(object)])(object_ptr, object);
 153                 }
 154             } else {
 155                 /* It points somewhere other than oldspace. Leave it
 156                  * alone. */
 157                 n_words_scavenged = 1;
 158             }
 159         }
 160 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
 161         /* This workaround is probably not needed for those ports
 162            which don't have a partitioned register set (and therefore
 163            scan the stack conservatively for roots). */
 164         else if (n_words == 1) {
 165             /* there are some situations where an other-immediate may
 166                end up in a descriptor register.  I'm not sure whether
 167                this is supposed to happen, but if it does then we
 168                don't want to (a) barf or (b) scavenge over the
 169                data-block, because there isn't one.  So, if we're
 170                checking a single word and it's anything other than a
 171                pointer, just hush it up */
 172             int widetag = widetag_of(object);
 173             n_words_scavenged = 1;
 174
 175             if ((scavtab[widetag] == scav_lose) ||
 176                 (((sizetab[widetag])(object_ptr)) > 1)) {
 177                 fprintf(stderr,"warning: \
 178 attempted to scavenge non-descriptor value %x at %p.\n\n\
 179 If you can reproduce this warning, please send a bug report\n\
 180 (see manual page for details).\n",
 181                         object, object_ptr);
 182             }
 183         }
 184 #endif
 185         else if (fixnump(object)) {
 186             /* It's a fixnum: really easy.. */
 187             n_words_scavenged = 1;
 188         } else {
 189             /* It's some sort of header object or another. */
 190             n_words_scavenged =
 191                 (scavtab[widetag_of(object)])(object_ptr, object);
 192         }
 193     }
 194     gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n",
 195                       object_ptr, start, end);
 196 }
 197
 198 static lispobj trans_fun_header(lispobj object); /* forward decls */
 199 static lispobj trans_boxed(lispobj object);
 200
 201 static long
 202 scav_fun_pointer(lispobj *where, lispobj object)
 203 {
 204     lispobj *first_pointer;
 205     lispobj copy;
 206
 207     gc_assert(is_lisp_pointer(object));
 208
 209     /* Object is a pointer into from_space - not a FP. */
 210     first_pointer = (lispobj *) native_pointer(object);
 211
 212     /* must transport object -- object may point to either a function
 213      * header, a closure function header, or to a closure header. */
 214
 215     switch (widetag_of(*first_pointer)) {
 216     case SIMPLE_FUN_HEADER_WIDETAG:
 217         copy = trans_fun_header(object);
 218         break;
 219     default:
 220         copy = trans_boxed(object);
 221         break;
 222     }
 223
 224     if (copy != object) {
 225         /* Set forwarding pointer */
 226         set_forwarding_pointer(first_pointer,copy);
 227     }
 228
 229     gc_assert(is_lisp_pointer(copy));
 230     gc_assert(!from_space_p(copy));
 231
 232     *where = copy;
 233
 234     return 1;
 235 }
 236
 237
 238 static struct code *
 239 trans_code(struct code *code)
 240 {
 241     struct code *new_code;
 242     lispobj first, l_code, l_new_code;
 243     long nheader_words, ncode_words, nwords;
 244     unsigned long displacement;
 245     lispobj fheaderl, *prev_pointer;
 246
 247     /* if object has already been transported, just return pointer */
 248     first = code->header;
 249     if (forwarding_pointer_p((lispobj *)code)) {
 250 #ifdef DEBUG_CODE_GC
 251         printf("Was already transported\n");
 252 #endif
 253         return (struct code *) forwarding_pointer_value
 254             ((lispobj *)((pointer_sized_uint_t) code));
 255     }
 256
 257     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 258
 259     /* prepare to transport the code vector */
 260     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 261
 262     ncode_words = fixnum_value(code->code_size);
 263     nheader_words = HeaderValue(code->header);
 264     nwords = ncode_words + nheader_words;
 265     nwords = CEILING(nwords, 2);
 266
 267     l_new_code = copy_object(l_code, nwords);
 268     new_code = (struct code *) native_pointer(l_new_code);
 269
 270 #if defined(DEBUG_CODE_GC)
 271     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 272            (unsigned long) code, (unsigned long) new_code);
 273     printf("Code object is %d words long.\n", nwords);
 274 #endif
 275
 276 #ifdef LISP_FEATURE_GENCGC
 277     if (new_code == code)
 278         return new_code;
 279 #endif
 280
 281     displacement = l_new_code - l_code;
 282
 283     set_forwarding_pointer((lispobj *)code, l_new_code);
 284
 285     /* set forwarding pointers for all the function headers in the */
 286     /* code object.  also fix all self pointers */
 287
 288     fheaderl = code->entry_points;
 289     prev_pointer = &new_code->entry_points;
 290
 291     while (fheaderl != NIL) {
 292         struct simple_fun *fheaderp, *nfheaderp;
 293         lispobj nfheaderl;
 294
 295         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 296         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 297
 298         /* Calculate the new function pointer and the new */
 299         /* function header. */
 300         nfheaderl = fheaderl + displacement;
 301         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 302
 303 #ifdef DEBUG_CODE_GC
 304         printf("fheaderp->header (at %x) <- %x\n",
 305                &(fheaderp->header) , nfheaderl);
 306 #endif
 307         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 308
 309         /* fix self pointer. */
 310         nfheaderp->self =
 311 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 312             FUN_RAW_ADDR_OFFSET +
 313 #endif
 314             nfheaderl;
 315
 316         *prev_pointer = nfheaderl;
 317
 318         fheaderl = fheaderp->next;
 319         prev_pointer = &nfheaderp->next;
 320     }
 321 #ifdef LISP_FEATURE_GENCGC
 322     /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
 323        spaces once when all copying is done. */
 324     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
 325                     ncode_words * sizeof(long));
 326
 327 #endif
 328
 329 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 330     gencgc_apply_code_fixups(code, new_code);
 331 #endif
 332
 333     return new_code;
 334 }
 335
 336 static long
 337 scav_code_header(lispobj *where, lispobj object)
 338 {
 339     struct code *code;
 340     long n_header_words, n_code_words, n_words;
 341     lispobj entry_point;        /* tagged pointer to entry point */
 342     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 343
 344     code = (struct code *) where;
 345     n_code_words = fixnum_value(code->code_size);
 346     n_header_words = HeaderValue(object);
 347     n_words = n_code_words + n_header_words;
 348     n_words = CEILING(n_words, 2);
 349
 350     /* Scavenge the boxed section of the code data block. */
 351     scavenge(where + 1, n_header_words - 1);
 352
 353     /* Scavenge the boxed section of each function object in the
 354      * code data block. */
 355     for (entry_point = code->entry_points;
 356          entry_point != NIL;
 357          entry_point = function_ptr->next) {
 358
 359         gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n",
 360                           (long)entry_point);
 361
 362         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 363         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 364
 365         scavenge(&function_ptr->name, 1);
 366         scavenge(&function_ptr->arglist, 1);
 367         scavenge(&function_ptr->type, 1);
 368     }
 369
 370     return n_words;
 371 }
 372
 373 static lispobj
 374 trans_code_header(lispobj object)
 375 {
 376     struct code *ncode;
 377
 378     ncode = trans_code((struct code *) native_pointer(object));
 379     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 380 }
 381
 382
 383 static long
 384 size_code_header(lispobj *where)
 385 {
 386     struct code *code;
 387     long nheader_words, ncode_words, nwords;
 388
 389     code = (struct code *) where;
 390
 391     ncode_words = fixnum_value(code->code_size);
 392     nheader_words = HeaderValue(code->header);
 393     nwords = ncode_words + nheader_words;
 394     nwords = CEILING(nwords, 2);
 395
 396     return nwords;
 397 }
 398
 399 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 400 static long
 401 scav_return_pc_header(lispobj *where, lispobj object)
 402 {
 403     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
 404          (unsigned long) where,
 405          (unsigned long) object);
 406     return 0; /* bogus return value to satisfy static type checking */
 407 }
 408 #endif /* LISP_FEATURE_X86 */
 409
 410 static lispobj
 411 trans_return_pc_header(lispobj object)
 412 {
 413     struct simple_fun *return_pc;
 414     unsigned long offset;
 415     struct code *code, *ncode;
 416
 417     return_pc = (struct simple_fun *) native_pointer(object);
 418     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 419     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 420
 421     /* Transport the whole code object */
 422     code = (struct code *) ((unsigned long) return_pc - offset);
 423     ncode = trans_code(code);
 424
 425     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 426 }
 427
 428 /* On the 386, closures hold a pointer to the raw address instead of the
 429  * function object, so we can use CALL [$FDEFN+const] to invoke
 430  * the function without loading it into a register. Given that code
 431  * objects don't move, we don't need to update anything, but we do
 432  * have to figure out that the function is still live. */
 433
 434 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 435 static long
 436 scav_closure_header(lispobj *where, lispobj object)
 437 {
 438     struct closure *closure;
 439     lispobj fun;
 440
 441     closure = (struct closure *)where;
 442     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 443     scavenge(&fun, 1);
 444 #ifdef LISP_FEATURE_GENCGC
 445     /* The function may have moved so update the raw address. But
 446      * don't write unnecessarily. */
 447     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 448         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 449 #endif
 450     return 2;
 451 }
 452 #endif
 453
 454 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 455 static long
 456 scav_fun_header(lispobj *where, lispobj object)
 457 {
 458     lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
 459          (unsigned long) where,
 460          (unsigned long) object);
 461     return 0; /* bogus return value to satisfy static type checking */
 462 }
 463 #endif /* LISP_FEATURE_X86 */
 464
 465 static lispobj
 466 trans_fun_header(lispobj object)
 467 {
 468     struct simple_fun *fheader;
 469     unsigned long offset;
 470     struct code *code, *ncode;
 471
 472     fheader = (struct simple_fun *) native_pointer(object);
 473     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 474     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 475
 476     /* Transport the whole code object */
 477     code = (struct code *) ((unsigned long) fheader - offset);
 478     ncode = trans_code(code);
 479
 480     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 481 }
 482
 483 \f
 484 /*
 485  * instances
 486  */
 487
 488 static long
 489 scav_instance_pointer(lispobj *where, lispobj object)
 490 {
 491     lispobj copy, *first_pointer;
 492
 493     /* Object is a pointer into from space - not a FP. */
 494     copy = trans_boxed(object);
 495
 496 #ifdef LISP_FEATURE_GENCGC
 497     gc_assert(copy != object);
 498 #endif
 499
 500     first_pointer = (lispobj *) native_pointer(object);
 501     set_forwarding_pointer(first_pointer,copy);
 502     *where = copy;
 503
 504     return 1;
 505 }
 506
 507 \f
 508 /*
 509  * lists and conses
 510  */
 511
 512 static lispobj trans_list(lispobj object);
 513
 514 static long
 515 scav_list_pointer(lispobj *where, lispobj object)
 516 {
 517     lispobj first, *first_pointer;
 518
 519     gc_assert(is_lisp_pointer(object));
 520
 521     /* Object is a pointer into from space - not FP. */
 522     first_pointer = (lispobj *) native_pointer(object);
 523
 524     first = trans_list(object);
 525     gc_assert(first != object);
 526
 527     /* Set forwarding pointer */
 528     set_forwarding_pointer(first_pointer, first);
 529
 530     gc_assert(is_lisp_pointer(first));
 531     gc_assert(!from_space_p(first));
 532
 533     *where = first;
 534     return 1;
 535 }
 536
 537
 538 static lispobj
 539 trans_list(lispobj object)
 540 {
 541     lispobj new_list_pointer;
 542     struct cons *cons, *new_cons;
 543     lispobj cdr;
 544
 545     cons = (struct cons *) native_pointer(object);
 546
 547     /* Copy 'object'. */
 548     new_cons = (struct cons *)
 549         gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 550     new_cons->car = cons->car;
 551     new_cons->cdr = cons->cdr; /* updated later */
 552     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 553
 554     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 555     cdr = cons->cdr;
 556
 557     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 558
 559     /* Try to linearize the list in the cdr direction to help reduce
 560      * paging. */
 561     while (1) {
 562         lispobj  new_cdr;
 563         struct cons *cdr_cons, *new_cdr_cons;
 564
 565         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 566            !from_space_p(cdr) ||
 567            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 568             break;
 569
 570         cdr_cons = (struct cons *) native_pointer(cdr);
 571
 572         /* Copy 'cdr'. */
 573         new_cdr_cons = (struct cons*)
 574             gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 575         new_cdr_cons->car = cdr_cons->car;
 576         new_cdr_cons->cdr = cdr_cons->cdr;
 577         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 578
 579         /* Grab the cdr before it is clobbered. */
 580         cdr = cdr_cons->cdr;
 581         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 582
 583         /* Update the cdr of the last cons copied into new space to
 584          * keep the newspace scavenge from having to do it. */
 585         new_cons->cdr = new_cdr;
 586
 587         new_cons = new_cdr_cons;
 588     }
 589
 590     return new_list_pointer;
 591 }
 592
 593 \f
 594 /*
 595  * scavenging and transporting other pointers
 596  */
 597
 598 static long
 599 scav_other_pointer(lispobj *where, lispobj object)
 600 {
 601     lispobj first, *first_pointer;
 602
 603     gc_assert(is_lisp_pointer(object));
 604
 605     /* Object is a pointer into from space - not FP. */
 606     first_pointer = (lispobj *) native_pointer(object);
 607     first = (transother[widetag_of(*first_pointer)])(object);
 608
 609     if (first != object) {
 610         set_forwarding_pointer(first_pointer, first);
 611 #ifdef LISP_FEATURE_GENCGC
 612         *where = first;
 613 #endif
 614     }
 615 #ifndef LISP_FEATURE_GENCGC
 616     *where = first;
 617 #endif
 618     gc_assert(is_lisp_pointer(first));
 619     gc_assert(!from_space_p(first));
 620
 621     return 1;
 622 }
 623 \f
 624 /*
 625  * immediate, boxed, and unboxed objects
 626  */
 627
 628 static long
 629 size_pointer(lispobj *where)
 630 {
 631     return 1;
 632 }
 633
 634 static long
 635 scav_immediate(lispobj *where, lispobj object)
 636 {
 637     return 1;
 638 }
 639
 640 static lispobj
 641 trans_immediate(lispobj object)
 642 {
 643     lose("trying to transport an immediate\n");
 644     return NIL; /* bogus return value to satisfy static type checking */
 645 }
 646
 647 static long
 648 size_immediate(lispobj *where)
 649 {
 650     return 1;
 651 }
 652
 653
 654 static long
 655 scav_boxed(lispobj *where, lispobj object)
 656 {
 657     return 1;
 658 }
 659
 660 static long
 661 scav_instance(lispobj *where, lispobj object)
 662 {
 663     lispobj nuntagged;
 664     long ntotal = HeaderValue(object);
 665     lispobj layout = ((struct instance *)where)->slots[0];
 666
 667     if (!layout)
 668         return 1;
 669     if (forwarding_pointer_p(native_pointer(layout)))
 670         layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
 671
 672     nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
 673     scavenge(where + 1, ntotal - fixnum_value(nuntagged));
 674
 675     return ntotal + 1;
 676 }
 677
 678 static lispobj
 679 trans_boxed(lispobj object)
 680 {
 681     lispobj header;
 682     unsigned long length;
 683
 684     gc_assert(is_lisp_pointer(object));
 685
 686     header = *((lispobj *) native_pointer(object));
 687     length = HeaderValue(header) + 1;
 688     length = CEILING(length, 2);
 689
 690     return copy_object(object, length);
 691 }
 692
 693
 694 static long
 695 size_boxed(lispobj *where)
 696 {
 697     lispobj header;
 698     unsigned long length;
 699
 700     header = *where;
 701     length = HeaderValue(header) + 1;
 702     length = CEILING(length, 2);
 703
 704     return length;
 705 }
 706
 707 /* Note: on the sparc we don't have to do anything special for fdefns, */
 708 /* 'cause the raw-addr has a function lowtag. */
 709 #if !defined(LISP_FEATURE_SPARC)
 710 static long
 711 scav_fdefn(lispobj *where, lispobj object)
 712 {
 713     struct fdefn *fdefn;
 714
 715     fdefn = (struct fdefn *)where;
 716
 717     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 718        fdefn->fun, fdefn->raw_addr)); */
 719
 720     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
 721         == (char *)((unsigned long)(fdefn->raw_addr))) {
 722         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 723
 724         /* Don't write unnecessarily. */
 725         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 726             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 727         /* gc.c has more casts here, which may be relevant or alternatively
 728            may be compiler warning defeaters.  try
 729         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 730         */
 731         return sizeof(struct fdefn) / sizeof(lispobj);
 732     } else {
 733         return 1;
 734     }
 735 }
 736 #endif
 737
 738 static long
 739 scav_unboxed(lispobj *where, lispobj object)
 740 {
 741     unsigned long length;
 742
 743     length = HeaderValue(object) + 1;
 744     length = CEILING(length, 2);
 745
 746     return length;
 747 }
 748
 749 static lispobj
 750 trans_unboxed(lispobj object)
 751 {
 752     lispobj header;
 753     unsigned long length;
 754
 755
 756     gc_assert(is_lisp_pointer(object));
 757
 758     header = *((lispobj *) native_pointer(object));
 759     length = HeaderValue(header) + 1;
 760     length = CEILING(length, 2);
 761
 762     return copy_unboxed_object(object, length);
 763 }
 764
 765 static long
 766 size_unboxed(lispobj *where)
 767 {
 768     lispobj header;
 769     unsigned long length;
 770
 771     header = *where;
 772     length = HeaderValue(header) + 1;
 773     length = CEILING(length, 2);
 774
 775     return length;
 776 }
 777
 778 \f
 779 /* vector-like objects */
 780 static long
 781 scav_base_string(lispobj *where, lispobj object)
 782 {
 783     struct vector *vector;
 784     long length, nwords;
 785
 786     /* NOTE: Strings contain one more byte of data than the length */
 787     /* slot indicates. */
 788
 789     vector = (struct vector *) where;
 790     length = fixnum_value(vector->length) + 1;
 791     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 792
 793     return nwords;
 794 }
 795 static lispobj
 796 trans_base_string(lispobj object)
 797 {
 798     struct vector *vector;
 799     long length, nwords;
 800
 801     gc_assert(is_lisp_pointer(object));
 802
 803     /* NOTE: A string contains one more byte of data (a terminating
 804      * '\0' to help when interfacing with C functions) than indicated
 805      * by the length slot. */
 806
 807     vector = (struct vector *) native_pointer(object);
 808     length = fixnum_value(vector->length) + 1;
 809     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 810
 811     return copy_large_unboxed_object(object, nwords);
 812 }
 813
 814 static long
 815 size_base_string(lispobj *where)
 816 {
 817     struct vector *vector;
 818     long length, nwords;
 819
 820     /* NOTE: A string contains one more byte of data (a terminating
 821      * '\0' to help when interfacing with C functions) than indicated
 822      * by the length slot. */
 823
 824     vector = (struct vector *) where;
 825     length = fixnum_value(vector->length) + 1;
 826     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 827
 828     return nwords;
 829 }
 830
 831 static long
 832 scav_character_string(lispobj *where, lispobj object)
 833 {
 834     struct vector *vector;
 835     int length, nwords;
 836
 837     /* NOTE: Strings contain one more byte of data than the length */
 838     /* slot indicates. */
 839
 840     vector = (struct vector *) where;
 841     length = fixnum_value(vector->length) + 1;
 842     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 843
 844     return nwords;
 845 }
 846 static lispobj
 847 trans_character_string(lispobj object)
 848 {
 849     struct vector *vector;
 850     int length, nwords;
 851
 852     gc_assert(is_lisp_pointer(object));
 853
 854     /* NOTE: A string contains one more byte of data (a terminating
 855      * '\0' to help when interfacing with C functions) than indicated
 856      * by the length slot. */
 857
 858     vector = (struct vector *) native_pointer(object);
 859     length = fixnum_value(vector->length) + 1;
 860     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 861
 862     return copy_large_unboxed_object(object, nwords);
 863 }
 864
 865 static long
 866 size_character_string(lispobj *where)
 867 {
 868     struct vector *vector;
 869     int length, nwords;
 870
 871     /* NOTE: A string contains one more byte of data (a terminating
 872      * '\0' to help when interfacing with C functions) than indicated
 873      * by the length slot. */
 874
 875     vector = (struct vector *) where;
 876     length = fixnum_value(vector->length) + 1;
 877     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 878
 879     return nwords;
 880 }
 881
 882 static lispobj
 883 trans_vector(lispobj object)
 884 {
 885     struct vector *vector;
 886     long length, nwords;
 887
 888     gc_assert(is_lisp_pointer(object));
 889
 890     vector = (struct vector *) native_pointer(object);
 891
 892     length = fixnum_value(vector->length);
 893     nwords = CEILING(length + 2, 2);
 894
 895     return copy_large_object(object, nwords);
 896 }
 897
 898 static long
 899 size_vector(lispobj *where)
 900 {
 901     struct vector *vector;
 902     long length, nwords;
 903
 904     vector = (struct vector *) where;
 905     length = fixnum_value(vector->length);
 906     nwords = CEILING(length + 2, 2);
 907
 908     return nwords;
 909 }
 910
 911 static long
 912 scav_vector_nil(lispobj *where, lispobj object)
 913 {
 914     return 2;
 915 }
 916
 917 static lispobj
 918 trans_vector_nil(lispobj object)
 919 {
 920     gc_assert(is_lisp_pointer(object));
 921     return copy_unboxed_object(object, 2);
 922 }
 923
 924 static long
 925 size_vector_nil(lispobj *where)
 926 {
 927     /* Just the header word and the length word */
 928     return 2;
 929 }
 930
 931 static long
 932 scav_vector_bit(lispobj *where, lispobj object)
 933 {
 934     struct vector *vector;
 935     long length, nwords;
 936
 937     vector = (struct vector *) where;
 938     length = fixnum_value(vector->length);
 939     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 940
 941     return nwords;
 942 }
 943
 944 static lispobj
 945 trans_vector_bit(lispobj object)
 946 {
 947     struct vector *vector;
 948     long length, nwords;
 949
 950     gc_assert(is_lisp_pointer(object));
 951
 952     vector = (struct vector *) native_pointer(object);
 953     length = fixnum_value(vector->length);
 954     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 955
 956     return copy_large_unboxed_object(object, nwords);
 957 }
 958
 959 static long
 960 size_vector_bit(lispobj *where)
 961 {
 962     struct vector *vector;
 963     long length, nwords;
 964
 965     vector = (struct vector *) where;
 966     length = fixnum_value(vector->length);
 967     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 968
 969     return nwords;
 970 }
 971
 972 static long
 973 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 974 {
 975     struct vector *vector;
 976     long length, nwords;
 977
 978     vector = (struct vector *) where;
 979     length = fixnum_value(vector->length);
 980     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 981
 982     return nwords;
 983 }
 984
 985 static lispobj
 986 trans_vector_unsigned_byte_2(lispobj object)
 987 {
 988     struct vector *vector;
 989     long length, nwords;
 990
 991     gc_assert(is_lisp_pointer(object));
 992
 993     vector = (struct vector *) native_pointer(object);
 994     length = fixnum_value(vector->length);
 995     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 996
 997     return copy_large_unboxed_object(object, nwords);
 998 }
 999
1000 static long
1001 size_vector_unsigned_byte_2(lispobj *where)
1002 {
1003     struct vector *vector;
1004     long length, nwords;
1005
1006     vector = (struct vector *) where;
1007     length = fixnum_value(vector->length);
1008     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1009
1010     return nwords;
1011 }
1012
1013 static long
1014 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1015 {
1016     struct vector *vector;
1017     long length, nwords;
1018
1019     vector = (struct vector *) where;
1020     length = fixnum_value(vector->length);
1021     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1022
1023     return nwords;
1024 }
1025
1026 static lispobj
1027 trans_vector_unsigned_byte_4(lispobj object)
1028 {
1029     struct vector *vector;
1030     long length, nwords;
1031
1032     gc_assert(is_lisp_pointer(object));
1033
1034     vector = (struct vector *) native_pointer(object);
1035     length = fixnum_value(vector->length);
1036     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1037
1038     return copy_large_unboxed_object(object, nwords);
1039 }
1040 static long
1041 size_vector_unsigned_byte_4(lispobj *where)
1042 {
1043     struct vector *vector;
1044     long length, nwords;
1045
1046     vector = (struct vector *) where;
1047     length = fixnum_value(vector->length);
1048     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1049
1050     return nwords;
1051 }
1052
1053
1054 static long
1055 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1056 {
1057     struct vector *vector;
1058     long length, nwords;
1059
1060     vector = (struct vector *) where;
1061     length = fixnum_value(vector->length);
1062     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1063
1064     return nwords;
1065 }
1066
1067 /*********************/
1068
1069
1070
1071 static lispobj
1072 trans_vector_unsigned_byte_8(lispobj object)
1073 {
1074     struct vector *vector;
1075     long length, nwords;
1076
1077     gc_assert(is_lisp_pointer(object));
1078
1079     vector = (struct vector *) native_pointer(object);
1080     length = fixnum_value(vector->length);
1081     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1082
1083     return copy_large_unboxed_object(object, nwords);
1084 }
1085
1086 static long
1087 size_vector_unsigned_byte_8(lispobj *where)
1088 {
1089     struct vector *vector;
1090     long length, nwords;
1091
1092     vector = (struct vector *) where;
1093     length = fixnum_value(vector->length);
1094     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1095
1096     return nwords;
1097 }
1098
1099
1100 static long
1101 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1102 {
1103     struct vector *vector;
1104     long length, nwords;
1105
1106     vector = (struct vector *) where;
1107     length = fixnum_value(vector->length);
1108     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1109
1110     return nwords;
1111 }
1112
1113 static lispobj
1114 trans_vector_unsigned_byte_16(lispobj object)
1115 {
1116     struct vector *vector;
1117     long length, nwords;
1118
1119     gc_assert(is_lisp_pointer(object));
1120
1121     vector = (struct vector *) native_pointer(object);
1122     length = fixnum_value(vector->length);
1123     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1124
1125     return copy_large_unboxed_object(object, nwords);
1126 }
1127
1128 static long
1129 size_vector_unsigned_byte_16(lispobj *where)
1130 {
1131     struct vector *vector;
1132     long length, nwords;
1133
1134     vector = (struct vector *) where;
1135     length = fixnum_value(vector->length);
1136     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1137
1138     return nwords;
1139 }
1140
1141 static long
1142 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1143 {
1144     struct vector *vector;
1145     long length, nwords;
1146
1147     vector = (struct vector *) where;
1148     length = fixnum_value(vector->length);
1149     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1150
1151     return nwords;
1152 }
1153
1154 static lispobj
1155 trans_vector_unsigned_byte_32(lispobj object)
1156 {
1157     struct vector *vector;
1158     long length, nwords;
1159
1160     gc_assert(is_lisp_pointer(object));
1161
1162     vector = (struct vector *) native_pointer(object);
1163     length = fixnum_value(vector->length);
1164     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1165
1166     return copy_large_unboxed_object(object, nwords);
1167 }
1168
1169 static long
1170 size_vector_unsigned_byte_32(lispobj *where)
1171 {
1172     struct vector *vector;
1173     long length, nwords;
1174
1175     vector = (struct vector *) where;
1176     length = fixnum_value(vector->length);
1177     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1178
1179     return nwords;
1180 }
1181
1182 #if N_WORD_BITS == 64
1183 static long
1184 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1185 {
1186     struct vector *vector;
1187     long length, nwords;
1188
1189     vector = (struct vector *) where;
1190     length = fixnum_value(vector->length);
1191     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1192
1193     return nwords;
1194 }
1195
1196 static lispobj
1197 trans_vector_unsigned_byte_64(lispobj object)
1198 {
1199     struct vector *vector;
1200     long length, nwords;
1201
1202     gc_assert(is_lisp_pointer(object));
1203
1204     vector = (struct vector *) native_pointer(object);
1205     length = fixnum_value(vector->length);
1206     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1207
1208     return copy_large_unboxed_object(object, nwords);
1209 }
1210
1211 static long
1212 size_vector_unsigned_byte_64(lispobj *where)
1213 {
1214     struct vector *vector;
1215     long length, nwords;
1216
1217     vector = (struct vector *) where;
1218     length = fixnum_value(vector->length);
1219     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1220
1221     return nwords;
1222 }
1223 #endif
1224
1225 static long
1226 scav_vector_single_float(lispobj *where, lispobj object)
1227 {
1228     struct vector *vector;
1229     long length, nwords;
1230
1231     vector = (struct vector *) where;
1232     length = fixnum_value(vector->length);
1233     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1234
1235     return nwords;
1236 }
1237
1238 static lispobj
1239 trans_vector_single_float(lispobj object)
1240 {
1241     struct vector *vector;
1242     long length, nwords;
1243
1244     gc_assert(is_lisp_pointer(object));
1245
1246     vector = (struct vector *) native_pointer(object);
1247     length = fixnum_value(vector->length);
1248     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1249
1250     return copy_large_unboxed_object(object, nwords);
1251 }
1252
1253 static long
1254 size_vector_single_float(lispobj *where)
1255 {
1256     struct vector *vector;
1257     long length, nwords;
1258
1259     vector = (struct vector *) where;
1260     length = fixnum_value(vector->length);
1261     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1262
1263     return nwords;
1264 }
1265
1266 static long
1267 scav_vector_double_float(lispobj *where, lispobj object)
1268 {
1269     struct vector *vector;
1270     long length, nwords;
1271
1272     vector = (struct vector *) where;
1273     length = fixnum_value(vector->length);
1274     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1275
1276     return nwords;
1277 }
1278
1279 static lispobj
1280 trans_vector_double_float(lispobj object)
1281 {
1282     struct vector *vector;
1283     long length, nwords;
1284
1285     gc_assert(is_lisp_pointer(object));
1286
1287     vector = (struct vector *) native_pointer(object);
1288     length = fixnum_value(vector->length);
1289     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1290
1291     return copy_large_unboxed_object(object, nwords);
1292 }
1293
1294 static long
1295 size_vector_double_float(lispobj *where)
1296 {
1297     struct vector *vector;
1298     long length, nwords;
1299
1300     vector = (struct vector *) where;
1301     length = fixnum_value(vector->length);
1302     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1303
1304     return nwords;
1305 }
1306
1307 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1308 static long
1309 scav_vector_long_float(lispobj *where, lispobj object)
1310 {
1311     struct vector *vector;
1312     long length, nwords;
1313
1314     vector = (struct vector *) where;
1315     length = fixnum_value(vector->length);
1316     nwords = CEILING(length *
1317                      LONG_FLOAT_SIZE
1318                      + 2, 2);
1319     return nwords;
1320 }
1321
1322 static lispobj
1323 trans_vector_long_float(lispobj object)
1324 {
1325     struct vector *vector;
1326     long length, nwords;
1327
1328     gc_assert(is_lisp_pointer(object));
1329
1330     vector = (struct vector *) native_pointer(object);
1331     length = fixnum_value(vector->length);
1332     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1333
1334     return copy_large_unboxed_object(object, nwords);
1335 }
1336
1337 static long
1338 size_vector_long_float(lispobj *where)
1339 {
1340     struct vector *vector;
1341     long length, nwords;
1342
1343     vector = (struct vector *) where;
1344     length = fixnum_value(vector->length);
1345     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1346
1347     return nwords;
1348 }
1349 #endif
1350
1351
1352 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1353 static long
1354 scav_vector_complex_single_float(lispobj *where, lispobj object)
1355 {
1356     struct vector *vector;
1357     long length, nwords;
1358
1359     vector = (struct vector *) where;
1360     length = fixnum_value(vector->length);
1361     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1362
1363     return nwords;
1364 }
1365
1366 static lispobj
1367 trans_vector_complex_single_float(lispobj object)
1368 {
1369     struct vector *vector;
1370     long length, nwords;
1371
1372     gc_assert(is_lisp_pointer(object));
1373
1374     vector = (struct vector *) native_pointer(object);
1375     length = fixnum_value(vector->length);
1376     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1377
1378     return copy_large_unboxed_object(object, nwords);
1379 }
1380
1381 static long
1382 size_vector_complex_single_float(lispobj *where)
1383 {
1384     struct vector *vector;
1385     long length, nwords;
1386
1387     vector = (struct vector *) where;
1388     length = fixnum_value(vector->length);
1389     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1390
1391     return nwords;
1392 }
1393 #endif
1394
1395 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1396 static long
1397 scav_vector_complex_double_float(lispobj *where, lispobj object)
1398 {
1399     struct vector *vector;
1400     long length, nwords;
1401
1402     vector = (struct vector *) where;
1403     length = fixnum_value(vector->length);
1404     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1405
1406     return nwords;
1407 }
1408
1409 static lispobj
1410 trans_vector_complex_double_float(lispobj object)
1411 {
1412     struct vector *vector;
1413     long length, nwords;
1414
1415     gc_assert(is_lisp_pointer(object));
1416
1417     vector = (struct vector *) native_pointer(object);
1418     length = fixnum_value(vector->length);
1419     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1420
1421     return copy_large_unboxed_object(object, nwords);
1422 }
1423
1424 static long
1425 size_vector_complex_double_float(lispobj *where)
1426 {
1427     struct vector *vector;
1428     long length, nwords;
1429
1430     vector = (struct vector *) where;
1431     length = fixnum_value(vector->length);
1432     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1433
1434     return nwords;
1435 }
1436 #endif
1437
1438
1439 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1440 static long
1441 scav_vector_complex_long_float(lispobj *where, lispobj object)
1442 {
1443     struct vector *vector;
1444     long length, nwords;
1445
1446     vector = (struct vector *) where;
1447     length = fixnum_value(vector->length);
1448     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1449
1450     return nwords;
1451 }
1452
1453 static lispobj
1454 trans_vector_complex_long_float(lispobj object)
1455 {
1456     struct vector *vector;
1457     long length, nwords;
1458
1459     gc_assert(is_lisp_pointer(object));
1460
1461     vector = (struct vector *) native_pointer(object);
1462     length = fixnum_value(vector->length);
1463     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1464
1465     return copy_large_unboxed_object(object, nwords);
1466 }
1467
1468 static long
1469 size_vector_complex_long_float(lispobj *where)
1470 {
1471     struct vector *vector;
1472     long length, nwords;
1473
1474     vector = (struct vector *) where;
1475     length = fixnum_value(vector->length);
1476     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1477
1478     return nwords;
1479 }
1480 #endif
1481
1482 #define WEAK_POINTER_NWORDS \
1483         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1484
1485 static lispobj
1486 trans_weak_pointer(lispobj object)
1487 {
1488     lispobj copy;
1489 #ifndef LISP_FEATURE_GENCGC
1490     struct weak_pointer *wp;
1491 #endif
1492     gc_assert(is_lisp_pointer(object));
1493
1494 #if defined(DEBUG_WEAK)
1495     printf("Transporting weak pointer from 0x%08x\n", object);
1496 #endif
1497
1498     /* Need to remember where all the weak pointers are that have */
1499     /* been transported so they can be fixed up in a post-GC pass. */
1500
1501     copy = copy_object(object, WEAK_POINTER_NWORDS);
1502 #ifndef LISP_FEATURE_GENCGC
1503     wp = (struct weak_pointer *) native_pointer(copy);
1504
1505     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1506     /* Push the weak pointer onto the list of weak pointers. */
1507     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1508     weak_pointers = wp;
1509 #endif
1510     return copy;
1511 }
1512
1513 static long
1514 size_weak_pointer(lispobj *where)
1515 {
1516     return WEAK_POINTER_NWORDS;
1517 }
1518
1519
1520 void scan_weak_pointers(void)
1521 {
1522     struct weak_pointer *wp;
1523     for (wp = weak_pointers; wp != NULL; wp=wp->next) {
1524         lispobj value = wp->value;
1525         lispobj *first_pointer;
1526         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1527         if (!(is_lisp_pointer(value) && from_space_p(value)))
1528             continue;
1529
1530         /* Now, we need to check whether the object has been forwarded. If
1531          * it has been, the weak pointer is still good and needs to be
1532          * updated. Otherwise, the weak pointer needs to be nil'ed
1533          * out. */
1534
1535         first_pointer = (lispobj *)native_pointer(value);
1536
1537         if (forwarding_pointer_p(first_pointer)) {
1538             wp->value=
1539                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1540         } else {
1541             /* Break it. */
1542             wp->value = NIL;
1543             wp->broken = T;
1544         }
1545     }
1546 }
1547
1548 \f
1549 /* Hash tables */
1550
1551 #if N_WORD_BITS == 32
1552 #define EQ_HASH_MASK 0x1fffffff
1553 #elif N_WORD_BITS == 64
1554 #define EQ_HASH_MASK 0x1fffffffffffffff
1555 #endif
1556
1557 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1558  * target-hash-table.lisp.  */
1559 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1560
1561 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1562  * slot. Set to NULL at the end of a collection.
1563  *
1564  * This is not optimal because, when a table is tenured, it won't be
1565  * processed automatically; only the yougest generation is GC'd by
1566  * default. On the other hand, all applications will need an
1567  * occasional full GC anyway, so it's not that bad either.  */
1568 struct hash_table *weak_hash_tables = NULL;
1569
1570 /* Return true if OBJ has already survived the current GC. */
1571 static inline int
1572 survived_gc_yet (lispobj obj)
1573 {
1574     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1575             forwarding_pointer_p(native_pointer(obj)));
1576 }
1577
1578 static inline int
1579 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1580 {
1581     switch (weakness) {
1582     case KEY:
1583         return survived_gc_yet(key);
1584     case VALUE:
1585         return survived_gc_yet(value);
1586     case KEY_OR_VALUE:
1587         return (survived_gc_yet(key) || survived_gc_yet(value));
1588     case KEY_AND_VALUE:
1589         return (survived_gc_yet(key) && survived_gc_yet(value));
1590     default:
1591         gc_assert(0);
1592         /* Shut compiler up. */
1593         return 0;
1594     }
1595 }
1596
1597 /* Return the beginning of data in ARRAY (skipping the header and the
1598  * length) or NULL if it isn't an array of the specified widetag after
1599  * all. */
1600 static inline lispobj *
1601 get_array_data (lispobj array, int widetag, unsigned long *length)
1602 {
1603     if (is_lisp_pointer(array) &&
1604         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1605         if (length != NULL)
1606             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1607         return ((lispobj *)native_pointer(array)) + 2;
1608     } else {
1609         return NULL;
1610     }
1611 }
1612
1613 /* Only need to worry about scavenging the _real_ entries in the
1614  * table. Phantom entries such as the hash table itself at index 0 and
1615  * the empty marker at index 1 were scavenged by scav_vector that
1616  * either called this function directly or arranged for it to be
1617  * called later by pushing the hash table onto weak_hash_tables. */
1618 static void
1619 scav_hash_table_entries (struct hash_table *hash_table)
1620 {
1621     lispobj *kv_vector;
1622     unsigned long kv_length;
1623     lispobj *index_vector;
1624     unsigned long length;
1625     lispobj *next_vector;
1626     unsigned long next_vector_length;
1627     lispobj *hash_vector;
1628     unsigned long hash_vector_length;
1629     lispobj empty_symbol;
1630     lispobj weakness = hash_table->weakness;
1631     long i;
1632
1633     kv_vector = get_array_data(hash_table->table,
1634                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1635     if (kv_vector == NULL)
1636         lose("invalid kv_vector %x\n", hash_table->table);
1637
1638     index_vector = get_array_data(hash_table->index_vector,
1639                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1640     if (index_vector == NULL)
1641         lose("invalid index_vector %x\n", hash_table->index_vector);
1642
1643     next_vector = get_array_data(hash_table->next_vector,
1644                                  SIMPLE_ARRAY_WORD_WIDETAG,
1645                                  &next_vector_length);
1646     if (next_vector == NULL)
1647         lose("invalid next_vector %x\n", hash_table->next_vector);
1648
1649     hash_vector = get_array_data(hash_table->hash_vector,
1650                                  SIMPLE_ARRAY_WORD_WIDETAG,
1651                                  &hash_vector_length);
1652     if (hash_vector != NULL)
1653         gc_assert(hash_vector_length == next_vector_length);
1654
1655      /* These lengths could be different as the index_vector can be a
1656       * different length from the others, a larger index_vector could
1657       * help reduce collisions. */
1658      gc_assert(next_vector_length*2 == kv_length);
1659
1660     empty_symbol = kv_vector[1];
1661     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1662     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1663         SYMBOL_HEADER_WIDETAG) {
1664         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1665              *(lispobj *)native_pointer(empty_symbol));
1666     }
1667
1668     /* Work through the KV vector. */
1669     for (i = 1; i < next_vector_length; i++) {
1670         lispobj old_key = kv_vector[2*i];
1671         lispobj value = kv_vector[2*i+1];
1672         if ((weakness == NIL) ||
1673             weak_hash_entry_alivep(weakness, old_key, value)) {
1674
1675             /* Scavenge the key and value. */
1676             scavenge(&kv_vector[2*i],2);
1677
1678             /* Rehashing of EQ based keys. */
1679             if ((!hash_vector) ||
1680                 (hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) {
1681 #ifndef LISP_FEATURE_GENCGC
1682                 /* For GENCGC scav_hash_table_entries only rehashes
1683                  * the entries whose keys were moved. Cheneygc always
1684                  * moves the objects so here we let the lisp side know
1685                  * that rehashing is needed for the whole table. */
1686                 *(kv_vector - 2) = (subtype_VectorMustRehash<<N_WIDETAG_BITS) |
1687                     SIMPLE_VECTOR_WIDETAG;
1688 #else
1689                 unsigned long old_index = EQ_HASH(old_key)%length;
1690                 lispobj new_key = kv_vector[2*i];
1691                 unsigned long new_index = EQ_HASH(new_key)%length;
1692                 /* Check whether the key has moved. */
1693                 if ((old_index != new_index) &&
1694                     (new_key != empty_symbol)) {
1695                     gc_assert(kv_vector[2*i+1] != empty_symbol);
1696
1697                     /*FSHOW((stderr,
1698                       "* EQ key %d moved from %x to %x; index %d to %d\n",
1699                       i, old_key, new_key, old_index, new_index));*/
1700
1701                     /* Unlink the key from the old_index chain. */
1702                     if (!index_vector[old_index]) {
1703                         /* It's not here, must be on the
1704                          * needing_rehash chain. */
1705                     } else if (index_vector[old_index] == i) {
1706                         /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
1707                         index_vector[old_index] = next_vector[i];
1708                         /* Link it into the needing rehash chain. */
1709                         next_vector[i] =
1710                             fixnum_value(hash_table->needing_rehash);
1711                         hash_table->needing_rehash = make_fixnum(i);
1712                         /*SHOW("P2");*/
1713                     } else {
1714                         unsigned long prior = index_vector[old_index];
1715                         unsigned long next = next_vector[prior];
1716
1717                         /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
1718
1719                         while (next != 0) {
1720                             /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
1721                             if (next == i) {
1722                                 /* Unlink it. */
1723                                 next_vector[prior] = next_vector[next];
1724                                 /* Link it into the needing rehash
1725                                  * chain. */
1726                                 next_vector[next] =
1727                                     fixnum_value(hash_table->needing_rehash);
1728                                 hash_table->needing_rehash = make_fixnum(next);
1729                                 /*SHOW("/P3");*/
1730                                 break;
1731                             }
1732                             prior = next;
1733                             next = next_vector[next];
1734                         }
1735                     }
1736                 }
1737 #endif
1738             }
1739         }
1740     }
1741 }
1742
1743 long
1744 scav_vector (lispobj *where, lispobj object)
1745 {
1746     unsigned long kv_length;
1747     lispobj *kv_vector;
1748     struct hash_table *hash_table;
1749
1750     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1751      * hash tables in the Lisp HASH-TABLE code to indicate need for
1752      * special GC support. */
1753     if (HeaderValue(object) == subtype_VectorNormal)
1754         return 1;
1755
1756     kv_length = fixnum_value(where[1]);
1757     kv_vector = where + 2;  /* Skip the header and length. */
1758     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1759
1760     /* Scavenge element 0, which may be a hash-table structure. */
1761     scavenge(where+2, 1);
1762     if (!is_lisp_pointer(where[2])) {
1763         lose("no pointer at %x in hash table\n", where[2]);
1764     }
1765     hash_table = (struct hash_table *)native_pointer(where[2]);
1766     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1767     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1768         lose("hash table not instance (%x at %x)\n",
1769              hash_table->header,
1770              hash_table);
1771     }
1772
1773     /* Scavenge element 1, which should be some internal symbol that
1774      * the hash table code reserves for marking empty slots. */
1775     scavenge(where+3, 1);
1776     if (!is_lisp_pointer(where[3])) {
1777         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1778     }
1779
1780     /* Scavenge hash table, which will fix the positions of the other
1781      * needed objects. */
1782     scavenge((lispobj *)hash_table,
1783              sizeof(struct hash_table) / sizeof(lispobj));
1784
1785     /* Cross-check the kv_vector. */
1786     if (where != (lispobj *)native_pointer(hash_table->table)) {
1787         lose("hash_table table!=this table %x\n", hash_table->table);
1788     }
1789
1790     if (hash_table->weakness == NIL) {
1791         scav_hash_table_entries(hash_table);
1792     } else {
1793         /* Delay scavenging of this table by pushing it onto
1794          * weak_hash_tables (if it's not there already) for the weak
1795          * object phase. */
1796         if (hash_table->next_weak_hash_table == NIL) {
1797             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1798             weak_hash_tables = hash_table;
1799         }
1800     }
1801
1802     return (CEILING(kv_length + 2, 2));
1803 }
1804
1805 void
1806 scav_weak_hash_tables (void)
1807 {
1808     struct hash_table *table;
1809
1810     /* Scavenge entries whose triggers are known to survive. */
1811     for (table = weak_hash_tables; table != NULL;
1812          table = (struct hash_table *)table->next_weak_hash_table) {
1813         scav_hash_table_entries(table);
1814     }
1815 }
1816
1817 /* Walk through the chain whose first element is *FIRST and remove
1818  * dead weak entries. */
1819 static inline void
1820 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1821                             lispobj *kv_vector, lispobj *index_vector,
1822                             lispobj *next_vector, lispobj *hash_vector,
1823                             lispobj empty_symbol, lispobj weakness)
1824 {
1825     unsigned index = *prev;
1826     while (index) {
1827         unsigned next = next_vector[index];
1828         lispobj key = kv_vector[2 * index];
1829         lispobj value = kv_vector[2 * index + 1];
1830         gc_assert(key != empty_symbol);
1831         gc_assert(value != empty_symbol);
1832         if (!weak_hash_entry_alivep(weakness, key, value)) {
1833             unsigned count = fixnum_value(hash_table->number_entries);
1834             gc_assert(count > 0);
1835             *prev = next;
1836             hash_table->number_entries = make_fixnum(count - 1);
1837             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1838             hash_table->next_free_kv = make_fixnum(index);
1839             kv_vector[2 * index] = empty_symbol;
1840             kv_vector[2 * index + 1] = empty_symbol;
1841             if (hash_vector)
1842                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1843         } else {
1844             prev = &next_vector[index];
1845         }
1846         index = next;
1847     }
1848 }
1849
1850 static void
1851 scan_weak_hash_table (struct hash_table *hash_table)
1852 {
1853     lispobj *kv_vector;
1854     lispobj *index_vector;
1855     unsigned long length = 0; /* prevent warning */
1856     lispobj *next_vector;
1857     unsigned long next_vector_length = 0; /* prevent warning */
1858     lispobj *hash_vector;
1859     lispobj empty_symbol;
1860     lispobj weakness = hash_table->weakness;
1861     long i;
1862
1863     kv_vector = get_array_data(hash_table->table,
1864                                SIMPLE_VECTOR_WIDETAG, NULL);
1865     index_vector = get_array_data(hash_table->index_vector,
1866                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1867     next_vector = get_array_data(hash_table->next_vector,
1868                                  SIMPLE_ARRAY_WORD_WIDETAG,
1869                                  &next_vector_length);
1870     hash_vector = get_array_data(hash_table->hash_vector,
1871                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1872     empty_symbol = kv_vector[1];
1873
1874     for (i = 0; i < length; i++) {
1875         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1876                                    kv_vector, index_vector, next_vector,
1877                                    hash_vector, empty_symbol, weakness);
1878     }
1879     {
1880         lispobj first = fixnum_value(hash_table->needing_rehash);
1881         scan_weak_hash_table_chain(hash_table, &first,
1882                                    kv_vector, index_vector, next_vector,
1883                                    hash_vector, empty_symbol, weakness);
1884         hash_table->needing_rehash = make_fixnum(first);
1885     }
1886 }
1887
1888 /* Remove dead entries from weak hash tables. */
1889 void
1890 scan_weak_hash_tables (void)
1891 {
1892     struct hash_table *table, *next;
1893
1894     for (table = weak_hash_tables; table != NULL; table = next) {
1895         next = (struct hash_table *)table->next_weak_hash_table;
1896         table->next_weak_hash_table = NIL;
1897         scan_weak_hash_table(table);
1898     }
1899
1900     weak_hash_tables = NULL;
1901 }
1902
1903 \f
1904 /*
1905  * initialization
1906  */
1907
1908 static long
1909 scav_lose(lispobj *where, lispobj object)
1910 {
1911     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1912          (unsigned long)object,
1913          widetag_of(*(lispobj*)native_pointer(object)));
1914
1915     return 0; /* bogus return value to satisfy static type checking */
1916 }
1917
1918 static lispobj
1919 trans_lose(lispobj object)
1920 {
1921     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1922          (unsigned long)object,
1923          widetag_of(*(lispobj*)native_pointer(object)));
1924     return NIL; /* bogus return value to satisfy static type checking */
1925 }
1926
1927 static long
1928 size_lose(lispobj *where)
1929 {
1930     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1931          (unsigned long)where,
1932          widetag_of(LOW_WORD(where)));
1933     return 1; /* bogus return value to satisfy static type checking */
1934 }
1935
1936 \f
1937 /*
1938  * initialization
1939  */
1940
1941 void
1942 gc_init_tables(void)
1943 {
1944     long i;
1945
1946     /* Set default value in all slots of scavenge table.  FIXME
1947      * replace this gnarly sizeof with something based on
1948      * N_WIDETAG_BITS */
1949     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1950         scavtab[i] = scav_lose;
1951     }
1952
1953     /* For each type which can be selected by the lowtag alone, set
1954      * multiple entries in our widetag scavenge table (one for each
1955      * possible value of the high bits).
1956      */
1957
1958     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1959         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1960         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1961         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1962         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1963         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1964         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1965         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1966         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1967     }
1968
1969     /* Other-pointer types (those selected by all eight bits of the
1970      * tag) get one entry each in the scavenge table. */
1971     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1972     scavtab[RATIO_WIDETAG] = scav_boxed;
1973 #if N_WORD_BITS == 64
1974     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1975 #else
1976     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1977 #endif
1978     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1979 #ifdef LONG_FLOAT_WIDETAG
1980     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1981 #endif
1982     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1983 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1984     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1985 #endif
1986 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1987     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1988 #endif
1989 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1990     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1991 #endif
1992     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1993     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1994 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1995     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1996 #endif
1997     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1998     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1999     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2000         scav_vector_unsigned_byte_2;
2001     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2002         scav_vector_unsigned_byte_4;
2003     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2004         scav_vector_unsigned_byte_8;
2005     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2006         scav_vector_unsigned_byte_8;
2007     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2008         scav_vector_unsigned_byte_16;
2009     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2010         scav_vector_unsigned_byte_16;
2011 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2012     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2013         scav_vector_unsigned_byte_32;
2014 #endif
2015     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2016         scav_vector_unsigned_byte_32;
2017     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2018         scav_vector_unsigned_byte_32;
2019 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2020     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2021         scav_vector_unsigned_byte_64;
2022 #endif
2023 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2024     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2025         scav_vector_unsigned_byte_64;
2026 #endif
2027 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2028     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2029         scav_vector_unsigned_byte_64;
2030 #endif
2031 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2032     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
2033 #endif
2034 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2035     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2036         scav_vector_unsigned_byte_16;
2037 #endif
2038 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2039     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2040         scav_vector_unsigned_byte_32;
2041 #endif
2042 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2043     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2044         scav_vector_unsigned_byte_32;
2045 #endif
2046 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2047     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2048         scav_vector_unsigned_byte_64;
2049 #endif
2050 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2051     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2052         scav_vector_unsigned_byte_64;
2053 #endif
2054     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2055     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2056 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2057     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2058 #endif
2059 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2060     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2061         scav_vector_complex_single_float;
2062 #endif
2063 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2064     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2065         scav_vector_complex_double_float;
2066 #endif
2067 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2068     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2069         scav_vector_complex_long_float;
2070 #endif
2071     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2072 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2073     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2074 #endif
2075     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2076     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2077     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2078     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2079     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2080 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2081     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2082     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2083 #endif
2084     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2085 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2086     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2087 #else
2088     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2089 #endif
2090     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2091     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2092     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2093     scavtab[SAP_WIDETAG] = scav_unboxed;
2094     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2095     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2096     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2097 #if defined(LISP_FEATURE_SPARC)
2098     scavtab[FDEFN_WIDETAG] = scav_boxed;
2099 #else
2100     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2101 #endif
2102     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2103
2104     /* transport other table, initialized same way as scavtab */
2105     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2106         transother[i] = trans_lose;
2107     transother[BIGNUM_WIDETAG] = trans_unboxed;
2108     transother[RATIO_WIDETAG] = trans_boxed;
2109
2110 #if N_WORD_BITS == 64
2111     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2112 #else
2113     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2114 #endif
2115     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2116 #ifdef LONG_FLOAT_WIDETAG
2117     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2118 #endif
2119     transother[COMPLEX_WIDETAG] = trans_boxed;
2120 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2121     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2122 #endif
2123 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2124     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2125 #endif
2126 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2127     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2128 #endif
2129     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2130     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2131 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2132     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2133 #endif
2134     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2135     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2136     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2137     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2138         trans_vector_unsigned_byte_2;
2139     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2140         trans_vector_unsigned_byte_4;
2141     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2142         trans_vector_unsigned_byte_8;
2143     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2144         trans_vector_unsigned_byte_8;
2145     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2146         trans_vector_unsigned_byte_16;
2147     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2148         trans_vector_unsigned_byte_16;
2149 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2150     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2151         trans_vector_unsigned_byte_32;
2152 #endif
2153     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2154         trans_vector_unsigned_byte_32;
2155     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2156         trans_vector_unsigned_byte_32;
2157 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2158     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2159         trans_vector_unsigned_byte_64;
2160 #endif
2161 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2162     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2163         trans_vector_unsigned_byte_64;
2164 #endif
2165 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2166     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2167         trans_vector_unsigned_byte_64;
2168 #endif
2169 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2170     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2171         trans_vector_unsigned_byte_8;
2172 #endif
2173 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2174     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2175         trans_vector_unsigned_byte_16;
2176 #endif
2177 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2178     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2179         trans_vector_unsigned_byte_32;
2180 #endif
2181 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2182     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2183         trans_vector_unsigned_byte_32;
2184 #endif
2185 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2186     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2187         trans_vector_unsigned_byte_64;
2188 #endif
2189 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2190     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2191         trans_vector_unsigned_byte_64;
2192 #endif
2193     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2194         trans_vector_single_float;
2195     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2196         trans_vector_double_float;
2197 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2198     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2199         trans_vector_long_float;
2200 #endif
2201 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2202     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2203         trans_vector_complex_single_float;
2204 #endif
2205 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2206     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2207         trans_vector_complex_double_float;
2208 #endif
2209 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2210     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2211         trans_vector_complex_long_float;
2212 #endif
2213     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2214 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2215     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2216 #endif
2217     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2218     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2219     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2220     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2221     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2222     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2223     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2224     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2225     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2226     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2227     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2228     transother[CHARACTER_WIDETAG] = trans_immediate;
2229     transother[SAP_WIDETAG] = trans_unboxed;
2230     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2231     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2232     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2233     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2234     transother[FDEFN_WIDETAG] = trans_boxed;
2235
2236     /* size table, initialized the same way as scavtab */
2237     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2238         sizetab[i] = size_lose;
2239     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2240         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2241         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2242         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2243         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2244         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2245         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2246         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2247         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2248     }
2249     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2250     sizetab[RATIO_WIDETAG] = size_boxed;
2251 #if N_WORD_BITS == 64
2252     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2253 #else
2254     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2255 #endif
2256     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2257 #ifdef LONG_FLOAT_WIDETAG
2258     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2259 #endif
2260     sizetab[COMPLEX_WIDETAG] = size_boxed;
2261 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2262     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2263 #endif
2264 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2265     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2266 #endif
2267 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2268     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2269 #endif
2270     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2271     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2272 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2273     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2274 #endif
2275     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2276     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2277     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2278     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2279         size_vector_unsigned_byte_2;
2280     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2281         size_vector_unsigned_byte_4;
2282     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2283         size_vector_unsigned_byte_8;
2284     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2285         size_vector_unsigned_byte_8;
2286     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2287         size_vector_unsigned_byte_16;
2288     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2289         size_vector_unsigned_byte_16;
2290 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2291     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2292         size_vector_unsigned_byte_32;
2293 #endif
2294     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2295         size_vector_unsigned_byte_32;
2296     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2297         size_vector_unsigned_byte_32;
2298 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2299     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2300         size_vector_unsigned_byte_64;
2301 #endif
2302 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2303     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2304         size_vector_unsigned_byte_64;
2305 #endif
2306 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2307     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2308         size_vector_unsigned_byte_64;
2309 #endif
2310 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2311     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2312 #endif
2313 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2314     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2315         size_vector_unsigned_byte_16;
2316 #endif
2317 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2318     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2319         size_vector_unsigned_byte_32;
2320 #endif
2321 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2322     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2323         size_vector_unsigned_byte_32;
2324 #endif
2325 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2326     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2327         size_vector_unsigned_byte_64;
2328 #endif
2329 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2330     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2331         size_vector_unsigned_byte_64;
2332 #endif
2333     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2334     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2335 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2336     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2337 #endif
2338 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2339     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2340         size_vector_complex_single_float;
2341 #endif
2342 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2343     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2344         size_vector_complex_double_float;
2345 #endif
2346 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2347     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2348         size_vector_complex_long_float;
2349 #endif
2350     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2351 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2352     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2353 #endif
2354     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2355     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2356     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2357     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2358     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2359 #if 0
2360     /* We shouldn't see these, so just lose if it happens. */
2361     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2362     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2363 #endif
2364     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2365     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2366     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2367     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2368     sizetab[CHARACTER_WIDETAG] = size_immediate;
2369     sizetab[SAP_WIDETAG] = size_unboxed;
2370     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2371     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2372     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2373     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2374     sizetab[FDEFN_WIDETAG] = size_boxed;
2375 }
2376
2377 \f
2378 /* Find the code object for the given pc, or return NULL on
2379    failure. */
2380 lispobj *
2381 component_ptr_from_pc(lispobj *pc)
2382 {
2383     lispobj *object = NULL;
2384
2385     if ( (object = search_read_only_space(pc)) )
2386         ;
2387     else if ( (object = search_static_space(pc)) )
2388         ;
2389     else
2390         object = search_dynamic_space(pc);
2391
2392     if (object) /* if we found something */
2393         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2394             return(object);
2395
2396     return (NULL);
2397 }
2398
2399 /* Scan an area looking for an object which encloses the given pointer.
2400  * Return the object start on success or NULL on failure. */
2401 lispobj *
2402 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2403 {
2404     while (words > 0) {
2405         size_t count = 1;
2406         lispobj thing = *start;
2407
2408         /* If thing is an immediate then this is a cons. */
2409         if (is_lisp_pointer(thing)
2410             || (fixnump(thing))
2411             || (widetag_of(thing) == CHARACTER_WIDETAG)
2412 #if N_WORD_BITS == 64
2413             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2414 #endif
2415             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2416             count = 2;
2417         else
2418             count = (sizetab[widetag_of(thing)])(start);
2419
2420         /* Check whether the pointer is within this object. */
2421         if ((pointer >= start) && (pointer < (start+count))) {
2422             /* found it! */
2423             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2424             return(start);
2425         }
2426
2427         /* Round up the count. */
2428         count = CEILING(count,2);
2429
2430         start += count;
2431         words -= count;
2432     }
2433     return (NULL);
2434 }