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 "gc.h"
  41 #include "genesis/primitive-objects.h"
  42 #include "genesis/static-symbols.h"
  43 #include "genesis/layout.h"
  44 #include "genesis/hash-table.h"
  45 #include "gc-internal.h"
  46
  47 #ifdef LISP_FEATURE_SPARC
  48 #define LONG_FLOAT_SIZE 4
  49 #else
  50 #ifdef LISP_FEATURE_X86
  51 #define LONG_FLOAT_SIZE 3
  52 #endif
  53 #endif
  54
  55 os_vm_size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE;
  56 os_vm_size_t thread_control_stack_size = DEFAULT_CONTROL_STACK_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 sword_t (*scavtab[256])(lispobj *where, lispobj object);
  89 lispobj (*transother[256])(lispobj object);
  90 sword_t (*sizetab[256])(lispobj *where);
  91 struct weak_pointer *weak_pointers;
  92
  93 os_vm_size_t bytes_consed_between_gcs = 12*1024*1024;
  94
  95 /*
  96  * copying objects
  97  */
  98
  99 /* gc_general_copy_object is inline from gc-internal.h */
 100
 101 /* to copy a boxed object */
 102 lispobj
 103 copy_object(lispobj object, sword_t nwords)
 104 {
 105     return gc_general_copy_object(object, nwords, BOXED_PAGE_FLAG);
 106 }
 107
 108 lispobj
 109 copy_code_object(lispobj object, sword_t nwords)
 110 {
 111     return gc_general_copy_object(object, nwords, CODE_PAGE_FLAG);
 112 }
 113
 114 static sword_t scav_lose(lispobj *where, lispobj object); /* forward decl */
 115
 116 /* FIXME: Most calls end up going to some trouble to compute an
 117  * 'n_words' value for this function. The system might be a little
 118  * simpler if this function used an 'end' parameter instead. */
 119 void
 120 scavenge(lispobj *start, sword_t n_words)
 121 {
 122     lispobj *end = start + n_words;
 123     lispobj *object_ptr;
 124     sword_t n_words_scavenged;
 125
 126     for (object_ptr = start;
 127          object_ptr < end;
 128          object_ptr += n_words_scavenged) {
 129
 130         lispobj object = *object_ptr;
 131 #ifdef LISP_FEATURE_GENCGC
 132         if (forwarding_pointer_p(object_ptr))
 133             lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
 134                  object_ptr, start, n_words);
 135 #endif
 136         if (is_lisp_pointer(object)) {
 137             if (from_space_p(object)) {
 138                 /* It currently points to old space. Check for a
 139                  * forwarding pointer. */
 140                 lispobj *ptr = native_pointer(object);
 141                 if (forwarding_pointer_p(ptr)) {
 142                     /* Yes, there's a forwarding pointer. */
 143                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 144                     n_words_scavenged = 1;
 145                 } else {
 146                     /* Scavenge that pointer. */
 147                     n_words_scavenged =
 148                         (scavtab[widetag_of(object)])(object_ptr, object);
 149                 }
 150             } else {
 151                 /* It points somewhere other than oldspace. Leave it
 152                  * alone. */
 153                 n_words_scavenged = 1;
 154             }
 155         }
 156 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
 157         /* This workaround is probably not needed for those ports
 158            which don't have a partitioned register set (and therefore
 159            scan the stack conservatively for roots). */
 160         else if (n_words == 1) {
 161             /* there are some situations where an other-immediate may
 162                end up in a descriptor register.  I'm not sure whether
 163                this is supposed to happen, but if it does then we
 164                don't want to (a) barf or (b) scavenge over the
 165                data-block, because there isn't one.  So, if we're
 166                checking a single word and it's anything other than a
 167                pointer, just hush it up */
 168             int widetag = widetag_of(object);
 169             n_words_scavenged = 1;
 170
 171             if ((scavtab[widetag] == scav_lose) ||
 172                 (((sizetab[widetag])(object_ptr)) > 1)) {
 173                 fprintf(stderr,"warning: \
 174 attempted to scavenge non-descriptor value %x at %p.\n\n\
 175 If you can reproduce this warning, please send a bug report\n\
 176 (see manual page for details).\n",
 177                         object, object_ptr);
 178             }
 179         }
 180 #endif
 181         else if (fixnump(object)) {
 182             /* It's a fixnum: really easy.. */
 183             n_words_scavenged = 1;
 184         } else {
 185             /* It's some sort of header object or another. */
 186             n_words_scavenged =
 187                 (scavtab[widetag_of(object)])(object_ptr, object);
 188         }
 189     }
 190     gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n",
 191                       object_ptr, start, end);
 192 }
 193
 194 static lispobj trans_fun_header(lispobj object); /* forward decls */
 195 static lispobj trans_boxed(lispobj object);
 196
 197 static sword_t
 198 scav_fun_pointer(lispobj *where, lispobj object)
 199 {
 200     lispobj *first_pointer;
 201     lispobj copy;
 202
 203     gc_assert(is_lisp_pointer(object));
 204
 205     /* Object is a pointer into from_space - not a FP. */
 206     first_pointer = (lispobj *) native_pointer(object);
 207
 208     /* must transport object -- object may point to either a function
 209      * header, a closure function header, or to a closure header. */
 210
 211     switch (widetag_of(*first_pointer)) {
 212     case SIMPLE_FUN_HEADER_WIDETAG:
 213         copy = trans_fun_header(object);
 214         break;
 215     default:
 216         copy = trans_boxed(object);
 217         break;
 218     }
 219
 220     if (copy != object) {
 221         /* Set forwarding pointer */
 222         set_forwarding_pointer(first_pointer,copy);
 223     }
 224
 225     gc_assert(is_lisp_pointer(copy));
 226     gc_assert(!from_space_p(copy));
 227
 228     *where = copy;
 229
 230     return 1;
 231 }
 232
 233
 234 static struct code *
 235 trans_code(struct code *code)
 236 {
 237     struct code *new_code;
 238     lispobj first, l_code, l_new_code;
 239     uword_t nheader_words, ncode_words, nwords;
 240     uword_t displacement;
 241     lispobj fheaderl, *prev_pointer;
 242
 243     /* if object has already been transported, just return pointer */
 244     first = code->header;
 245     if (forwarding_pointer_p((lispobj *)code)) {
 246 #ifdef DEBUG_CODE_GC
 247         printf("Was already transported\n");
 248 #endif
 249         return (struct code *) forwarding_pointer_value
 250             ((lispobj *)((pointer_sized_uint_t) code));
 251     }
 252
 253     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 254
 255     /* prepare to transport the code vector */
 256     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 257
 258     ncode_words = fixnum_value(code->code_size);
 259     nheader_words = HeaderValue(code->header);
 260     nwords = ncode_words + nheader_words;
 261     nwords = CEILING(nwords, 2);
 262
 263     l_new_code = copy_code_object(l_code, nwords);
 264     new_code = (struct code *) native_pointer(l_new_code);
 265
 266 #if defined(DEBUG_CODE_GC)
 267     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 268            (uword_t) code, (uword_t) new_code);
 269     printf("Code object is %d words long.\n", nwords);
 270 #endif
 271
 272 #ifdef LISP_FEATURE_GENCGC
 273     if (new_code == code)
 274         return new_code;
 275 #endif
 276
 277     displacement = l_new_code - l_code;
 278
 279     set_forwarding_pointer((lispobj *)code, l_new_code);
 280
 281     /* set forwarding pointers for all the function headers in the */
 282     /* code object.  also fix all self pointers */
 283
 284     fheaderl = code->entry_points;
 285     prev_pointer = &new_code->entry_points;
 286
 287     while (fheaderl != NIL) {
 288         struct simple_fun *fheaderp, *nfheaderp;
 289         lispobj nfheaderl;
 290
 291         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 292         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 293
 294         /* Calculate the new function pointer and the new */
 295         /* function header. */
 296         nfheaderl = fheaderl + displacement;
 297         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 298
 299 #ifdef DEBUG_CODE_GC
 300         printf("fheaderp->header (at %x) <- %x\n",
 301                &(fheaderp->header) , nfheaderl);
 302 #endif
 303         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 304
 305         /* fix self pointer. */
 306         nfheaderp->self =
 307 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 308             FUN_RAW_ADDR_OFFSET +
 309 #endif
 310             nfheaderl;
 311
 312         *prev_pointer = nfheaderl;
 313
 314         fheaderl = fheaderp->next;
 315         prev_pointer = &nfheaderp->next;
 316     }
 317 #ifdef LISP_FEATURE_GENCGC
 318     /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
 319        spaces once when all copying is done. */
 320     os_flush_icache((os_vm_address_t) (((sword_t *)new_code) + nheader_words),
 321                     ncode_words * sizeof(sword_t));
 322
 323 #endif
 324
 325 #ifdef LISP_FEATURE_X86
 326     gencgc_apply_code_fixups(code, new_code);
 327 #endif
 328
 329     return new_code;
 330 }
 331
 332 static sword_t
 333 scav_code_header(lispobj *where, lispobj object)
 334 {
 335     struct code *code;
 336     sword_t n_header_words, n_code_words, n_words;
 337     lispobj entry_point;        /* tagged pointer to entry point */
 338     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 339
 340     code = (struct code *) where;
 341     n_code_words = fixnum_value(code->code_size);
 342     n_header_words = HeaderValue(object);
 343     n_words = n_code_words + n_header_words;
 344     n_words = CEILING(n_words, 2);
 345
 346     /* Scavenge the boxed section of the code data block. */
 347     scavenge(where + 1, n_header_words - 1);
 348
 349     /* Scavenge the boxed section of each function object in the
 350      * code data block. */
 351     for (entry_point = code->entry_points;
 352          entry_point != NIL;
 353          entry_point = function_ptr->next) {
 354
 355         gc_assert_verbose(is_lisp_pointer(entry_point),
 356                           "Entry point %lx\n is not a lisp pointer.",
 357                           (sword_t)entry_point);
 358
 359         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 360         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 361
 362         scavenge(&function_ptr->name, 1);
 363         scavenge(&function_ptr->arglist, 1);
 364         scavenge(&function_ptr->type, 1);
 365         scavenge(&function_ptr->info, 1);
 366     }
 367
 368     return n_words;
 369 }
 370
 371 static lispobj
 372 trans_code_header(lispobj object)
 373 {
 374     struct code *ncode;
 375
 376     ncode = trans_code((struct code *) native_pointer(object));
 377     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 378 }
 379
 380
 381 static sword_t
 382 size_code_header(lispobj *where)
 383 {
 384     struct code *code;
 385     sword_t nheader_words, ncode_words, nwords;
 386
 387     code = (struct code *) where;
 388
 389     ncode_words = fixnum_value(code->code_size);
 390     nheader_words = HeaderValue(code->header);
 391     nwords = ncode_words + nheader_words;
 392     nwords = CEILING(nwords, 2);
 393
 394     return nwords;
 395 }
 396
 397 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 398 static sword_t
 399 scav_return_pc_header(lispobj *where, lispobj object)
 400 {
 401     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
 402          (uword_t) where,
 403          (uword_t) object);
 404     return 0; /* bogus return value to satisfy static type checking */
 405 }
 406 #endif /* LISP_FEATURE_X86 */
 407
 408 static lispobj
 409 trans_return_pc_header(lispobj object)
 410 {
 411     struct simple_fun *return_pc;
 412     uword_t offset;
 413     struct code *code, *ncode;
 414
 415     return_pc = (struct simple_fun *) native_pointer(object);
 416     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 417     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 418
 419     /* Transport the whole code object */
 420     code = (struct code *) ((uword_t) return_pc - offset);
 421     ncode = trans_code(code);
 422
 423     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 424 }
 425
 426 /* On the 386, closures hold a pointer to the raw address instead of the
 427  * function object, so we can use CALL [$FDEFN+const] to invoke
 428  * the function without loading it into a register. Given that code
 429  * objects don't move, we don't need to update anything, but we do
 430  * have to figure out that the function is still live. */
 431
 432 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 433 static sword_t
 434 scav_closure_header(lispobj *where, lispobj object)
 435 {
 436     struct closure *closure;
 437     lispobj fun;
 438
 439     closure = (struct closure *)where;
 440     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 441     scavenge(&fun, 1);
 442 #ifdef LISP_FEATURE_GENCGC
 443     /* The function may have moved so update the raw address. But
 444      * don't write unnecessarily. */
 445     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 446         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 447 #endif
 448     return 2;
 449 }
 450 #endif
 451
 452 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 453 static sword_t
 454 scav_fun_header(lispobj *where, lispobj object)
 455 {
 456     lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
 457          (uword_t) where,
 458          (uword_t) object);
 459     return 0; /* bogus return value to satisfy static type checking */
 460 }
 461 #endif /* LISP_FEATURE_X86 */
 462
 463 static lispobj
 464 trans_fun_header(lispobj object)
 465 {
 466     struct simple_fun *fheader;
 467     uword_t offset;
 468     struct code *code, *ncode;
 469
 470     fheader = (struct simple_fun *) native_pointer(object);
 471     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 472     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 473
 474     /* Transport the whole code object */
 475     code = (struct code *) ((uword_t) fheader - offset);
 476     ncode = trans_code(code);
 477
 478     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 479 }
 480
 481 \f
 482 /*
 483  * instances
 484  */
 485
 486 static sword_t
 487 scav_instance_pointer(lispobj *where, lispobj object)
 488 {
 489     lispobj copy, *first_pointer;
 490
 491     /* Object is a pointer into from space - not a FP. */
 492     copy = trans_boxed(object);
 493
 494 #ifdef LISP_FEATURE_GENCGC
 495     gc_assert(copy != object);
 496 #endif
 497
 498     first_pointer = (lispobj *) native_pointer(object);
 499     set_forwarding_pointer(first_pointer,copy);
 500     *where = copy;
 501
 502     return 1;
 503 }
 504
 505 \f
 506 /*
 507  * lists and conses
 508  */
 509
 510 static lispobj trans_list(lispobj object);
 511
 512 static sword_t
 513 scav_list_pointer(lispobj *where, lispobj object)
 514 {
 515     lispobj first, *first_pointer;
 516
 517     gc_assert(is_lisp_pointer(object));
 518
 519     /* Object is a pointer into from space - not FP. */
 520     first_pointer = (lispobj *) native_pointer(object);
 521
 522     first = trans_list(object);
 523     gc_assert(first != object);
 524
 525     /* Set forwarding pointer */
 526     set_forwarding_pointer(first_pointer, first);
 527
 528     gc_assert(is_lisp_pointer(first));
 529     gc_assert(!from_space_p(first));
 530
 531     *where = first;
 532     return 1;
 533 }
 534
 535
 536 static lispobj
 537 trans_list(lispobj object)
 538 {
 539     lispobj new_list_pointer;
 540     struct cons *cons, *new_cons;
 541     lispobj cdr;
 542
 543     cons = (struct cons *) native_pointer(object);
 544
 545     /* Copy 'object'. */
 546     new_cons = (struct cons *)
 547         gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
 548     new_cons->car = cons->car;
 549     new_cons->cdr = cons->cdr; /* updated later */
 550     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 551
 552     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 553     cdr = cons->cdr;
 554
 555     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 556
 557     /* Try to linearize the list in the cdr direction to help reduce
 558      * paging. */
 559     while (1) {
 560         lispobj  new_cdr;
 561         struct cons *cdr_cons, *new_cdr_cons;
 562
 563         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 564            !from_space_p(cdr) ||
 565            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 566             break;
 567
 568         cdr_cons = (struct cons *) native_pointer(cdr);
 569
 570         /* Copy 'cdr'. */
 571         new_cdr_cons = (struct cons*)
 572             gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
 573         new_cdr_cons->car = cdr_cons->car;
 574         new_cdr_cons->cdr = cdr_cons->cdr;
 575         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 576
 577         /* Grab the cdr before it is clobbered. */
 578         cdr = cdr_cons->cdr;
 579         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 580
 581         /* Update the cdr of the last cons copied into new space to
 582          * keep the newspace scavenge from having to do it. */
 583         new_cons->cdr = new_cdr;
 584
 585         new_cons = new_cdr_cons;
 586     }
 587
 588     return new_list_pointer;
 589 }
 590
 591 \f
 592 /*
 593  * scavenging and transporting other pointers
 594  */
 595
 596 static sword_t
 597 scav_other_pointer(lispobj *where, lispobj object)
 598 {
 599     lispobj first, *first_pointer;
 600
 601     gc_assert(is_lisp_pointer(object));
 602
 603     /* Object is a pointer into from space - not FP. */
 604     first_pointer = (lispobj *) native_pointer(object);
 605     first = (transother[widetag_of(*first_pointer)])(object);
 606
 607     if (first != object) {
 608         set_forwarding_pointer(first_pointer, first);
 609 #ifdef LISP_FEATURE_GENCGC
 610         *where = first;
 611 #endif
 612     }
 613 #ifndef LISP_FEATURE_GENCGC
 614     *where = first;
 615 #endif
 616     gc_assert(is_lisp_pointer(first));
 617     gc_assert(!from_space_p(first));
 618
 619     return 1;
 620 }
 621 \f
 622 /*
 623  * immediate, boxed, and unboxed objects
 624  */
 625
 626 static sword_t
 627 size_pointer(lispobj *where)
 628 {
 629     return 1;
 630 }
 631
 632 static sword_t
 633 scav_immediate(lispobj *where, lispobj object)
 634 {
 635     return 1;
 636 }
 637
 638 static lispobj
 639 trans_immediate(lispobj object)
 640 {
 641     lose("trying to transport an immediate\n");
 642     return NIL; /* bogus return value to satisfy static type checking */
 643 }
 644
 645 static sword_t
 646 size_immediate(lispobj *where)
 647 {
 648     return 1;
 649 }
 650
 651
 652 static sword_t
 653 scav_boxed(lispobj *where, lispobj object)
 654 {
 655     return 1;
 656 }
 657
 658 static sword_t
 659 scav_instance(lispobj *where, lispobj object)
 660 {
 661     lispobj nuntagged;
 662     sword_t ntotal = HeaderValue(object);
 663     lispobj layout = ((struct instance *)where)->slots[0];
 664
 665     if (!layout)
 666         return 1;
 667     if (forwarding_pointer_p(native_pointer(layout)))
 668         layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
 669
 670     nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
 671     scavenge(where + 1, ntotal - fixnum_value(nuntagged));
 672
 673     return ntotal + 1;
 674 }
 675
 676 static lispobj
 677 trans_boxed(lispobj object)
 678 {
 679     lispobj header;
 680     uword_t length;
 681
 682     gc_assert(is_lisp_pointer(object));
 683
 684     header = *((lispobj *) native_pointer(object));
 685     length = HeaderValue(header) + 1;
 686     length = CEILING(length, 2);
 687
 688     return copy_object(object, length);
 689 }
 690
 691
 692 static sword_t
 693 size_boxed(lispobj *where)
 694 {
 695     lispobj header;
 696     uword_t length;
 697
 698     header = *where;
 699     length = HeaderValue(header) + 1;
 700     length = CEILING(length, 2);
 701
 702     return length;
 703 }
 704
 705 /* Note: on the sparc we don't have to do anything special for fdefns, */
 706 /* 'cause the raw-addr has a function lowtag. */
 707 #if !defined(LISP_FEATURE_SPARC)
 708 static sword_t
 709 scav_fdefn(lispobj *where, lispobj object)
 710 {
 711     struct fdefn *fdefn;
 712
 713     fdefn = (struct fdefn *)where;
 714
 715     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 716        fdefn->fun, fdefn->raw_addr)); */
 717
 718     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
 719         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 720
 721         /* Don't write unnecessarily. */
 722         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 723             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 724         /* gc.c has more casts here, which may be relevant or alternatively
 725            may be compiler warning defeaters.  try
 726         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 727         */
 728         return sizeof(struct fdefn) / sizeof(lispobj);
 729     } else {
 730         return 1;
 731     }
 732 }
 733 #endif
 734
 735 static sword_t
 736 scav_unboxed(lispobj *where, lispobj object)
 737 {
 738     uword_t length;
 739
 740     length = HeaderValue(object) + 1;
 741     length = CEILING(length, 2);
 742
 743     return length;
 744 }
 745
 746 static lispobj
 747 trans_unboxed(lispobj object)
 748 {
 749     lispobj header;
 750     uword_t length;
 751
 752
 753     gc_assert(is_lisp_pointer(object));
 754
 755     header = *((lispobj *) native_pointer(object));
 756     length = HeaderValue(header) + 1;
 757     length = CEILING(length, 2);
 758
 759     return copy_unboxed_object(object, length);
 760 }
 761
 762 static sword_t
 763 size_unboxed(lispobj *where)
 764 {
 765     lispobj header;
 766     uword_t length;
 767
 768     header = *where;
 769     length = HeaderValue(header) + 1;
 770     length = CEILING(length, 2);
 771
 772     return length;
 773 }
 774
 775 \f
 776 /* vector-like objects */
 777 static sword_t
 778 scav_base_string(lispobj *where, lispobj object)
 779 {
 780     struct vector *vector;
 781     sword_t length, nwords;
 782
 783     /* NOTE: Strings contain one more byte of data than the length */
 784     /* slot indicates. */
 785
 786     vector = (struct vector *) where;
 787     length = fixnum_value(vector->length) + 1;
 788     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 789
 790     return nwords;
 791 }
 792 static lispobj
 793 trans_base_string(lispobj object)
 794 {
 795     struct vector *vector;
 796     sword_t length, nwords;
 797
 798     gc_assert(is_lisp_pointer(object));
 799
 800     /* NOTE: A string contains one more byte of data (a terminating
 801      * '\0' to help when interfacing with C functions) than indicated
 802      * by the length slot. */
 803
 804     vector = (struct vector *) native_pointer(object);
 805     length = fixnum_value(vector->length) + 1;
 806     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 807
 808     return copy_large_unboxed_object(object, nwords);
 809 }
 810
 811 static sword_t
 812 size_base_string(lispobj *where)
 813 {
 814     struct vector *vector;
 815     sword_t length, nwords;
 816
 817     /* NOTE: A string contains one more byte of data (a terminating
 818      * '\0' to help when interfacing with C functions) than indicated
 819      * by the length slot. */
 820
 821     vector = (struct vector *) where;
 822     length = fixnum_value(vector->length) + 1;
 823     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 824
 825     return nwords;
 826 }
 827
 828 static sword_t
 829 scav_character_string(lispobj *where, lispobj object)
 830 {
 831     struct vector *vector;
 832     int length, nwords;
 833
 834     /* NOTE: Strings contain one more byte of data than the length */
 835     /* slot indicates. */
 836
 837     vector = (struct vector *) where;
 838     length = fixnum_value(vector->length) + 1;
 839     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 840
 841     return nwords;
 842 }
 843 static lispobj
 844 trans_character_string(lispobj object)
 845 {
 846     struct vector *vector;
 847     int length, nwords;
 848
 849     gc_assert(is_lisp_pointer(object));
 850
 851     /* NOTE: A string contains one more byte of data (a terminating
 852      * '\0' to help when interfacing with C functions) than indicated
 853      * by the length slot. */
 854
 855     vector = (struct vector *) native_pointer(object);
 856     length = fixnum_value(vector->length) + 1;
 857     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 858
 859     return copy_large_unboxed_object(object, nwords);
 860 }
 861
 862 static sword_t
 863 size_character_string(lispobj *where)
 864 {
 865     struct vector *vector;
 866     int length, nwords;
 867
 868     /* NOTE: A string contains one more byte of data (a terminating
 869      * '\0' to help when interfacing with C functions) than indicated
 870      * by the length slot. */
 871
 872     vector = (struct vector *) where;
 873     length = fixnum_value(vector->length) + 1;
 874     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 875
 876     return nwords;
 877 }
 878
 879 static lispobj
 880 trans_vector(lispobj object)
 881 {
 882     struct vector *vector;
 883     sword_t length, nwords;
 884
 885     gc_assert(is_lisp_pointer(object));
 886
 887     vector = (struct vector *) native_pointer(object);
 888
 889     length = fixnum_value(vector->length);
 890     nwords = CEILING(length + 2, 2);
 891
 892     return copy_large_object(object, nwords);
 893 }
 894
 895 static sword_t
 896 size_vector(lispobj *where)
 897 {
 898     struct vector *vector;
 899     sword_t length, nwords;
 900
 901     vector = (struct vector *) where;
 902     length = fixnum_value(vector->length);
 903     nwords = CEILING(length + 2, 2);
 904
 905     return nwords;
 906 }
 907
 908 static sword_t
 909 scav_vector_nil(lispobj *where, lispobj object)
 910 {
 911     return 2;
 912 }
 913
 914 static lispobj
 915 trans_vector_nil(lispobj object)
 916 {
 917     gc_assert(is_lisp_pointer(object));
 918     return copy_unboxed_object(object, 2);
 919 }
 920
 921 static sword_t
 922 size_vector_nil(lispobj *where)
 923 {
 924     /* Just the header word and the length word */
 925     return 2;
 926 }
 927
 928 static sword_t
 929 scav_vector_bit(lispobj *where, lispobj object)
 930 {
 931     struct vector *vector;
 932     sword_t length, nwords;
 933
 934     vector = (struct vector *) where;
 935     length = fixnum_value(vector->length);
 936     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 937
 938     return nwords;
 939 }
 940
 941 static lispobj
 942 trans_vector_bit(lispobj object)
 943 {
 944     struct vector *vector;
 945     sword_t length, nwords;
 946
 947     gc_assert(is_lisp_pointer(object));
 948
 949     vector = (struct vector *) native_pointer(object);
 950     length = fixnum_value(vector->length);
 951     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 952
 953     return copy_large_unboxed_object(object, nwords);
 954 }
 955
 956 static sword_t
 957 size_vector_bit(lispobj *where)
 958 {
 959     struct vector *vector;
 960     sword_t length, nwords;
 961
 962     vector = (struct vector *) where;
 963     length = fixnum_value(vector->length);
 964     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 965
 966     return nwords;
 967 }
 968
 969 static sword_t
 970 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 971 {
 972     struct vector *vector;
 973     sword_t length, nwords;
 974
 975     vector = (struct vector *) where;
 976     length = fixnum_value(vector->length);
 977     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 978
 979     return nwords;
 980 }
 981
 982 static lispobj
 983 trans_vector_unsigned_byte_2(lispobj object)
 984 {
 985     struct vector *vector;
 986     sword_t length, nwords;
 987
 988     gc_assert(is_lisp_pointer(object));
 989
 990     vector = (struct vector *) native_pointer(object);
 991     length = fixnum_value(vector->length);
 992     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 993
 994     return copy_large_unboxed_object(object, nwords);
 995 }
 996
 997 static sword_t
 998 size_vector_unsigned_byte_2(lispobj *where)
 999 {
1000     struct vector *vector;
1001     sword_t length, nwords;
1002
1003     vector = (struct vector *) where;
1004     length = fixnum_value(vector->length);
1005     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1006
1007     return nwords;
1008 }
1009
1010 static sword_t
1011 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1012 {
1013     struct vector *vector;
1014     sword_t length, nwords;
1015
1016     vector = (struct vector *) where;
1017     length = fixnum_value(vector->length);
1018     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1019
1020     return nwords;
1021 }
1022
1023 static lispobj
1024 trans_vector_unsigned_byte_4(lispobj object)
1025 {
1026     struct vector *vector;
1027     sword_t length, nwords;
1028
1029     gc_assert(is_lisp_pointer(object));
1030
1031     vector = (struct vector *) native_pointer(object);
1032     length = fixnum_value(vector->length);
1033     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1034
1035     return copy_large_unboxed_object(object, nwords);
1036 }
1037 static sword_t
1038 size_vector_unsigned_byte_4(lispobj *where)
1039 {
1040     struct vector *vector;
1041     sword_t length, nwords;
1042
1043     vector = (struct vector *) where;
1044     length = fixnum_value(vector->length);
1045     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1046
1047     return nwords;
1048 }
1049
1050
1051 static sword_t
1052 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1053 {
1054     struct vector *vector;
1055     sword_t length, nwords;
1056
1057     vector = (struct vector *) where;
1058     length = fixnum_value(vector->length);
1059     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1060
1061     return nwords;
1062 }
1063
1064 /*********************/
1065
1066
1067
1068 static lispobj
1069 trans_vector_unsigned_byte_8(lispobj object)
1070 {
1071     struct vector *vector;
1072     sword_t length, nwords;
1073
1074     gc_assert(is_lisp_pointer(object));
1075
1076     vector = (struct vector *) native_pointer(object);
1077     length = fixnum_value(vector->length);
1078     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1079
1080     return copy_large_unboxed_object(object, nwords);
1081 }
1082
1083 static sword_t
1084 size_vector_unsigned_byte_8(lispobj *where)
1085 {
1086     struct vector *vector;
1087     sword_t length, nwords;
1088
1089     vector = (struct vector *) where;
1090     length = fixnum_value(vector->length);
1091     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1092
1093     return nwords;
1094 }
1095
1096
1097 static sword_t
1098 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1099 {
1100     struct vector *vector;
1101     sword_t length, nwords;
1102
1103     vector = (struct vector *) where;
1104     length = fixnum_value(vector->length);
1105     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1106
1107     return nwords;
1108 }
1109
1110 static lispobj
1111 trans_vector_unsigned_byte_16(lispobj object)
1112 {
1113     struct vector *vector;
1114     sword_t length, nwords;
1115
1116     gc_assert(is_lisp_pointer(object));
1117
1118     vector = (struct vector *) native_pointer(object);
1119     length = fixnum_value(vector->length);
1120     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1121
1122     return copy_large_unboxed_object(object, nwords);
1123 }
1124
1125 static sword_t
1126 size_vector_unsigned_byte_16(lispobj *where)
1127 {
1128     struct vector *vector;
1129     sword_t length, nwords;
1130
1131     vector = (struct vector *) where;
1132     length = fixnum_value(vector->length);
1133     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1134
1135     return nwords;
1136 }
1137
1138 static sword_t
1139 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1140 {
1141     struct vector *vector;
1142     sword_t length, nwords;
1143
1144     vector = (struct vector *) where;
1145     length = fixnum_value(vector->length);
1146     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1147
1148     return nwords;
1149 }
1150
1151 static lispobj
1152 trans_vector_unsigned_byte_32(lispobj object)
1153 {
1154     struct vector *vector;
1155     sword_t length, nwords;
1156
1157     gc_assert(is_lisp_pointer(object));
1158
1159     vector = (struct vector *) native_pointer(object);
1160     length = fixnum_value(vector->length);
1161     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1162
1163     return copy_large_unboxed_object(object, nwords);
1164 }
1165
1166 static sword_t
1167 size_vector_unsigned_byte_32(lispobj *where)
1168 {
1169     struct vector *vector;
1170     sword_t length, nwords;
1171
1172     vector = (struct vector *) where;
1173     length = fixnum_value(vector->length);
1174     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1175
1176     return nwords;
1177 }
1178
1179 #if N_WORD_BITS == 64
1180 static sword_t
1181 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1182 {
1183     struct vector *vector;
1184     sword_t length, nwords;
1185
1186     vector = (struct vector *) where;
1187     length = fixnum_value(vector->length);
1188     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1189
1190     return nwords;
1191 }
1192
1193 static lispobj
1194 trans_vector_unsigned_byte_64(lispobj object)
1195 {
1196     struct vector *vector;
1197     sword_t length, nwords;
1198
1199     gc_assert(is_lisp_pointer(object));
1200
1201     vector = (struct vector *) native_pointer(object);
1202     length = fixnum_value(vector->length);
1203     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1204
1205     return copy_large_unboxed_object(object, nwords);
1206 }
1207
1208 static sword_t
1209 size_vector_unsigned_byte_64(lispobj *where)
1210 {
1211     struct vector *vector;
1212     sword_t length, nwords;
1213
1214     vector = (struct vector *) where;
1215     length = fixnum_value(vector->length);
1216     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1217
1218     return nwords;
1219 }
1220 #endif
1221
1222 static sword_t
1223 scav_vector_single_float(lispobj *where, lispobj object)
1224 {
1225     struct vector *vector;
1226     sword_t length, nwords;
1227
1228     vector = (struct vector *) where;
1229     length = fixnum_value(vector->length);
1230     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1231
1232     return nwords;
1233 }
1234
1235 static lispobj
1236 trans_vector_single_float(lispobj object)
1237 {
1238     struct vector *vector;
1239     sword_t length, nwords;
1240
1241     gc_assert(is_lisp_pointer(object));
1242
1243     vector = (struct vector *) native_pointer(object);
1244     length = fixnum_value(vector->length);
1245     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1246
1247     return copy_large_unboxed_object(object, nwords);
1248 }
1249
1250 static sword_t
1251 size_vector_single_float(lispobj *where)
1252 {
1253     struct vector *vector;
1254     sword_t length, nwords;
1255
1256     vector = (struct vector *) where;
1257     length = fixnum_value(vector->length);
1258     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1259
1260     return nwords;
1261 }
1262
1263 static sword_t
1264 scav_vector_double_float(lispobj *where, lispobj object)
1265 {
1266     struct vector *vector;
1267     sword_t length, nwords;
1268
1269     vector = (struct vector *) where;
1270     length = fixnum_value(vector->length);
1271     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1272
1273     return nwords;
1274 }
1275
1276 static lispobj
1277 trans_vector_double_float(lispobj object)
1278 {
1279     struct vector *vector;
1280     sword_t length, nwords;
1281
1282     gc_assert(is_lisp_pointer(object));
1283
1284     vector = (struct vector *) native_pointer(object);
1285     length = fixnum_value(vector->length);
1286     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1287
1288     return copy_large_unboxed_object(object, nwords);
1289 }
1290
1291 static sword_t
1292 size_vector_double_float(lispobj *where)
1293 {
1294     struct vector *vector;
1295     sword_t length, nwords;
1296
1297     vector = (struct vector *) where;
1298     length = fixnum_value(vector->length);
1299     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1300
1301     return nwords;
1302 }
1303
1304 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1305 static long
1306 scav_vector_long_float(lispobj *where, lispobj object)
1307 {
1308     struct vector *vector;
1309     long length, nwords;
1310
1311     vector = (struct vector *) where;
1312     length = fixnum_value(vector->length);
1313     nwords = CEILING(length *
1314                      LONG_FLOAT_SIZE
1315                      + 2, 2);
1316     return nwords;
1317 }
1318
1319 static lispobj
1320 trans_vector_long_float(lispobj object)
1321 {
1322     struct vector *vector;
1323     long length, nwords;
1324
1325     gc_assert(is_lisp_pointer(object));
1326
1327     vector = (struct vector *) native_pointer(object);
1328     length = fixnum_value(vector->length);
1329     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1330
1331     return copy_large_unboxed_object(object, nwords);
1332 }
1333
1334 static long
1335 size_vector_long_float(lispobj *where)
1336 {
1337     struct vector *vector;
1338     sword_t length, nwords;
1339
1340     vector = (struct vector *) where;
1341     length = fixnum_value(vector->length);
1342     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1343
1344     return nwords;
1345 }
1346 #endif
1347
1348
1349 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1350 static sword_t
1351 scav_vector_complex_single_float(lispobj *where, lispobj object)
1352 {
1353     struct vector *vector;
1354     sword_t length, nwords;
1355
1356     vector = (struct vector *) where;
1357     length = fixnum_value(vector->length);
1358     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1359
1360     return nwords;
1361 }
1362
1363 static lispobj
1364 trans_vector_complex_single_float(lispobj object)
1365 {
1366     struct vector *vector;
1367     sword_t length, nwords;
1368
1369     gc_assert(is_lisp_pointer(object));
1370
1371     vector = (struct vector *) native_pointer(object);
1372     length = fixnum_value(vector->length);
1373     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1374
1375     return copy_large_unboxed_object(object, nwords);
1376 }
1377
1378 static sword_t
1379 size_vector_complex_single_float(lispobj *where)
1380 {
1381     struct vector *vector;
1382     sword_t length, nwords;
1383
1384     vector = (struct vector *) where;
1385     length = fixnum_value(vector->length);
1386     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1387
1388     return nwords;
1389 }
1390 #endif
1391
1392 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1393 static sword_t
1394 scav_vector_complex_double_float(lispobj *where, lispobj object)
1395 {
1396     struct vector *vector;
1397     sword_t length, nwords;
1398
1399     vector = (struct vector *) where;
1400     length = fixnum_value(vector->length);
1401     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1402
1403     return nwords;
1404 }
1405
1406 static lispobj
1407 trans_vector_complex_double_float(lispobj object)
1408 {
1409     struct vector *vector;
1410     sword_t length, nwords;
1411
1412     gc_assert(is_lisp_pointer(object));
1413
1414     vector = (struct vector *) native_pointer(object);
1415     length = fixnum_value(vector->length);
1416     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1417
1418     return copy_large_unboxed_object(object, nwords);
1419 }
1420
1421 static sword_t
1422 size_vector_complex_double_float(lispobj *where)
1423 {
1424     struct vector *vector;
1425     sword_t length, nwords;
1426
1427     vector = (struct vector *) where;
1428     length = fixnum_value(vector->length);
1429     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1430
1431     return nwords;
1432 }
1433 #endif
1434
1435
1436 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1437 static long
1438 scav_vector_complex_long_float(lispobj *where, lispobj object)
1439 {
1440     struct vector *vector;
1441     sword_t length, nwords;
1442
1443     vector = (struct vector *) where;
1444     length = fixnum_value(vector->length);
1445     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1446
1447     return nwords;
1448 }
1449
1450 static lispobj
1451 trans_vector_complex_long_float(lispobj object)
1452 {
1453     struct vector *vector;
1454     long length, nwords;
1455
1456     gc_assert(is_lisp_pointer(object));
1457
1458     vector = (struct vector *) native_pointer(object);
1459     length = fixnum_value(vector->length);
1460     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1461
1462     return copy_large_unboxed_object(object, nwords);
1463 }
1464
1465 static long
1466 size_vector_complex_long_float(lispobj *where)
1467 {
1468     struct vector *vector;
1469     long length, nwords;
1470
1471     vector = (struct vector *) where;
1472     length = fixnum_value(vector->length);
1473     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1474
1475     return nwords;
1476 }
1477 #endif
1478
1479 #define WEAK_POINTER_NWORDS \
1480         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1481
1482 static lispobj
1483 trans_weak_pointer(lispobj object)
1484 {
1485     lispobj copy;
1486 #ifndef LISP_FEATURE_GENCGC
1487     struct weak_pointer *wp;
1488 #endif
1489     gc_assert(is_lisp_pointer(object));
1490
1491 #if defined(DEBUG_WEAK)
1492     printf("Transporting weak pointer from 0x%08x\n", object);
1493 #endif
1494
1495     /* Need to remember where all the weak pointers are that have */
1496     /* been transported so they can be fixed up in a post-GC pass. */
1497
1498     copy = copy_object(object, WEAK_POINTER_NWORDS);
1499 #ifndef LISP_FEATURE_GENCGC
1500     wp = (struct weak_pointer *) native_pointer(copy);
1501
1502     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1503     /* Push the weak pointer onto the list of weak pointers. */
1504     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1505     weak_pointers = wp;
1506 #endif
1507     return copy;
1508 }
1509
1510 static sword_t
1511 size_weak_pointer(lispobj *where)
1512 {
1513     return WEAK_POINTER_NWORDS;
1514 }
1515
1516
1517 void scan_weak_pointers(void)
1518 {
1519     struct weak_pointer *wp, *next_wp;
1520     for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
1521         lispobj value = wp->value;
1522         lispobj *first_pointer;
1523         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1524
1525         next_wp = wp->next;
1526         wp->next = NULL;
1527         if (next_wp == wp) /* gencgc uses a ref to self for end of list */
1528             next_wp = NULL;
1529
1530         if (!(is_lisp_pointer(value) && from_space_p(value)))
1531             continue;
1532
1533         /* Now, we need to check whether the object has been forwarded. If
1534          * it has been, the weak pointer is still good and needs to be
1535          * updated. Otherwise, the weak pointer needs to be nil'ed
1536          * out. */
1537
1538         first_pointer = (lispobj *)native_pointer(value);
1539
1540         if (forwarding_pointer_p(first_pointer)) {
1541             wp->value=
1542                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1543         } else {
1544             /* Break it. */
1545             wp->value = NIL;
1546             wp->broken = T;
1547         }
1548     }
1549 }
1550
1551 \f
1552 /* Hash tables */
1553
1554 #if N_WORD_BITS == 32
1555 #define EQ_HASH_MASK 0x1fffffff
1556 #elif N_WORD_BITS == 64
1557 #define EQ_HASH_MASK 0x1fffffffffffffff
1558 #endif
1559
1560 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1561  * target-hash-table.lisp.  */
1562 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1563
1564 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1565  * slot. Set to NULL at the end of a collection.
1566  *
1567  * This is not optimal because, when a table is tenured, it won't be
1568  * processed automatically; only the yougest generation is GC'd by
1569  * default. On the other hand, all applications will need an
1570  * occasional full GC anyway, so it's not that bad either.  */
1571 struct hash_table *weak_hash_tables = NULL;
1572
1573 /* Return true if OBJ has already survived the current GC. */
1574 static inline int
1575 survived_gc_yet (lispobj obj)
1576 {
1577     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1578             forwarding_pointer_p(native_pointer(obj)));
1579 }
1580
1581 static inline int
1582 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1583 {
1584     switch (weakness) {
1585     case KEY:
1586         return survived_gc_yet(key);
1587     case VALUE:
1588         return survived_gc_yet(value);
1589     case KEY_OR_VALUE:
1590         return (survived_gc_yet(key) || survived_gc_yet(value));
1591     case KEY_AND_VALUE:
1592         return (survived_gc_yet(key) && survived_gc_yet(value));
1593     default:
1594         gc_assert(0);
1595         /* Shut compiler up. */
1596         return 0;
1597     }
1598 }
1599
1600 /* Return the beginning of data in ARRAY (skipping the header and the
1601  * length) or NULL if it isn't an array of the specified widetag after
1602  * all. */
1603 static inline lispobj *
1604 get_array_data (lispobj array, int widetag, uword_t *length)
1605 {
1606     if (is_lisp_pointer(array) &&
1607         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1608         if (length != NULL)
1609             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1610         return ((lispobj *)native_pointer(array)) + 2;
1611     } else {
1612         return NULL;
1613     }
1614 }
1615
1616 /* Only need to worry about scavenging the _real_ entries in the
1617  * table. Phantom entries such as the hash table itself at index 0 and
1618  * the empty marker at index 1 were scavenged by scav_vector that
1619  * either called this function directly or arranged for it to be
1620  * called later by pushing the hash table onto weak_hash_tables. */
1621 static void
1622 scav_hash_table_entries (struct hash_table *hash_table)
1623 {
1624     lispobj *kv_vector;
1625     uword_t kv_length;
1626     lispobj *index_vector;
1627     uword_t length;
1628     lispobj *next_vector;
1629     uword_t next_vector_length;
1630     lispobj *hash_vector;
1631     uword_t hash_vector_length;
1632     lispobj empty_symbol;
1633     lispobj weakness = hash_table->weakness;
1634     uword_t i;
1635
1636     kv_vector = get_array_data(hash_table->table,
1637                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1638     if (kv_vector == NULL)
1639         lose("invalid kv_vector %x\n", hash_table->table);
1640
1641     index_vector = get_array_data(hash_table->index_vector,
1642                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1643     if (index_vector == NULL)
1644         lose("invalid index_vector %x\n", hash_table->index_vector);
1645
1646     next_vector = get_array_data(hash_table->next_vector,
1647                                  SIMPLE_ARRAY_WORD_WIDETAG,
1648                                  &next_vector_length);
1649     if (next_vector == NULL)
1650         lose("invalid next_vector %x\n", hash_table->next_vector);
1651
1652     hash_vector = get_array_data(hash_table->hash_vector,
1653                                  SIMPLE_ARRAY_WORD_WIDETAG,
1654                                  &hash_vector_length);
1655     if (hash_vector != NULL)
1656         gc_assert(hash_vector_length == next_vector_length);
1657
1658      /* These lengths could be different as the index_vector can be a
1659       * different length from the others, a larger index_vector could
1660       * help reduce collisions. */
1661      gc_assert(next_vector_length*2 == kv_length);
1662
1663     empty_symbol = kv_vector[1];
1664     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1665     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1666         SYMBOL_HEADER_WIDETAG) {
1667         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1668              *(lispobj *)native_pointer(empty_symbol));
1669     }
1670
1671     /* Work through the KV vector. */
1672     for (i = 1; i < next_vector_length; i++) {
1673         lispobj old_key = kv_vector[2*i];
1674         lispobj value = kv_vector[2*i+1];
1675         if ((weakness == NIL) ||
1676             weak_hash_entry_alivep(weakness, old_key, value)) {
1677
1678             /* Scavenge the key and value. */
1679             scavenge(&kv_vector[2*i],2);
1680
1681             /* If an EQ-based key has moved, mark the hash-table for
1682              * rehashing. */
1683             if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
1684                 lispobj new_key = kv_vector[2*i];
1685
1686                 if (old_key != new_key && new_key != empty_symbol) {
1687                     hash_table->needs_rehash_p = T;
1688                 }
1689             }
1690         }
1691     }
1692 }
1693
1694 sword_t
1695 scav_vector (lispobj *where, lispobj object)
1696 {
1697     uword_t kv_length;
1698     struct hash_table *hash_table;
1699
1700     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1701      * hash tables in the Lisp HASH-TABLE code to indicate need for
1702      * special GC support. */
1703     if (HeaderValue(object) == subtype_VectorNormal)
1704         return 1;
1705
1706     kv_length = fixnum_value(where[1]);
1707     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1708
1709     /* Scavenge element 0, which may be a hash-table structure. */
1710     scavenge(where+2, 1);
1711     if (!is_lisp_pointer(where[2])) {
1712         /* This'll happen when REHASH clears the header of old-kv-vector
1713          * and fills it with zero, but some other thread simulatenously
1714          * sets the header in %%PUTHASH.
1715          */
1716         fprintf(stderr,
1717                 "Warning: no pointer at %p in hash table: this indicates "
1718                 "non-fatal corruption caused by concurrent access to a "
1719                 "hash-table from multiple threads. Any accesses to "
1720                 "hash-tables shared between threads should be protected "
1721                 "by locks.\n", (uword_t)&where[2]);
1722         // We've scavenged three words.
1723         return 3;
1724     }
1725     hash_table = (struct hash_table *)native_pointer(where[2]);
1726     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1727     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1728         lose("hash table not instance (%x at %x)\n",
1729              hash_table->header,
1730              hash_table);
1731     }
1732
1733     /* Scavenge element 1, which should be some internal symbol that
1734      * the hash table code reserves for marking empty slots. */
1735     scavenge(where+3, 1);
1736     if (!is_lisp_pointer(where[3])) {
1737         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1738     }
1739
1740     /* Scavenge hash table, which will fix the positions of the other
1741      * needed objects. */
1742     scavenge((lispobj *)hash_table,
1743              sizeof(struct hash_table) / sizeof(lispobj));
1744
1745     /* Cross-check the kv_vector. */
1746     if (where != (lispobj *)native_pointer(hash_table->table)) {
1747         lose("hash_table table!=this table %x\n", hash_table->table);
1748     }
1749
1750     if (hash_table->weakness == NIL) {
1751         scav_hash_table_entries(hash_table);
1752     } else {
1753         /* Delay scavenging of this table by pushing it onto
1754          * weak_hash_tables (if it's not there already) for the weak
1755          * object phase. */
1756         if (hash_table->next_weak_hash_table == NIL) {
1757             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1758             weak_hash_tables = hash_table;
1759         }
1760     }
1761
1762     return (CEILING(kv_length + 2, 2));
1763 }
1764
1765 void
1766 scav_weak_hash_tables (void)
1767 {
1768     struct hash_table *table;
1769
1770     /* Scavenge entries whose triggers are known to survive. */
1771     for (table = weak_hash_tables; table != NULL;
1772          table = (struct hash_table *)table->next_weak_hash_table) {
1773         scav_hash_table_entries(table);
1774     }
1775 }
1776
1777 /* Walk through the chain whose first element is *FIRST and remove
1778  * dead weak entries. */
1779 static inline void
1780 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1781                             lispobj *kv_vector, lispobj *index_vector,
1782                             lispobj *next_vector, lispobj *hash_vector,
1783                             lispobj empty_symbol, lispobj weakness)
1784 {
1785     unsigned index = *prev;
1786     while (index) {
1787         unsigned next = next_vector[index];
1788         lispobj key = kv_vector[2 * index];
1789         lispobj value = kv_vector[2 * index + 1];
1790         gc_assert(key != empty_symbol);
1791         gc_assert(value != empty_symbol);
1792         if (!weak_hash_entry_alivep(weakness, key, value)) {
1793             unsigned count = fixnum_value(hash_table->number_entries);
1794             gc_assert(count > 0);
1795             *prev = next;
1796             hash_table->number_entries = make_fixnum(count - 1);
1797             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1798             hash_table->next_free_kv = make_fixnum(index);
1799             kv_vector[2 * index] = empty_symbol;
1800             kv_vector[2 * index + 1] = empty_symbol;
1801             if (hash_vector)
1802                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1803         } else {
1804             prev = &next_vector[index];
1805         }
1806         index = next;
1807     }
1808 }
1809
1810 static void
1811 scan_weak_hash_table (struct hash_table *hash_table)
1812 {
1813     lispobj *kv_vector;
1814     lispobj *index_vector;
1815     uword_t length = 0; /* prevent warning */
1816     lispobj *next_vector;
1817     uword_t next_vector_length = 0; /* prevent warning */
1818     lispobj *hash_vector;
1819     lispobj empty_symbol;
1820     lispobj weakness = hash_table->weakness;
1821     uword_t i;
1822
1823     kv_vector = get_array_data(hash_table->table,
1824                                SIMPLE_VECTOR_WIDETAG, NULL);
1825     index_vector = get_array_data(hash_table->index_vector,
1826                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1827     next_vector = get_array_data(hash_table->next_vector,
1828                                  SIMPLE_ARRAY_WORD_WIDETAG,
1829                                  &next_vector_length);
1830     hash_vector = get_array_data(hash_table->hash_vector,
1831                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1832     empty_symbol = kv_vector[1];
1833
1834     for (i = 0; i < length; i++) {
1835         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1836                                    kv_vector, index_vector, next_vector,
1837                                    hash_vector, empty_symbol, weakness);
1838     }
1839 }
1840
1841 /* Remove dead entries from weak hash tables. */
1842 void
1843 scan_weak_hash_tables (void)
1844 {
1845     struct hash_table *table, *next;
1846
1847     for (table = weak_hash_tables; table != NULL; table = next) {
1848         next = (struct hash_table *)table->next_weak_hash_table;
1849         table->next_weak_hash_table = NIL;
1850         scan_weak_hash_table(table);
1851     }
1852
1853     weak_hash_tables = NULL;
1854 }
1855
1856 \f
1857 /*
1858  * initialization
1859  */
1860
1861 static sword_t
1862 scav_lose(lispobj *where, lispobj object)
1863 {
1864     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1865          (uword_t)object,
1866          widetag_of(*where));
1867
1868     return 0; /* bogus return value to satisfy static type checking */
1869 }
1870
1871 static lispobj
1872 trans_lose(lispobj object)
1873 {
1874     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1875          (uword_t)object,
1876          widetag_of(*(lispobj*)native_pointer(object)));
1877     return NIL; /* bogus return value to satisfy static type checking */
1878 }
1879
1880 static sword_t
1881 size_lose(lispobj *where)
1882 {
1883     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1884          (uword_t)where,
1885          widetag_of(*where));
1886     return 1; /* bogus return value to satisfy static type checking */
1887 }
1888
1889 \f
1890 /*
1891  * initialization
1892  */
1893
1894 void
1895 gc_init_tables(void)
1896 {
1897     uword_t i, j;
1898
1899     /* Set default value in all slots of scavenge table.  FIXME
1900      * replace this gnarly sizeof with something based on
1901      * N_WIDETAG_BITS */
1902     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1903         scavtab[i] = scav_lose;
1904     }
1905
1906     /* For each type which can be selected by the lowtag alone, set
1907      * multiple entries in our widetag scavenge table (one for each
1908      * possible value of the high bits).
1909      */
1910
1911     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1912         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
1913             if (fixnump(j)) {
1914                 scavtab[j|(i<<N_LOWTAG_BITS)] = scav_immediate;
1915             }
1916         }
1917         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1918         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1919         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1920         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1921             scav_instance_pointer;
1922         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1923         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1924     }
1925
1926     /* Other-pointer types (those selected by all eight bits of the
1927      * tag) get one entry each in the scavenge table. */
1928     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1929     scavtab[RATIO_WIDETAG] = scav_boxed;
1930 #if N_WORD_BITS == 64
1931     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1932 #else
1933     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1934 #endif
1935     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1936 #ifdef LONG_FLOAT_WIDETAG
1937     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1938 #endif
1939     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1940 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1941     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1942 #endif
1943 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1944     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1945 #endif
1946 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1947     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1948 #endif
1949 #ifdef SIMD_PACK_WIDETAG
1950     scavtab[SIMD_PACK_WIDETAG] = scav_unboxed;
1951 #endif
1952     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1953     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1954 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1955     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1956 #endif
1957     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1958     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1959     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1960         scav_vector_unsigned_byte_2;
1961     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1962         scav_vector_unsigned_byte_4;
1963     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1964         scav_vector_unsigned_byte_8;
1965     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1966         scav_vector_unsigned_byte_8;
1967     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1968         scav_vector_unsigned_byte_16;
1969     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1970         scav_vector_unsigned_byte_16;
1971 #if (N_WORD_BITS == 32)
1972     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1973         scav_vector_unsigned_byte_32;
1974 #endif
1975     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1976         scav_vector_unsigned_byte_32;
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1978         scav_vector_unsigned_byte_32;
1979 #if (N_WORD_BITS == 64)
1980     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1981         scav_vector_unsigned_byte_64;
1982 #endif
1983 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1984     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1985         scav_vector_unsigned_byte_64;
1986 #endif
1987 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1988     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1989         scav_vector_unsigned_byte_64;
1990 #endif
1991 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1992     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1993 #endif
1994 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1995     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1996         scav_vector_unsigned_byte_16;
1997 #endif
1998 #if (N_WORD_BITS == 32)
1999     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2000         scav_vector_unsigned_byte_32;
2001 #endif
2002 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2003     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2004         scav_vector_unsigned_byte_32;
2005 #endif
2006 #if (N_WORD_BITS == 64)
2007     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2008         scav_vector_unsigned_byte_64;
2009 #endif
2010 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2011     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2012         scav_vector_unsigned_byte_64;
2013 #endif
2014     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2015     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2016 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2017     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2018 #endif
2019 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2020     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2021         scav_vector_complex_single_float;
2022 #endif
2023 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2024     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2025         scav_vector_complex_double_float;
2026 #endif
2027 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2028     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2029         scav_vector_complex_long_float;
2030 #endif
2031     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2032 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2033     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2034 #endif
2035     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2036     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2037     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2038     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2039     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2040 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2041     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2042     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2043 #endif
2044     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2045 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2046     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2047 #else
2048     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2049 #endif
2050     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2051     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2052     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2053     scavtab[SAP_WIDETAG] = scav_unboxed;
2054     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2055     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2056     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2057 #if defined(LISP_FEATURE_SPARC)
2058     scavtab[FDEFN_WIDETAG] = scav_boxed;
2059 #else
2060     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2061 #endif
2062     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2063
2064     /* transport other table, initialized same way as scavtab */
2065     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2066         transother[i] = trans_lose;
2067     transother[BIGNUM_WIDETAG] = trans_unboxed;
2068     transother[RATIO_WIDETAG] = trans_boxed;
2069
2070 #if N_WORD_BITS == 64
2071     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2072 #else
2073     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2074 #endif
2075     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2076 #ifdef LONG_FLOAT_WIDETAG
2077     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2078 #endif
2079     transother[COMPLEX_WIDETAG] = trans_boxed;
2080 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2081     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2082 #endif
2083 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2084     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2085 #endif
2086 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2087     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2088 #endif
2089     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2090     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2091 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2092     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2093 #endif
2094     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2095     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2096     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2097     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2098         trans_vector_unsigned_byte_2;
2099     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2100         trans_vector_unsigned_byte_4;
2101     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2102         trans_vector_unsigned_byte_8;
2103     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2104         trans_vector_unsigned_byte_8;
2105     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2106         trans_vector_unsigned_byte_16;
2107     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2108         trans_vector_unsigned_byte_16;
2109 #if (N_WORD_BITS == 32)
2110     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2111         trans_vector_unsigned_byte_32;
2112 #endif
2113     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2114         trans_vector_unsigned_byte_32;
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2116         trans_vector_unsigned_byte_32;
2117 #if (N_WORD_BITS == 64)
2118     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2119         trans_vector_unsigned_byte_64;
2120 #endif
2121 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2122     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2123         trans_vector_unsigned_byte_64;
2124 #endif
2125 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2126     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2127         trans_vector_unsigned_byte_64;
2128 #endif
2129 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2130     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2131         trans_vector_unsigned_byte_8;
2132 #endif
2133 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2134     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2135         trans_vector_unsigned_byte_16;
2136 #endif
2137 #if (N_WORD_BITS == 32)
2138     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2139         trans_vector_unsigned_byte_32;
2140 #endif
2141 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2142     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2143         trans_vector_unsigned_byte_32;
2144 #endif
2145 #if (N_WORD_BITS == 64)
2146     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2147         trans_vector_unsigned_byte_64;
2148 #endif
2149 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2150     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2151         trans_vector_unsigned_byte_64;
2152 #endif
2153     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2154         trans_vector_single_float;
2155     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2156         trans_vector_double_float;
2157 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2158     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2159         trans_vector_long_float;
2160 #endif
2161 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2162     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2163         trans_vector_complex_single_float;
2164 #endif
2165 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2166     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2167         trans_vector_complex_double_float;
2168 #endif
2169 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2170     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2171         trans_vector_complex_long_float;
2172 #endif
2173     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2174 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2175     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2176 #endif
2177     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2178     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2179     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2180     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2181     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2182     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2183     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2184     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2185     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2186     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2187     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2188     transother[CHARACTER_WIDETAG] = trans_immediate;
2189     transother[SAP_WIDETAG] = trans_unboxed;
2190 #ifdef SIMD_PACK_WIDETAG
2191     transother[SIMD_PACK_WIDETAG] = trans_unboxed;
2192 #endif
2193     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2194     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2195     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2196     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2197     transother[FDEFN_WIDETAG] = trans_boxed;
2198
2199     /* size table, initialized the same way as scavtab */
2200     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2201         sizetab[i] = size_lose;
2202     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2203         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
2204             if (fixnump(j)) {
2205                 sizetab[j|(i<<N_LOWTAG_BITS)] = size_immediate;
2206             }
2207         }
2208         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2209         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2210         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2211         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2212         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2213         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2214     }
2215     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2216     sizetab[RATIO_WIDETAG] = size_boxed;
2217 #if N_WORD_BITS == 64
2218     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2219 #else
2220     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2221 #endif
2222     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2223 #ifdef LONG_FLOAT_WIDETAG
2224     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2225 #endif
2226     sizetab[COMPLEX_WIDETAG] = size_boxed;
2227 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2228     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2229 #endif
2230 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2231     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2232 #endif
2233 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2234     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2235 #endif
2236     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2237     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2238 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2239     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2240 #endif
2241     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2242     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2243     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2244     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2245         size_vector_unsigned_byte_2;
2246     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2247         size_vector_unsigned_byte_4;
2248     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2249         size_vector_unsigned_byte_8;
2250     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2251         size_vector_unsigned_byte_8;
2252     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2253         size_vector_unsigned_byte_16;
2254     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2255         size_vector_unsigned_byte_16;
2256 #if (N_WORD_BITS == 32)
2257     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2258         size_vector_unsigned_byte_32;
2259 #endif
2260     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2261         size_vector_unsigned_byte_32;
2262     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2263         size_vector_unsigned_byte_32;
2264 #if (N_WORD_BITS == 64)
2265     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2266         size_vector_unsigned_byte_64;
2267 #endif
2268 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2269     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2270         size_vector_unsigned_byte_64;
2271 #endif
2272 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2273     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2274         size_vector_unsigned_byte_64;
2275 #endif
2276 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2277     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2278 #endif
2279 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2280     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2281         size_vector_unsigned_byte_16;
2282 #endif
2283 #if (N_WORD_BITS == 32)
2284     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2285         size_vector_unsigned_byte_32;
2286 #endif
2287 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2288     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2289         size_vector_unsigned_byte_32;
2290 #endif
2291 #if (N_WORD_BITS == 64)
2292     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2293         size_vector_unsigned_byte_64;
2294 #endif
2295 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2296     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2297         size_vector_unsigned_byte_64;
2298 #endif
2299     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2300     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2301 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2302     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2303 #endif
2304 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2305     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2306         size_vector_complex_single_float;
2307 #endif
2308 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2309     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2310         size_vector_complex_double_float;
2311 #endif
2312 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2313     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2314         size_vector_complex_long_float;
2315 #endif
2316     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2317 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2318     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2319 #endif
2320     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2321     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2322     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2323     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2324     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2325 #if 0
2326     /* We shouldn't see these, so just lose if it happens. */
2327     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2328     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2329 #endif
2330     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2331     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2332     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2333     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2334     sizetab[CHARACTER_WIDETAG] = size_immediate;
2335     sizetab[SAP_WIDETAG] = size_unboxed;
2336 #ifdef SIMD_PACK_WIDETAG
2337     sizetab[SIMD_PACK_WIDETAG] = size_unboxed;
2338 #endif
2339     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2340     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2341     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2342     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2343     sizetab[FDEFN_WIDETAG] = size_boxed;
2344 }
2345
2346 \f
2347 /* Find the code object for the given pc, or return NULL on
2348    failure. */
2349 lispobj *
2350 component_ptr_from_pc(lispobj *pc)
2351 {
2352     lispobj *object = NULL;
2353
2354     if ( (object = search_read_only_space(pc)) )
2355         ;
2356     else if ( (object = search_static_space(pc)) )
2357         ;
2358     else
2359         object = search_dynamic_space(pc);
2360
2361     if (object) /* if we found something */
2362         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2363             return(object);
2364
2365     return (NULL);
2366 }
2367
2368 /* Scan an area looking for an object which encloses the given pointer.
2369  * Return the object start on success or NULL on failure. */
2370 lispobj *
2371 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2372 {
2373     while (words > 0) {
2374         size_t count = 1;
2375         lispobj thing = *start;
2376
2377         /* If thing is an immediate then this is a cons. */
2378         if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
2379             count = 2;
2380         else
2381             count = (sizetab[widetag_of(thing)])(start);
2382
2383         /* Check whether the pointer is within this object. */
2384         if ((pointer >= start) && (pointer < (start+count))) {
2385             /* found it! */
2386             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2387             return(start);
2388         }
2389
2390         /* Round up the count. */
2391         count = CEILING(count,2);
2392
2393         start += count;
2394         words -= count;
2395     }
2396     return (NULL);
2397 }
2398
2399 /* Helper for valid_lisp_pointer_p (below) and
2400  * possibly_valid_dynamic_space_pointer (gencgc).
2401  *
2402  * pointer is the pointer to validate, and start_addr is the address
2403  * of the enclosing object.
2404  */
2405 int
2406 looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr)
2407 {
2408     if (!is_lisp_pointer(pointer)) {
2409         return 0;
2410     }
2411
2412     /* Check that the object pointed to is consistent with the pointer
2413      * low tag. */
2414     switch (lowtag_of(pointer)) {
2415     case FUN_POINTER_LOWTAG:
2416         /* Start_addr should be the enclosing code object, or a closure
2417          * header. */
2418         switch (widetag_of(*start_addr)) {
2419         case CODE_HEADER_WIDETAG:
2420             /* Make sure we actually point to a function in the code object,
2421              * as opposed to a random point there. */
2422             if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(native_pointer(pointer)[0]))
2423                 return 1;
2424             else
2425                 return 0;
2426         case CLOSURE_HEADER_WIDETAG:
2427         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2428             if (pointer != make_lispobj(start_addr, FUN_POINTER_LOWTAG)) {
2429                 return 0;
2430             }
2431             break;
2432         default:
2433             return 0;
2434         }
2435         break;
2436     case LIST_POINTER_LOWTAG:
2437         if (pointer != make_lispobj(start_addr, LIST_POINTER_LOWTAG)) {
2438             return 0;
2439         }
2440         /* Is it plausible cons? */
2441         if ((is_lisp_pointer(start_addr[0]) ||
2442              is_lisp_immediate(start_addr[0])) &&
2443             (is_lisp_pointer(start_addr[1]) ||
2444              is_lisp_immediate(start_addr[1])))
2445             break;
2446         else {
2447             return 0;
2448         }
2449     case INSTANCE_POINTER_LOWTAG:
2450         if (pointer != make_lispobj(start_addr, INSTANCE_POINTER_LOWTAG)) {
2451             return 0;
2452         }
2453         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2454             return 0;
2455         }
2456         break;
2457     case OTHER_POINTER_LOWTAG:
2458
2459 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2460         /* The all-architecture test below is good as far as it goes,
2461          * but an LRA object is similar to a FUN-POINTER: It is
2462          * embedded within a CODE-OBJECT pointed to by start_addr, and
2463          * cannot be found by simply walking the heap, therefore we
2464          * need to check for it. -- AB, 2010-Jun-04 */
2465         if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
2466             lispobj *potential_lra = native_pointer(pointer);
2467             if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
2468                 ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
2469                 return 1; /* It's as good as we can verify. */
2470             }
2471         }
2472 #endif
2473
2474         if (pointer != make_lispobj(start_addr, OTHER_POINTER_LOWTAG)) {
2475             return 0;
2476         }
2477         /* Is it plausible?  Not a cons. XXX should check the headers. */
2478         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2479             return 0;
2480         }
2481         switch (widetag_of(start_addr[0])) {
2482         case UNBOUND_MARKER_WIDETAG:
2483         case NO_TLS_VALUE_MARKER_WIDETAG:
2484         case CHARACTER_WIDETAG:
2485 #if N_WORD_BITS == 64
2486         case SINGLE_FLOAT_WIDETAG:
2487 #endif
2488             return 0;
2489
2490             /* only pointed to by function pointers? */
2491         case CLOSURE_HEADER_WIDETAG:
2492         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2493             return 0;
2494
2495         case INSTANCE_HEADER_WIDETAG:
2496             return 0;
2497
2498             /* the valid other immediate pointer objects */
2499         case SIMPLE_VECTOR_WIDETAG:
2500         case RATIO_WIDETAG:
2501         case COMPLEX_WIDETAG:
2502 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2503         case COMPLEX_SINGLE_FLOAT_WIDETAG:
2504 #endif
2505 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2506         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2507 #endif
2508 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2509         case COMPLEX_LONG_FLOAT_WIDETAG:
2510 #endif
2511 #ifdef SIMD_PACK_WIDETAG
2512         case SIMD_PACK_WIDETAG:
2513 #endif
2514         case SIMPLE_ARRAY_WIDETAG:
2515         case COMPLEX_BASE_STRING_WIDETAG:
2516 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2517         case COMPLEX_CHARACTER_STRING_WIDETAG:
2518 #endif
2519         case COMPLEX_VECTOR_NIL_WIDETAG:
2520         case COMPLEX_BIT_VECTOR_WIDETAG:
2521         case COMPLEX_VECTOR_WIDETAG:
2522         case COMPLEX_ARRAY_WIDETAG:
2523         case VALUE_CELL_HEADER_WIDETAG:
2524         case SYMBOL_HEADER_WIDETAG:
2525         case FDEFN_WIDETAG:
2526         case CODE_HEADER_WIDETAG:
2527         case BIGNUM_WIDETAG:
2528 #if N_WORD_BITS != 64
2529         case SINGLE_FLOAT_WIDETAG:
2530 #endif
2531         case DOUBLE_FLOAT_WIDETAG:
2532 #ifdef LONG_FLOAT_WIDETAG
2533         case LONG_FLOAT_WIDETAG:
2534 #endif
2535         case SIMPLE_BASE_STRING_WIDETAG:
2536 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2537         case SIMPLE_CHARACTER_STRING_WIDETAG:
2538 #endif
2539         case SIMPLE_BIT_VECTOR_WIDETAG:
2540         case SIMPLE_ARRAY_NIL_WIDETAG:
2541         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2542         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2543         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2544         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2545         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2546         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2547
2548         case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
2549
2550         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2551         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2552 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2553         case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2554 #endif
2555 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2556         case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2557 #endif
2558 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2559         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2560 #endif
2561 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2562         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2563 #endif
2564
2565         case SIMPLE_ARRAY_FIXNUM_WIDETAG:
2566
2567 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2568         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2569 #endif
2570 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2571         case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2572 #endif
2573         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2574         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2575 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2576         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2577 #endif
2578 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2579         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2580 #endif
2581 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2582         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2583 #endif
2584 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2585         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2586 #endif
2587         case SAP_WIDETAG:
2588         case WEAK_POINTER_WIDETAG:
2589             break;
2590
2591         default:
2592             return 0;
2593         }
2594         break;
2595     default:
2596         return 0;
2597     }
2598
2599     /* looks good */
2600     return 1;
2601 }
2602
2603 /* Used by the debugger to validate possibly bogus pointers before
2604  * calling MAKE-LISP-OBJ on them.
2605  *
2606  * FIXME: We would like to make this perfect, because if the debugger
2607  * constructs a reference to a bugs lisp object, and it ends up in a
2608  * location scavenged by the GC all hell breaks loose.
2609  *
2610  * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2611  * and return true for all valid pointers, this could actually be eager
2612  * and lie about a few pointers without bad results... but that should
2613  * be reflected in the name.
2614  */
2615 int
2616 valid_lisp_pointer_p(lispobj *pointer)
2617 {
2618     lispobj *start;
2619     if (((start=search_dynamic_space(pointer))!=NULL) ||
2620         ((start=search_static_space(pointer))!=NULL) ||
2621         ((start=search_read_only_space(pointer))!=NULL))
2622         return looks_like_valid_lisp_pointer_p((lispobj)pointer, start);
2623     else
2624         return 0;
2625 }
2626
2627 boolean
2628 maybe_gc(os_context_t *context)
2629 {
2630     lispobj gc_happened;
2631     struct thread *thread = arch_os_get_current_thread();
2632
2633     fake_foreign_function_call(context);
2634     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2635      * which case we will be running with no gc trigger barrier
2636      * thing for a while.  But it shouldn't be long until the end
2637      * of WITHOUT-GCING.
2638      *
2639      * FIXME: It would be good to protect the end of dynamic space for
2640      * CheneyGC and signal a storage condition from there.
2641      */
2642
2643     /* Restore the signal mask from the interrupted context before
2644      * calling into Lisp if interrupts are enabled. Why not always?
2645      *
2646      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2647      * interrupt hits while in SUB-GC, it is deferred and the
2648      * os_context_sigmask of that interrupt is set to block further
2649      * deferrable interrupts (until the first one is
2650      * handled). Unfortunately, that context refers to this place and
2651      * when we return from here the signals will not be blocked.
2652      *
2653      * A kludgy alternative is to propagate the sigmask change to the
2654      * outer context.
2655      */
2656 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2657     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2658     unblock_gc_signals(0, 0);
2659 #endif
2660     FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2661     /* FIXME: Nothing must go wrong during GC else we end up running
2662      * the debugger, error handlers, and user code in general in a
2663      * potentially unsafe place. Running out of the control stack or
2664      * the heap in SUB-GC are ways to lose. Of course, deferrables
2665      * cannot be unblocked because there may be a pending handler, or
2666      * we may even be in a WITHOUT-INTERRUPTS. */
2667     gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2668     FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2669            (gc_happened == NIL) ? "NIL" : "T"));
2670     if ((gc_happened != NIL) &&
2671         /* See if interrupts are enabled or it's possible to enable
2672          * them. POST-GC has a similar check, but we don't want to
2673          * unlock deferrables in that case and get a pending interrupt
2674          * here. */
2675         ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2676          (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2677 #ifndef LISP_FEATURE_WIN32
2678         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2679         if (!deferrables_blocked_p(context_sigmask)) {
2680             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2681 #ifndef LISP_FEATURE_SB_SAFEPOINT
2682             check_gc_signals_unblocked_or_lose(0);
2683 #endif
2684 #endif
2685             FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2686             funcall0(StaticSymbolFunction(POST_GC));
2687 #ifndef LISP_FEATURE_WIN32
2688         } else {
2689             FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2690         }
2691 #endif
2692     }
2693     undo_fake_foreign_function_call(context);
2694     FSHOW((stderr, "/maybe_gc: returning\n"));
2695     return (gc_happened != NIL);
2696 }
2697
2698 #define BYTES_ZERO_BEFORE_END (1<<12)
2699
2700 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2701  * Lisp and another called zero_stack() in cheneygc.c, but since it's
2702  * shorter to express in, and more often called from C, I keep only
2703  * the C one after fixing it. -- MG 2009-03-25 */
2704
2705 /* Zero the unused portion of the control stack so that old objects
2706  * are not kept alive because of uninitialized stack variables.
2707  *
2708  * "To summarize the problem, since not all allocated stack frame
2709  * slots are guaranteed to be written by the time you call an another
2710  * function or GC, there may be garbage pointers retained in your dead
2711  * stack locations. The stack scrubbing only affects the part of the
2712  * stack from the SP to the end of the allocated stack." - ram, on
2713  * cmucl-imp, Tue, 25 Sep 2001
2714  *
2715  * So, as an (admittedly lame) workaround, from time to time we call
2716  * scrub-control-stack to zero out all the unused portion. This is
2717  * supposed to happen when the stack is mostly empty, so that we have
2718  * a chance of clearing more of it: callers are currently (2002.07.18)
2719  * REPL, SUB-GC and sig_stop_for_gc_handler. */
2720
2721 /* Take care not to tread on the guard page and the hard guard page as
2722  * it would be unkind to sig_stop_for_gc_handler. Touching the return
2723  * guard page is not dangerous. For this to work the guard page must
2724  * be zeroed when protected. */
2725
2726 /* FIXME: I think there is no guarantee that once
2727  * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2728  * may be what the "lame" adjective in the above comment is for. In
2729  * this case, exact gc may lose badly. */
2730 void
2731 scrub_control_stack()
2732 {
2733     scrub_thread_control_stack(arch_os_get_current_thread());
2734 }
2735
2736 void
2737 scrub_thread_control_stack(struct thread *th)
2738 {
2739     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2740     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2741 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2742     /* On these targets scrubbing from C is a bad idea, so we punt to
2743      * a routine in $ARCH-assem.S. */
2744     extern void arch_scrub_control_stack(struct thread *, os_vm_address_t, os_vm_address_t);
2745     arch_scrub_control_stack(th, guard_page_address, hard_guard_page_address);
2746 #else
2747     lispobj *sp = access_control_stack_pointer(th);
2748  scrub:
2749     if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2750          ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2751         (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2752          ((os_vm_address_t)sp >= guard_page_address) &&
2753          (th->control_stack_guard_page_protected != NIL)))
2754         return;
2755 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2756     do {
2757         *sp = 0;
2758     } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2759     if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2760         return;
2761     do {
2762         if (*sp)
2763             goto scrub;
2764     } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2765 #else
2766     do {
2767         *sp = 0;
2768     } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2769     if ((os_vm_address_t)sp >= hard_guard_page_address)
2770         return;
2771     do {
2772         if (*sp)
2773             goto scrub;
2774     } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2775 #endif
2776 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2777 }
2778 \f
2779 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2780
2781 void
2782 scavenge_control_stack(struct thread *th)
2783 {
2784     lispobj *object_ptr;
2785
2786     /* In order to properly support dynamic-extent allocation of
2787      * non-CONS objects, the control stack requires special handling.
2788      * Rather than calling scavenge() directly, grovel over it fixing
2789      * broken hearts, scavenging pointers to oldspace, and pitching a
2790      * fit when encountering unboxed data.  This prevents stray object
2791      * headers from causing the scavenger to blow past the end of the
2792      * stack (an error case checked in scavenge()).  We don't worry
2793      * about treating unboxed words as boxed or vice versa, because
2794      * the compiler isn't allowed to store unboxed objects on the
2795      * control stack.  -- AB, 2011-Dec-02 */
2796
2797     for (object_ptr = th->control_stack_start;
2798          object_ptr < access_control_stack_pointer(th);
2799          object_ptr++) {
2800
2801         lispobj object = *object_ptr;
2802 #ifdef LISP_FEATURE_GENCGC
2803         if (forwarding_pointer_p(object_ptr))
2804             lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
2805                  object_ptr, th->control_stack_start, access_control_stack_pointer(th));
2806 #endif
2807         if (is_lisp_pointer(object) && from_space_p(object)) {
2808             /* It currently points to old space. Check for a
2809              * forwarding pointer. */
2810             lispobj *ptr = native_pointer(object);
2811             if (forwarding_pointer_p(ptr)) {
2812                 /* Yes, there's a forwarding pointer. */
2813                 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
2814             } else {
2815                 /* Scavenge that pointer. */
2816                 long n_words_scavenged =
2817                     (scavtab[widetag_of(object)])(object_ptr, object);
2818                 gc_assert(n_words_scavenged == 1);
2819             }
2820         } else if (scavtab[widetag_of(object)] == scav_lose) {
2821             lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
2822                  object_ptr, object, th->control_stack_start, access_control_stack_pointer(th));
2823         }
2824     }
2825 }
2826
2827 /* Scavenging Interrupt Contexts */
2828
2829 static int boxed_registers[] = BOXED_REGISTERS;
2830
2831 /* The GC has a notion of an "interior pointer" register, an unboxed
2832  * register that typically contains a pointer to inside an object
2833  * referenced by another pointer.  The most obvious of these is the
2834  * program counter, although many compiler backends define a "Lisp
2835  * Interior Pointer" register known to the runtime as reg_LIP, and
2836  * various CPU architectures have other registers that also partake of
2837  * the interior-pointer nature.  As the code for pairing an interior
2838  * pointer value up with its "base" register, and fixing it up after
2839  * scavenging is complete is horribly repetitive, a few macros paper
2840  * over the monotony.  --AB, 2010-Jul-14 */
2841
2842 /* These macros are only ever used over a lexical environment which
2843  * defines a pointer to an os_context_t called context, thus we don't
2844  * bother to pass that context in as a parameter. */
2845
2846 /* Define how to access a given interior pointer. */
2847 #define ACCESS_INTERIOR_POINTER_pc \
2848     *os_context_pc_addr(context)
2849 #define ACCESS_INTERIOR_POINTER_lip \
2850     *os_context_register_addr(context, reg_LIP)
2851 #define ACCESS_INTERIOR_POINTER_lr \
2852     *os_context_lr_addr(context)
2853 #define ACCESS_INTERIOR_POINTER_npc \
2854     *os_context_npc_addr(context)
2855 #define ACCESS_INTERIOR_POINTER_ctr \
2856     *os_context_ctr_addr(context)
2857
2858 #define INTERIOR_POINTER_VARS(name) \
2859     uword_t name##_offset;    \
2860     int name##_register_pair
2861
2862 #define PAIR_INTERIOR_POINTER(name)                             \
2863     pair_interior_pointer(context,                              \
2864                           ACCESS_INTERIOR_POINTER_##name,       \
2865                           &name##_offset,                       \
2866                           &name##_register_pair)
2867
2868 /* One complexity here is that if a paired register is not found for
2869  * an interior pointer, then that pointer does not get updated.
2870  * Originally, there was some commentary about using an index of -1
2871  * when calling os_context_register_addr() on SPARC referring to the
2872  * program counter, but the real reason is to allow an interior
2873  * pointer register to point to the runtime, read-only space, or
2874  * static space without problems. */
2875 #define FIXUP_INTERIOR_POINTER(name)                                    \
2876     do {                                                                \
2877         if (name##_register_pair >= 0) {                                \
2878             ACCESS_INTERIOR_POINTER_##name =                            \
2879                 (*os_context_register_addr(context,                     \
2880                                            name##_register_pair)        \
2881                  & ~LOWTAG_MASK)                                        \
2882                 + name##_offset;                                        \
2883         }                                                               \
2884     } while (0)
2885
2886
2887 static void
2888 pair_interior_pointer(os_context_t *context, uword_t pointer,
2889                       uword_t *saved_offset, int *register_pair)
2890 {
2891     int i;
2892
2893     /*
2894      * I (RLT) think this is trying to find the boxed register that is
2895      * closest to the LIP address, without going past it.  Usually, it's
2896      * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2897      */
2898     /* 0x7FFFFFFF on 32-bit platforms;
2899        0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2900     *saved_offset = (((uword_t)1) << (N_WORD_BITS - 1)) - 1;
2901     *register_pair = -1;
2902     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2903         uword_t reg;
2904         sword_t offset;
2905         int index;
2906
2907         index = boxed_registers[i];
2908         reg = *os_context_register_addr(context, index);
2909
2910         /* An interior pointer is never relative to a non-pointer
2911          * register (an oversight in the original implementation).
2912          * The simplest argument for why this is true is to consider
2913          * the fixnum that happens by coincide to be the word-index in
2914          * memory of the header for some object plus two.  This is
2915          * happenstance would cause the register containing the fixnum
2916          * to be selected as the register_pair if the interior pointer
2917          * is to anywhere after the first two words of the object.
2918          * The fixnum won't be changed during GC, but the object might
2919          * move, thus destroying the interior pointer.  --AB,
2920          * 2010-Jul-14 */
2921
2922         if (is_lisp_pointer(reg) &&
2923             ((reg & ~LOWTAG_MASK) <= pointer)) {
2924             offset = pointer - (reg & ~LOWTAG_MASK);
2925             if (offset < *saved_offset) {
2926                 *saved_offset = offset;
2927                 *register_pair = index;
2928             }
2929         }
2930     }
2931 }
2932
2933 static void
2934 scavenge_interrupt_context(os_context_t * context)
2935 {
2936     int i;
2937
2938     /* FIXME: The various #ifdef noise here is precisely that: noise.
2939      * Is it possible to fold it into the macrology so that we have
2940      * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2941      * compile out for the registers that don't exist on a given
2942      * platform? */
2943
2944     INTERIOR_POINTER_VARS(pc);
2945 #ifdef reg_LIP
2946     INTERIOR_POINTER_VARS(lip);
2947 #endif
2948 #ifdef ARCH_HAS_LINK_REGISTER
2949     INTERIOR_POINTER_VARS(lr);
2950 #endif
2951 #ifdef ARCH_HAS_NPC_REGISTER
2952     INTERIOR_POINTER_VARS(npc);
2953 #endif
2954 #ifdef LISP_FEATURE_PPC
2955     INTERIOR_POINTER_VARS(ctr);
2956 #endif
2957
2958     PAIR_INTERIOR_POINTER(pc);
2959 #ifdef reg_LIP
2960     PAIR_INTERIOR_POINTER(lip);
2961 #endif
2962 #ifdef ARCH_HAS_LINK_REGISTER
2963     PAIR_INTERIOR_POINTER(lr);
2964 #endif
2965 #ifdef ARCH_HAS_NPC_REGISTER
2966     PAIR_INTERIOR_POINTER(npc);
2967 #endif
2968 #ifdef LISP_FEATURE_PPC
2969     PAIR_INTERIOR_POINTER(ctr);
2970 #endif
2971
2972     /* Scavenge all boxed registers in the context. */
2973     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2974         int index;
2975         lispobj foo;
2976
2977         index = boxed_registers[i];
2978         foo = *os_context_register_addr(context, index);
2979         scavenge(&foo, 1);
2980         *os_context_register_addr(context, index) = foo;
2981
2982         /* this is unlikely to work as intended on bigendian
2983          * 64 bit platforms */
2984
2985         scavenge((lispobj *) os_context_register_addr(context, index), 1);
2986     }
2987
2988     /* Now that the scavenging is done, repair the various interior
2989      * pointers. */
2990     FIXUP_INTERIOR_POINTER(pc);
2991 #ifdef reg_LIP
2992     FIXUP_INTERIOR_POINTER(lip);
2993 #endif
2994 #ifdef ARCH_HAS_LINK_REGISTER
2995     FIXUP_INTERIOR_POINTER(lr);
2996 #endif
2997 #ifdef ARCH_HAS_NPC_REGISTER
2998     FIXUP_INTERIOR_POINTER(npc);
2999 #endif
3000 #ifdef LISP_FEATURE_PPC
3001     FIXUP_INTERIOR_POINTER(ctr);
3002 #endif
3003 }
3004
3005 void
3006 scavenge_interrupt_contexts(struct thread *th)
3007 {
3008     int i, index;
3009     os_context_t *context;
3010
3011     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
3012
3013 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3014     printf("Number of active contexts: %d\n", index);
3015 #endif
3016
3017     for (i = 0; i < index; i++) {
3018         context = th->interrupt_contexts[i];
3019         scavenge_interrupt_context(context);
3020     }
3021 }
3022 #endif /* x86oid targets */