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