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     lispobj *kv_vector;
1699     struct hash_table *hash_table;
1700
1701     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1702      * hash tables in the Lisp HASH-TABLE code to indicate need for
1703      * special GC support. */
1704     if (HeaderValue(object) == subtype_VectorNormal)
1705         return 1;
1706
1707     kv_length = fixnum_value(where[1]);
1708     kv_vector = where + 2;  /* Skip the header and length. */
1709     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1710
1711     /* Scavenge element 0, which may be a hash-table structure. */
1712     scavenge(where+2, 1);
1713     if (!is_lisp_pointer(where[2])) {
1714         /* This'll happen when REHASH clears the header of old-kv-vector
1715          * and fills it with zero, but some other thread simulatenously
1716          * sets the header in %%PUTHASH.
1717          */
1718         fprintf(stderr,
1719                 "Warning: no pointer at %p in hash table: this indicates "
1720                 "non-fatal corruption caused by concurrent access to a "
1721                 "hash-table from multiple threads. Any accesses to "
1722                 "hash-tables shared between threads should be protected "
1723                 "by locks.\n", (uword_t)&where[2]);
1724         // We've scavenged three words.
1725         return 3;
1726     }
1727     hash_table = (struct hash_table *)native_pointer(where[2]);
1728     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1729     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1730         lose("hash table not instance (%x at %x)\n",
1731              hash_table->header,
1732              hash_table);
1733     }
1734
1735     /* Scavenge element 1, which should be some internal symbol that
1736      * the hash table code reserves for marking empty slots. */
1737     scavenge(where+3, 1);
1738     if (!is_lisp_pointer(where[3])) {
1739         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1740     }
1741
1742     /* Scavenge hash table, which will fix the positions of the other
1743      * needed objects. */
1744     scavenge((lispobj *)hash_table,
1745              sizeof(struct hash_table) / sizeof(lispobj));
1746
1747     /* Cross-check the kv_vector. */
1748     if (where != (lispobj *)native_pointer(hash_table->table)) {
1749         lose("hash_table table!=this table %x\n", hash_table->table);
1750     }
1751
1752     if (hash_table->weakness == NIL) {
1753         scav_hash_table_entries(hash_table);
1754     } else {
1755         /* Delay scavenging of this table by pushing it onto
1756          * weak_hash_tables (if it's not there already) for the weak
1757          * object phase. */
1758         if (hash_table->next_weak_hash_table == NIL) {
1759             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1760             weak_hash_tables = hash_table;
1761         }
1762     }
1763
1764     return (CEILING(kv_length + 2, 2));
1765 }
1766
1767 void
1768 scav_weak_hash_tables (void)
1769 {
1770     struct hash_table *table;
1771
1772     /* Scavenge entries whose triggers are known to survive. */
1773     for (table = weak_hash_tables; table != NULL;
1774          table = (struct hash_table *)table->next_weak_hash_table) {
1775         scav_hash_table_entries(table);
1776     }
1777 }
1778
1779 /* Walk through the chain whose first element is *FIRST and remove
1780  * dead weak entries. */
1781 static inline void
1782 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1783                             lispobj *kv_vector, lispobj *index_vector,
1784                             lispobj *next_vector, lispobj *hash_vector,
1785                             lispobj empty_symbol, lispobj weakness)
1786 {
1787     unsigned index = *prev;
1788     while (index) {
1789         unsigned next = next_vector[index];
1790         lispobj key = kv_vector[2 * index];
1791         lispobj value = kv_vector[2 * index + 1];
1792         gc_assert(key != empty_symbol);
1793         gc_assert(value != empty_symbol);
1794         if (!weak_hash_entry_alivep(weakness, key, value)) {
1795             unsigned count = fixnum_value(hash_table->number_entries);
1796             gc_assert(count > 0);
1797             *prev = next;
1798             hash_table->number_entries = make_fixnum(count - 1);
1799             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1800             hash_table->next_free_kv = make_fixnum(index);
1801             kv_vector[2 * index] = empty_symbol;
1802             kv_vector[2 * index + 1] = empty_symbol;
1803             if (hash_vector)
1804                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1805         } else {
1806             prev = &next_vector[index];
1807         }
1808         index = next;
1809     }
1810 }
1811
1812 static void
1813 scan_weak_hash_table (struct hash_table *hash_table)
1814 {
1815     lispobj *kv_vector;
1816     lispobj *index_vector;
1817     uword_t length = 0; /* prevent warning */
1818     lispobj *next_vector;
1819     uword_t next_vector_length = 0; /* prevent warning */
1820     lispobj *hash_vector;
1821     lispobj empty_symbol;
1822     lispobj weakness = hash_table->weakness;
1823     uword_t i;
1824
1825     kv_vector = get_array_data(hash_table->table,
1826                                SIMPLE_VECTOR_WIDETAG, NULL);
1827     index_vector = get_array_data(hash_table->index_vector,
1828                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1829     next_vector = get_array_data(hash_table->next_vector,
1830                                  SIMPLE_ARRAY_WORD_WIDETAG,
1831                                  &next_vector_length);
1832     hash_vector = get_array_data(hash_table->hash_vector,
1833                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1834     empty_symbol = kv_vector[1];
1835
1836     for (i = 0; i < length; i++) {
1837         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1838                                    kv_vector, index_vector, next_vector,
1839                                    hash_vector, empty_symbol, weakness);
1840     }
1841 }
1842
1843 /* Remove dead entries from weak hash tables. */
1844 void
1845 scan_weak_hash_tables (void)
1846 {
1847     struct hash_table *table, *next;
1848
1849     for (table = weak_hash_tables; table != NULL; table = next) {
1850         next = (struct hash_table *)table->next_weak_hash_table;
1851         table->next_weak_hash_table = NIL;
1852         scan_weak_hash_table(table);
1853     }
1854
1855     weak_hash_tables = NULL;
1856 }
1857
1858 \f
1859 /*
1860  * initialization
1861  */
1862
1863 static sword_t
1864 scav_lose(lispobj *where, lispobj object)
1865 {
1866     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1867          (uword_t)object,
1868          widetag_of(*where));
1869
1870     return 0; /* bogus return value to satisfy static type checking */
1871 }
1872
1873 static lispobj
1874 trans_lose(lispobj object)
1875 {
1876     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1877          (uword_t)object,
1878          widetag_of(*(lispobj*)native_pointer(object)));
1879     return NIL; /* bogus return value to satisfy static type checking */
1880 }
1881
1882 static sword_t
1883 size_lose(lispobj *where)
1884 {
1885     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1886          (uword_t)where,
1887          widetag_of(*where));
1888     return 1; /* bogus return value to satisfy static type checking */
1889 }
1890
1891 \f
1892 /*
1893  * initialization
1894  */
1895
1896 void
1897 gc_init_tables(void)
1898 {
1899     uword_t i, j;
1900
1901     /* Set default value in all slots of scavenge table.  FIXME
1902      * replace this gnarly sizeof with something based on
1903      * N_WIDETAG_BITS */
1904     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1905         scavtab[i] = scav_lose;
1906     }
1907
1908     /* For each type which can be selected by the lowtag alone, set
1909      * multiple entries in our widetag scavenge table (one for each
1910      * possible value of the high bits).
1911      */
1912
1913     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1914         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
1915             if (fixnump(j)) {
1916                 scavtab[j|(i<<N_LOWTAG_BITS)] = scav_immediate;
1917             }
1918         }
1919         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1920         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1921         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1922         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1923             scav_instance_pointer;
1924         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1925         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1926     }
1927
1928     /* Other-pointer types (those selected by all eight bits of the
1929      * tag) get one entry each in the scavenge table. */
1930     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1931     scavtab[RATIO_WIDETAG] = scav_boxed;
1932 #if N_WORD_BITS == 64
1933     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1934 #else
1935     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1936 #endif
1937     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1938 #ifdef LONG_FLOAT_WIDETAG
1939     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1940 #endif
1941     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1942 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1943     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1944 #endif
1945 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1946     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1947 #endif
1948 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1949     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1950 #endif
1951 #ifdef SIMD_PACK_WIDETAG
1952     scavtab[SIMD_PACK_WIDETAG] = scav_unboxed;
1953 #endif
1954     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1955     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1956 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1957     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1958 #endif
1959     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1960     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1961     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1962         scav_vector_unsigned_byte_2;
1963     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1964         scav_vector_unsigned_byte_4;
1965     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1966         scav_vector_unsigned_byte_8;
1967     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1968         scav_vector_unsigned_byte_8;
1969     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1970         scav_vector_unsigned_byte_16;
1971     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1972         scav_vector_unsigned_byte_16;
1973 #if (N_WORD_BITS == 32)
1974     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1975         scav_vector_unsigned_byte_32;
1976 #endif
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1978         scav_vector_unsigned_byte_32;
1979     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1980         scav_vector_unsigned_byte_32;
1981 #if (N_WORD_BITS == 64)
1982     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1983         scav_vector_unsigned_byte_64;
1984 #endif
1985 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1986     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1987         scav_vector_unsigned_byte_64;
1988 #endif
1989 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1990     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1991         scav_vector_unsigned_byte_64;
1992 #endif
1993 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1994     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1995 #endif
1996 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1997     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1998         scav_vector_unsigned_byte_16;
1999 #endif
2000 #if (N_WORD_BITS == 32)
2001     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2002         scav_vector_unsigned_byte_32;
2003 #endif
2004 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2005     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2006         scav_vector_unsigned_byte_32;
2007 #endif
2008 #if (N_WORD_BITS == 64)
2009     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2010         scav_vector_unsigned_byte_64;
2011 #endif
2012 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2013     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2014         scav_vector_unsigned_byte_64;
2015 #endif
2016     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2017     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2018 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2019     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2020 #endif
2021 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2022     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2023         scav_vector_complex_single_float;
2024 #endif
2025 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2026     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2027         scav_vector_complex_double_float;
2028 #endif
2029 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2030     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2031         scav_vector_complex_long_float;
2032 #endif
2033     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2034 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2035     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2036 #endif
2037     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2038     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2039     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2040     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2041     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2042 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2043     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2044     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2045 #endif
2046     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2047 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2048     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2049 #else
2050     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2051 #endif
2052     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2053     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2054     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2055     scavtab[SAP_WIDETAG] = scav_unboxed;
2056     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2057     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2058     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2059 #if defined(LISP_FEATURE_SPARC)
2060     scavtab[FDEFN_WIDETAG] = scav_boxed;
2061 #else
2062     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2063 #endif
2064     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2065
2066     /* transport other table, initialized same way as scavtab */
2067     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2068         transother[i] = trans_lose;
2069     transother[BIGNUM_WIDETAG] = trans_unboxed;
2070     transother[RATIO_WIDETAG] = trans_boxed;
2071
2072 #if N_WORD_BITS == 64
2073     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2074 #else
2075     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2076 #endif
2077     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2078 #ifdef LONG_FLOAT_WIDETAG
2079     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2080 #endif
2081     transother[COMPLEX_WIDETAG] = trans_boxed;
2082 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2083     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2084 #endif
2085 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2086     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2087 #endif
2088 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2089     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2090 #endif
2091     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2092     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2093 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2094     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2095 #endif
2096     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2097     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2098     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2099     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2100         trans_vector_unsigned_byte_2;
2101     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2102         trans_vector_unsigned_byte_4;
2103     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2104         trans_vector_unsigned_byte_8;
2105     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2106         trans_vector_unsigned_byte_8;
2107     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2108         trans_vector_unsigned_byte_16;
2109     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2110         trans_vector_unsigned_byte_16;
2111 #if (N_WORD_BITS == 32)
2112     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2113         trans_vector_unsigned_byte_32;
2114 #endif
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2116         trans_vector_unsigned_byte_32;
2117     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2118         trans_vector_unsigned_byte_32;
2119 #if (N_WORD_BITS == 64)
2120     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2121         trans_vector_unsigned_byte_64;
2122 #endif
2123 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2124     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2125         trans_vector_unsigned_byte_64;
2126 #endif
2127 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2128     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2129         trans_vector_unsigned_byte_64;
2130 #endif
2131 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2132     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2133         trans_vector_unsigned_byte_8;
2134 #endif
2135 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2136     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2137         trans_vector_unsigned_byte_16;
2138 #endif
2139 #if (N_WORD_BITS == 32)
2140     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2141         trans_vector_unsigned_byte_32;
2142 #endif
2143 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2144     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2145         trans_vector_unsigned_byte_32;
2146 #endif
2147 #if (N_WORD_BITS == 64)
2148     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2149         trans_vector_unsigned_byte_64;
2150 #endif
2151 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2152     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2153         trans_vector_unsigned_byte_64;
2154 #endif
2155     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2156         trans_vector_single_float;
2157     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2158         trans_vector_double_float;
2159 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2160     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2161         trans_vector_long_float;
2162 #endif
2163 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2164     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2165         trans_vector_complex_single_float;
2166 #endif
2167 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2168     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2169         trans_vector_complex_double_float;
2170 #endif
2171 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2172     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2173         trans_vector_complex_long_float;
2174 #endif
2175     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2176 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2177     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2178 #endif
2179     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2180     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2181     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2182     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2183     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2184     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2185     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2186     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2187     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2188     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2189     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2190     transother[CHARACTER_WIDETAG] = trans_immediate;
2191     transother[SAP_WIDETAG] = trans_unboxed;
2192 #ifdef SIMD_PACK_WIDETAG
2193     transother[SIMD_PACK_WIDETAG] = trans_unboxed;
2194 #endif
2195     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2196     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2197     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2198     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2199     transother[FDEFN_WIDETAG] = trans_boxed;
2200
2201     /* size table, initialized the same way as scavtab */
2202     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2203         sizetab[i] = size_lose;
2204     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2205         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
2206             if (fixnump(j)) {
2207                 sizetab[j|(i<<N_LOWTAG_BITS)] = size_immediate;
2208             }
2209         }
2210         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2211         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2212         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2213         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2214         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2215         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2216     }
2217     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2218     sizetab[RATIO_WIDETAG] = size_boxed;
2219 #if N_WORD_BITS == 64
2220     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2221 #else
2222     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2223 #endif
2224     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2225 #ifdef LONG_FLOAT_WIDETAG
2226     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2227 #endif
2228     sizetab[COMPLEX_WIDETAG] = size_boxed;
2229 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2230     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2231 #endif
2232 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2233     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2234 #endif
2235 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2236     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2237 #endif
2238     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2239     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2240 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2241     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2242 #endif
2243     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2244     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2245     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2246     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2247         size_vector_unsigned_byte_2;
2248     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2249         size_vector_unsigned_byte_4;
2250     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2251         size_vector_unsigned_byte_8;
2252     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2253         size_vector_unsigned_byte_8;
2254     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2255         size_vector_unsigned_byte_16;
2256     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2257         size_vector_unsigned_byte_16;
2258 #if (N_WORD_BITS == 32)
2259     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2260         size_vector_unsigned_byte_32;
2261 #endif
2262     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2263         size_vector_unsigned_byte_32;
2264     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2265         size_vector_unsigned_byte_32;
2266 #if (N_WORD_BITS == 64)
2267     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2268         size_vector_unsigned_byte_64;
2269 #endif
2270 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2271     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2272         size_vector_unsigned_byte_64;
2273 #endif
2274 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2275     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2276         size_vector_unsigned_byte_64;
2277 #endif
2278 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2279     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2280 #endif
2281 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2282     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2283         size_vector_unsigned_byte_16;
2284 #endif
2285 #if (N_WORD_BITS == 32)
2286     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2287         size_vector_unsigned_byte_32;
2288 #endif
2289 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2290     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2291         size_vector_unsigned_byte_32;
2292 #endif
2293 #if (N_WORD_BITS == 64)
2294     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2295         size_vector_unsigned_byte_64;
2296 #endif
2297 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2298     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2299         size_vector_unsigned_byte_64;
2300 #endif
2301     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2302     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2303 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2304     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2305 #endif
2306 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2307     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2308         size_vector_complex_single_float;
2309 #endif
2310 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2311     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2312         size_vector_complex_double_float;
2313 #endif
2314 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2315     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2316         size_vector_complex_long_float;
2317 #endif
2318     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2319 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2320     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2321 #endif
2322     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2323     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2324     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2325     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2326     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2327 #if 0
2328     /* We shouldn't see these, so just lose if it happens. */
2329     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2330     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2331 #endif
2332     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2333     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2334     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2335     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2336     sizetab[CHARACTER_WIDETAG] = size_immediate;
2337     sizetab[SAP_WIDETAG] = size_unboxed;
2338 #ifdef SIMD_PACK_WIDETAG
2339     sizetab[SIMD_PACK_WIDETAG] = size_unboxed;
2340 #endif
2341     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2342     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2343     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2344     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2345     sizetab[FDEFN_WIDETAG] = size_boxed;
2346 }
2347
2348 \f
2349 /* Find the code object for the given pc, or return NULL on
2350    failure. */
2351 lispobj *
2352 component_ptr_from_pc(lispobj *pc)
2353 {
2354     lispobj *object = NULL;
2355
2356     if ( (object = search_read_only_space(pc)) )
2357         ;
2358     else if ( (object = search_static_space(pc)) )
2359         ;
2360     else
2361         object = search_dynamic_space(pc);
2362
2363     if (object) /* if we found something */
2364         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2365             return(object);
2366
2367     return (NULL);
2368 }
2369
2370 /* Scan an area looking for an object which encloses the given pointer.
2371  * Return the object start on success or NULL on failure. */
2372 lispobj *
2373 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2374 {
2375     while (words > 0) {
2376         size_t count = 1;
2377         lispobj thing = *start;
2378
2379         /* If thing is an immediate then this is a cons. */
2380         if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
2381             count = 2;
2382         else
2383             count = (sizetab[widetag_of(thing)])(start);
2384
2385         /* Check whether the pointer is within this object. */
2386         if ((pointer >= start) && (pointer < (start+count))) {
2387             /* found it! */
2388             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2389             return(start);
2390         }
2391
2392         /* Round up the count. */
2393         count = CEILING(count,2);
2394
2395         start += count;
2396         words -= count;
2397     }
2398     return (NULL);
2399 }
2400
2401 /* Helper for valid_lisp_pointer_p (below) and
2402  * possibly_valid_dynamic_space_pointer (gencgc).
2403  *
2404  * pointer is the pointer to validate, and start_addr is the address
2405  * of the enclosing object.
2406  */
2407 int
2408 looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr)
2409 {
2410     if (!is_lisp_pointer(pointer)) {
2411         return 0;
2412     }
2413
2414     /* Check that the object pointed to is consistent with the pointer
2415      * low tag. */
2416     switch (lowtag_of(pointer)) {
2417     case FUN_POINTER_LOWTAG:
2418         /* Start_addr should be the enclosing code object, or a closure
2419          * header. */
2420         switch (widetag_of(*start_addr)) {
2421         case CODE_HEADER_WIDETAG:
2422             /* Make sure we actually point to a function in the code object,
2423              * as opposed to a random point there. */
2424             if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(native_pointer(pointer)[0]))
2425                 return 1;
2426             else
2427                 return 0;
2428         case CLOSURE_HEADER_WIDETAG:
2429         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2430             if (pointer != make_lispobj(start_addr, FUN_POINTER_LOWTAG)) {
2431                 return 0;
2432             }
2433             break;
2434         default:
2435             return 0;
2436         }
2437         break;
2438     case LIST_POINTER_LOWTAG:
2439         if (pointer != make_lispobj(start_addr, LIST_POINTER_LOWTAG)) {
2440             return 0;
2441         }
2442         /* Is it plausible cons? */
2443         if ((is_lisp_pointer(start_addr[0]) ||
2444              is_lisp_immediate(start_addr[0])) &&
2445             (is_lisp_pointer(start_addr[1]) ||
2446              is_lisp_immediate(start_addr[1])))
2447             break;
2448         else {
2449             return 0;
2450         }
2451     case INSTANCE_POINTER_LOWTAG:
2452         if (pointer != make_lispobj(start_addr, INSTANCE_POINTER_LOWTAG)) {
2453             return 0;
2454         }
2455         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2456             return 0;
2457         }
2458         break;
2459     case OTHER_POINTER_LOWTAG:
2460
2461 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2462         /* The all-architecture test below is good as far as it goes,
2463          * but an LRA object is similar to a FUN-POINTER: It is
2464          * embedded within a CODE-OBJECT pointed to by start_addr, and
2465          * cannot be found by simply walking the heap, therefore we
2466          * need to check for it. -- AB, 2010-Jun-04 */
2467         if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
2468             lispobj *potential_lra = native_pointer(pointer);
2469             if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
2470                 ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
2471                 return 1; /* It's as good as we can verify. */
2472             }
2473         }
2474 #endif
2475
2476         if (pointer != make_lispobj(start_addr, OTHER_POINTER_LOWTAG)) {
2477             return 0;
2478         }
2479         /* Is it plausible?  Not a cons. XXX should check the headers. */
2480         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2481             return 0;
2482         }
2483         switch (widetag_of(start_addr[0])) {
2484         case UNBOUND_MARKER_WIDETAG:
2485         case NO_TLS_VALUE_MARKER_WIDETAG:
2486         case CHARACTER_WIDETAG:
2487 #if N_WORD_BITS == 64
2488         case SINGLE_FLOAT_WIDETAG:
2489 #endif
2490             return 0;
2491
2492             /* only pointed to by function pointers? */
2493         case CLOSURE_HEADER_WIDETAG:
2494         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2495             return 0;
2496
2497         case INSTANCE_HEADER_WIDETAG:
2498             return 0;
2499
2500             /* the valid other immediate pointer objects */
2501         case SIMPLE_VECTOR_WIDETAG:
2502         case RATIO_WIDETAG:
2503         case COMPLEX_WIDETAG:
2504 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2505         case COMPLEX_SINGLE_FLOAT_WIDETAG:
2506 #endif
2507 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2508         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2509 #endif
2510 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2511         case COMPLEX_LONG_FLOAT_WIDETAG:
2512 #endif
2513 #ifdef SIMD_PACK_WIDETAG
2514         case SIMD_PACK_WIDETAG:
2515 #endif
2516         case SIMPLE_ARRAY_WIDETAG:
2517         case COMPLEX_BASE_STRING_WIDETAG:
2518 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2519         case COMPLEX_CHARACTER_STRING_WIDETAG:
2520 #endif
2521         case COMPLEX_VECTOR_NIL_WIDETAG:
2522         case COMPLEX_BIT_VECTOR_WIDETAG:
2523         case COMPLEX_VECTOR_WIDETAG:
2524         case COMPLEX_ARRAY_WIDETAG:
2525         case VALUE_CELL_HEADER_WIDETAG:
2526         case SYMBOL_HEADER_WIDETAG:
2527         case FDEFN_WIDETAG:
2528         case CODE_HEADER_WIDETAG:
2529         case BIGNUM_WIDETAG:
2530 #if N_WORD_BITS != 64
2531         case SINGLE_FLOAT_WIDETAG:
2532 #endif
2533         case DOUBLE_FLOAT_WIDETAG:
2534 #ifdef LONG_FLOAT_WIDETAG
2535         case LONG_FLOAT_WIDETAG:
2536 #endif
2537         case SIMPLE_BASE_STRING_WIDETAG:
2538 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2539         case SIMPLE_CHARACTER_STRING_WIDETAG:
2540 #endif
2541         case SIMPLE_BIT_VECTOR_WIDETAG:
2542         case SIMPLE_ARRAY_NIL_WIDETAG:
2543         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2544         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2545         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2546         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2547         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2548         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2549
2550         case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
2551
2552         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2553         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2554 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2555         case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2556 #endif
2557 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2558         case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2559 #endif
2560 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2561         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2562 #endif
2563 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2564         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2565 #endif
2566
2567         case SIMPLE_ARRAY_FIXNUM_WIDETAG:
2568
2569 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2570         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2571 #endif
2572 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2573         case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2574 #endif
2575         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2576         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2577 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2578         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2579 #endif
2580 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2581         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2582 #endif
2583 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2584         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2585 #endif
2586 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2587         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2588 #endif
2589         case SAP_WIDETAG:
2590         case WEAK_POINTER_WIDETAG:
2591             break;
2592
2593         default:
2594             return 0;
2595         }
2596         break;
2597     default:
2598         return 0;
2599     }
2600
2601     /* looks good */
2602     return 1;
2603 }
2604
2605 /* Used by the debugger to validate possibly bogus pointers before
2606  * calling MAKE-LISP-OBJ on them.
2607  *
2608  * FIXME: We would like to make this perfect, because if the debugger
2609  * constructs a reference to a bugs lisp object, and it ends up in a
2610  * location scavenged by the GC all hell breaks loose.
2611  *
2612  * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2613  * and return true for all valid pointers, this could actually be eager
2614  * and lie about a few pointers without bad results... but that should
2615  * be reflected in the name.
2616  */
2617 int
2618 valid_lisp_pointer_p(lispobj *pointer)
2619 {
2620     lispobj *start;
2621     if (((start=search_dynamic_space(pointer))!=NULL) ||
2622         ((start=search_static_space(pointer))!=NULL) ||
2623         ((start=search_read_only_space(pointer))!=NULL))
2624         return looks_like_valid_lisp_pointer_p((lispobj)pointer, start);
2625     else
2626         return 0;
2627 }
2628
2629 boolean
2630 maybe_gc(os_context_t *context)
2631 {
2632     lispobj gc_happened;
2633     struct thread *thread = arch_os_get_current_thread();
2634
2635     fake_foreign_function_call(context);
2636     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2637      * which case we will be running with no gc trigger barrier
2638      * thing for a while.  But it shouldn't be long until the end
2639      * of WITHOUT-GCING.
2640      *
2641      * FIXME: It would be good to protect the end of dynamic space for
2642      * CheneyGC and signal a storage condition from there.
2643      */
2644
2645     /* Restore the signal mask from the interrupted context before
2646      * calling into Lisp if interrupts are enabled. Why not always?
2647      *
2648      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2649      * interrupt hits while in SUB-GC, it is deferred and the
2650      * os_context_sigmask of that interrupt is set to block further
2651      * deferrable interrupts (until the first one is
2652      * handled). Unfortunately, that context refers to this place and
2653      * when we return from here the signals will not be blocked.
2654      *
2655      * A kludgy alternative is to propagate the sigmask change to the
2656      * outer context.
2657      */
2658 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2659     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2660     unblock_gc_signals(0, 0);
2661 #endif
2662     FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2663     /* FIXME: Nothing must go wrong during GC else we end up running
2664      * the debugger, error handlers, and user code in general in a
2665      * potentially unsafe place. Running out of the control stack or
2666      * the heap in SUB-GC are ways to lose. Of course, deferrables
2667      * cannot be unblocked because there may be a pending handler, or
2668      * we may even be in a WITHOUT-INTERRUPTS. */
2669     gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2670     FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2671            (gc_happened == NIL) ? "NIL" : "T"));
2672     if ((gc_happened != NIL) &&
2673         /* See if interrupts are enabled or it's possible to enable
2674          * them. POST-GC has a similar check, but we don't want to
2675          * unlock deferrables in that case and get a pending interrupt
2676          * here. */
2677         ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2678          (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2679 #ifndef LISP_FEATURE_WIN32
2680         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2681         if (!deferrables_blocked_p(context_sigmask)) {
2682             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2683 #ifndef LISP_FEATURE_SB_SAFEPOINT
2684             check_gc_signals_unblocked_or_lose(0);
2685 #endif
2686 #endif
2687             FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2688             funcall0(StaticSymbolFunction(POST_GC));
2689 #ifndef LISP_FEATURE_WIN32
2690         } else {
2691             FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2692         }
2693 #endif
2694     }
2695     undo_fake_foreign_function_call(context);
2696     FSHOW((stderr, "/maybe_gc: returning\n"));
2697     return (gc_happened != NIL);
2698 }
2699
2700 #define BYTES_ZERO_BEFORE_END (1<<12)
2701
2702 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2703  * Lisp and another called zero_stack() in cheneygc.c, but since it's
2704  * shorter to express in, and more often called from C, I keep only
2705  * the C one after fixing it. -- MG 2009-03-25 */
2706
2707 /* Zero the unused portion of the control stack so that old objects
2708  * are not kept alive because of uninitialized stack variables.
2709  *
2710  * "To summarize the problem, since not all allocated stack frame
2711  * slots are guaranteed to be written by the time you call an another
2712  * function or GC, there may be garbage pointers retained in your dead
2713  * stack locations. The stack scrubbing only affects the part of the
2714  * stack from the SP to the end of the allocated stack." - ram, on
2715  * cmucl-imp, Tue, 25 Sep 2001
2716  *
2717  * So, as an (admittedly lame) workaround, from time to time we call
2718  * scrub-control-stack to zero out all the unused portion. This is
2719  * supposed to happen when the stack is mostly empty, so that we have
2720  * a chance of clearing more of it: callers are currently (2002.07.18)
2721  * REPL, SUB-GC and sig_stop_for_gc_handler. */
2722
2723 /* Take care not to tread on the guard page and the hard guard page as
2724  * it would be unkind to sig_stop_for_gc_handler. Touching the return
2725  * guard page is not dangerous. For this to work the guard page must
2726  * be zeroed when protected. */
2727
2728 /* FIXME: I think there is no guarantee that once
2729  * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2730  * may be what the "lame" adjective in the above comment is for. In
2731  * this case, exact gc may lose badly. */
2732 void
2733 scrub_control_stack()
2734 {
2735     scrub_thread_control_stack(arch_os_get_current_thread());
2736 }
2737
2738 void
2739 scrub_thread_control_stack(struct thread *th)
2740 {
2741     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2742     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2743 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2744     /* On these targets scrubbing from C is a bad idea, so we punt to
2745      * a routine in $ARCH-assem.S. */
2746     extern void arch_scrub_control_stack(struct thread *, os_vm_address_t, os_vm_address_t);
2747     arch_scrub_control_stack(th, guard_page_address, hard_guard_page_address);
2748 #else
2749     lispobj *sp = access_control_stack_pointer(th);
2750  scrub:
2751     if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2752          ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2753         (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2754          ((os_vm_address_t)sp >= guard_page_address) &&
2755          (th->control_stack_guard_page_protected != NIL)))
2756         return;
2757 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2758     do {
2759         *sp = 0;
2760     } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2761     if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2762         return;
2763     do {
2764         if (*sp)
2765             goto scrub;
2766     } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2767 #else
2768     do {
2769         *sp = 0;
2770     } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2771     if ((os_vm_address_t)sp >= hard_guard_page_address)
2772         return;
2773     do {
2774         if (*sp)
2775             goto scrub;
2776     } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2777 #endif
2778 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2779 }
2780 \f
2781 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2782
2783 void
2784 scavenge_control_stack(struct thread *th)
2785 {
2786     lispobj *object_ptr;
2787
2788     /* In order to properly support dynamic-extent allocation of
2789      * non-CONS objects, the control stack requires special handling.
2790      * Rather than calling scavenge() directly, grovel over it fixing
2791      * broken hearts, scavenging pointers to oldspace, and pitching a
2792      * fit when encountering unboxed data.  This prevents stray object
2793      * headers from causing the scavenger to blow past the end of the
2794      * stack (an error case checked in scavenge()).  We don't worry
2795      * about treating unboxed words as boxed or vice versa, because
2796      * the compiler isn't allowed to store unboxed objects on the
2797      * control stack.  -- AB, 2011-Dec-02 */
2798
2799     for (object_ptr = th->control_stack_start;
2800          object_ptr < access_control_stack_pointer(th);
2801          object_ptr++) {
2802
2803         lispobj object = *object_ptr;
2804 #ifdef LISP_FEATURE_GENCGC
2805         if (forwarding_pointer_p(object_ptr))
2806             lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
2807                  object_ptr, th->control_stack_start, access_control_stack_pointer(th));
2808 #endif
2809         if (is_lisp_pointer(object) && from_space_p(object)) {
2810             /* It currently points to old space. Check for a
2811              * forwarding pointer. */
2812             lispobj *ptr = native_pointer(object);
2813             if (forwarding_pointer_p(ptr)) {
2814                 /* Yes, there's a forwarding pointer. */
2815                 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
2816             } else {
2817                 /* Scavenge that pointer. */
2818                 long n_words_scavenged =
2819                     (scavtab[widetag_of(object)])(object_ptr, object);
2820                 gc_assert(n_words_scavenged == 1);
2821             }
2822         } else if (scavtab[widetag_of(object)] == scav_lose) {
2823             lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
2824                  object_ptr, object, th->control_stack_start, access_control_stack_pointer(th));
2825         }
2826     }
2827 }
2828
2829 /* Scavenging Interrupt Contexts */
2830
2831 static int boxed_registers[] = BOXED_REGISTERS;
2832
2833 /* The GC has a notion of an "interior pointer" register, an unboxed
2834  * register that typically contains a pointer to inside an object
2835  * referenced by another pointer.  The most obvious of these is the
2836  * program counter, although many compiler backends define a "Lisp
2837  * Interior Pointer" register known to the runtime as reg_LIP, and
2838  * various CPU architectures have other registers that also partake of
2839  * the interior-pointer nature.  As the code for pairing an interior
2840  * pointer value up with its "base" register, and fixing it up after
2841  * scavenging is complete is horribly repetitive, a few macros paper
2842  * over the monotony.  --AB, 2010-Jul-14 */
2843
2844 /* These macros are only ever used over a lexical environment which
2845  * defines a pointer to an os_context_t called context, thus we don't
2846  * bother to pass that context in as a parameter. */
2847
2848 /* Define how to access a given interior pointer. */
2849 #define ACCESS_INTERIOR_POINTER_pc \
2850     *os_context_pc_addr(context)
2851 #define ACCESS_INTERIOR_POINTER_lip \
2852     *os_context_register_addr(context, reg_LIP)
2853 #define ACCESS_INTERIOR_POINTER_lr \
2854     *os_context_lr_addr(context)
2855 #define ACCESS_INTERIOR_POINTER_npc \
2856     *os_context_npc_addr(context)
2857 #define ACCESS_INTERIOR_POINTER_ctr \
2858     *os_context_ctr_addr(context)
2859
2860 #define INTERIOR_POINTER_VARS(name) \
2861     uword_t name##_offset;    \
2862     int name##_register_pair
2863
2864 #define PAIR_INTERIOR_POINTER(name)                             \
2865     pair_interior_pointer(context,                              \
2866                           ACCESS_INTERIOR_POINTER_##name,       \
2867                           &name##_offset,                       \
2868                           &name##_register_pair)
2869
2870 /* One complexity here is that if a paired register is not found for
2871  * an interior pointer, then that pointer does not get updated.
2872  * Originally, there was some commentary about using an index of -1
2873  * when calling os_context_register_addr() on SPARC referring to the
2874  * program counter, but the real reason is to allow an interior
2875  * pointer register to point to the runtime, read-only space, or
2876  * static space without problems. */
2877 #define FIXUP_INTERIOR_POINTER(name)                                    \
2878     do {                                                                \
2879         if (name##_register_pair >= 0) {                                \
2880             ACCESS_INTERIOR_POINTER_##name =                            \
2881                 (*os_context_register_addr(context,                     \
2882                                            name##_register_pair)        \
2883                  & ~LOWTAG_MASK)                                        \
2884                 + name##_offset;                                        \
2885         }                                                               \
2886     } while (0)
2887
2888
2889 static void
2890 pair_interior_pointer(os_context_t *context, uword_t pointer,
2891                       uword_t *saved_offset, int *register_pair)
2892 {
2893     int i;
2894
2895     /*
2896      * I (RLT) think this is trying to find the boxed register that is
2897      * closest to the LIP address, without going past it.  Usually, it's
2898      * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2899      */
2900     /* 0x7FFFFFFF on 32-bit platforms;
2901        0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2902     *saved_offset = (((uword_t)1) << (N_WORD_BITS - 1)) - 1;
2903     *register_pair = -1;
2904     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2905         uword_t reg;
2906         sword_t offset;
2907         int index;
2908
2909         index = boxed_registers[i];
2910         reg = *os_context_register_addr(context, index);
2911
2912         /* An interior pointer is never relative to a non-pointer
2913          * register (an oversight in the original implementation).
2914          * The simplest argument for why this is true is to consider
2915          * the fixnum that happens by coincide to be the word-index in
2916          * memory of the header for some object plus two.  This is
2917          * happenstance would cause the register containing the fixnum
2918          * to be selected as the register_pair if the interior pointer
2919          * is to anywhere after the first two words of the object.
2920          * The fixnum won't be changed during GC, but the object might
2921          * move, thus destroying the interior pointer.  --AB,
2922          * 2010-Jul-14 */
2923
2924         if (is_lisp_pointer(reg) &&
2925             ((reg & ~LOWTAG_MASK) <= pointer)) {
2926             offset = pointer - (reg & ~LOWTAG_MASK);
2927             if (offset < *saved_offset) {
2928                 *saved_offset = offset;
2929                 *register_pair = index;
2930             }
2931         }
2932     }
2933 }
2934
2935 static void
2936 scavenge_interrupt_context(os_context_t * context)
2937 {
2938     int i;
2939
2940     /* FIXME: The various #ifdef noise here is precisely that: noise.
2941      * Is it possible to fold it into the macrology so that we have
2942      * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2943      * compile out for the registers that don't exist on a given
2944      * platform? */
2945
2946     INTERIOR_POINTER_VARS(pc);
2947 #ifdef reg_LIP
2948     INTERIOR_POINTER_VARS(lip);
2949 #endif
2950 #ifdef ARCH_HAS_LINK_REGISTER
2951     INTERIOR_POINTER_VARS(lr);
2952 #endif
2953 #ifdef ARCH_HAS_NPC_REGISTER
2954     INTERIOR_POINTER_VARS(npc);
2955 #endif
2956 #ifdef LISP_FEATURE_PPC
2957     INTERIOR_POINTER_VARS(ctr);
2958 #endif
2959
2960     PAIR_INTERIOR_POINTER(pc);
2961 #ifdef reg_LIP
2962     PAIR_INTERIOR_POINTER(lip);
2963 #endif
2964 #ifdef ARCH_HAS_LINK_REGISTER
2965     PAIR_INTERIOR_POINTER(lr);
2966 #endif
2967 #ifdef ARCH_HAS_NPC_REGISTER
2968     PAIR_INTERIOR_POINTER(npc);
2969 #endif
2970 #ifdef LISP_FEATURE_PPC
2971     PAIR_INTERIOR_POINTER(ctr);
2972 #endif
2973
2974     /* Scavenge all boxed registers in the context. */
2975     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2976         int index;
2977         lispobj foo;
2978
2979         index = boxed_registers[i];
2980         foo = *os_context_register_addr(context, index);
2981         scavenge(&foo, 1);
2982         *os_context_register_addr(context, index) = foo;
2983
2984         /* this is unlikely to work as intended on bigendian
2985          * 64 bit platforms */
2986
2987         scavenge((lispobj *) os_context_register_addr(context, index), 1);
2988     }
2989
2990     /* Now that the scavenging is done, repair the various interior
2991      * pointers. */
2992     FIXUP_INTERIOR_POINTER(pc);
2993 #ifdef reg_LIP
2994     FIXUP_INTERIOR_POINTER(lip);
2995 #endif
2996 #ifdef ARCH_HAS_LINK_REGISTER
2997     FIXUP_INTERIOR_POINTER(lr);
2998 #endif
2999 #ifdef ARCH_HAS_NPC_REGISTER
3000     FIXUP_INTERIOR_POINTER(npc);
3001 #endif
3002 #ifdef LISP_FEATURE_PPC
3003     FIXUP_INTERIOR_POINTER(ctr);
3004 #endif
3005 }
3006
3007 void
3008 scavenge_interrupt_contexts(struct thread *th)
3009 {
3010     int i, index;
3011     os_context_t *context;
3012
3013     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
3014
3015 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3016     printf("Number of active contexts: %d\n", index);
3017 #endif
3018
3019     for (i = 0; i < index; i++) {
3020         context = th->interrupt_contexts[i];
3021         scavenge_interrupt_context(context);
3022     }
3023 }
3024 #endif /* x86oid targets */