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 long (*scavtab[256])(lispobj *where, lispobj object);
  89 lispobj (*transother[256])(lispobj object);
  90 long (*sizetab[256])(lispobj *where);
  91 struct weak_pointer *weak_pointers;
  92
  93 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, long nwords)
 104 {
 105     return gc_general_copy_object(object, nwords, BOXED_PAGE_FLAG);
 106 }
 107
 108 lispobj
 109 copy_code_object(lispobj object, long nwords)
 110 {
 111     return gc_general_copy_object(object, nwords, CODE_PAGE_FLAG);
 112 }
 113
 114 static long 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, long n_words)
 121 {
 122     lispobj *end = start + n_words;
 123     lispobj *object_ptr;
 124     long 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 long
 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     long nheader_words, ncode_words, nwords;
 240     unsigned long 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            (unsigned long) code, (unsigned long) 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) (((long *)new_code) + nheader_words),
 321                     ncode_words * sizeof(long));
 322
 323 #endif
 324
 325 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 326     gencgc_apply_code_fixups(code, new_code);
 327 #endif
 328
 329     return new_code;
 330 }
 331
 332 static long
 333 scav_code_header(lispobj *where, lispobj object)
 334 {
 335     struct code *code;
 336     long 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                           (long)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 long
 382 size_code_header(lispobj *where)
 383 {
 384     struct code *code;
 385     long 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 long
 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          (unsigned long) where,
 403          (unsigned long) 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     unsigned long 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 *) ((unsigned long) 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 long
 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 long
 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          (unsigned long) where,
 458          (unsigned long) 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     unsigned long 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 *) ((unsigned long) 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 long
 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 long
 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 long
 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 long
 627 size_pointer(lispobj *where)
 628 {
 629     return 1;
 630 }
 631
 632 static long
 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 long
 646 size_immediate(lispobj *where)
 647 {
 648     return 1;
 649 }
 650
 651
 652 static long
 653 scav_boxed(lispobj *where, lispobj object)
 654 {
 655     return 1;
 656 }
 657
 658 static long
 659 scav_instance(lispobj *where, lispobj object)
 660 {
 661     lispobj nuntagged;
 662     long 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     unsigned long 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 long
 693 size_boxed(lispobj *where)
 694 {
 695     lispobj header;
 696     unsigned long 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 long
 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 long
 736 scav_unboxed(lispobj *where, lispobj object)
 737 {
 738     unsigned long 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     unsigned long 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 long
 763 size_unboxed(lispobj *where)
 764 {
 765     lispobj header;
 766     unsigned long 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 long
 778 scav_base_string(lispobj *where, lispobj object)
 779 {
 780     struct vector *vector;
 781     long 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     long 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 long
 812 size_base_string(lispobj *where)
 813 {
 814     struct vector *vector;
 815     long 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 long
 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 long
 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     long 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 long
 896 size_vector(lispobj *where)
 897 {
 898     struct vector *vector;
 899     long 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 long
 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 long
 922 size_vector_nil(lispobj *where)
 923 {
 924     /* Just the header word and the length word */
 925     return 2;
 926 }
 927
 928 static long
 929 scav_vector_bit(lispobj *where, lispobj object)
 930 {
 931     struct vector *vector;
 932     long 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     long 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 long
 957 size_vector_bit(lispobj *where)
 958 {
 959     struct vector *vector;
 960     long 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 long
 970 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 971 {
 972     struct vector *vector;
 973     long 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     long 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 long
 998 size_vector_unsigned_byte_2(lispobj *where)
 999 {
1000     struct vector *vector;
1001     long 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 long
1011 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1012 {
1013     struct vector *vector;
1014     long 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     long 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 long
1038 size_vector_unsigned_byte_4(lispobj *where)
1039 {
1040     struct vector *vector;
1041     long 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 long
1052 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1053 {
1054     struct vector *vector;
1055     long 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     long 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 long
1084 size_vector_unsigned_byte_8(lispobj *where)
1085 {
1086     struct vector *vector;
1087     long 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 long
1098 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1099 {
1100     struct vector *vector;
1101     long 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     long 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 long
1126 size_vector_unsigned_byte_16(lispobj *where)
1127 {
1128     struct vector *vector;
1129     long 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 long
1139 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1140 {
1141     struct vector *vector;
1142     long 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     long 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 long
1167 size_vector_unsigned_byte_32(lispobj *where)
1168 {
1169     struct vector *vector;
1170     long 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 long
1181 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1182 {
1183     struct vector *vector;
1184     long 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     long 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 long
1209 size_vector_unsigned_byte_64(lispobj *where)
1210 {
1211     struct vector *vector;
1212     long 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 long
1223 scav_vector_single_float(lispobj *where, lispobj object)
1224 {
1225     struct vector *vector;
1226     long 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     long 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 long
1251 size_vector_single_float(lispobj *where)
1252 {
1253     struct vector *vector;
1254     long 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 long
1264 scav_vector_double_float(lispobj *where, lispobj object)
1265 {
1266     struct vector *vector;
1267     long 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     long 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 long
1292 size_vector_double_float(lispobj *where)
1293 {
1294     struct vector *vector;
1295     long 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     long 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 long
1351 scav_vector_complex_single_float(lispobj *where, lispobj object)
1352 {
1353     struct vector *vector;
1354     long 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     long 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 long
1379 size_vector_complex_single_float(lispobj *where)
1380 {
1381     struct vector *vector;
1382     long 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 long
1394 scav_vector_complex_double_float(lispobj *where, lispobj object)
1395 {
1396     struct vector *vector;
1397     long 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     long 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 long
1422 size_vector_complex_double_float(lispobj *where)
1423 {
1424     struct vector *vector;
1425     long 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     long 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 long
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, unsigned long *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     unsigned long kv_length;
1626     lispobj *index_vector;
1627     unsigned long length;
1628     lispobj *next_vector;
1629     unsigned long next_vector_length;
1630     lispobj *hash_vector;
1631     unsigned long hash_vector_length;
1632     lispobj empty_symbol;
1633     lispobj weakness = hash_table->weakness;
1634     unsigned long 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 long
1695 scav_vector (lispobj *where, lispobj object)
1696 {
1697     unsigned long 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 %lx 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", (unsigned long)&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     unsigned long length = 0; /* prevent warning */
1818     lispobj *next_vector;
1819     unsigned long next_vector_length = 0; /* prevent warning */
1820     lispobj *hash_vector;
1821     lispobj empty_symbol;
1822     lispobj weakness = hash_table->weakness;
1823     unsigned long 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 long
1864 scav_lose(lispobj *where, lispobj object)
1865 {
1866     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1867          (unsigned long)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          (unsigned long)object,
1878          widetag_of(*(lispobj*)native_pointer(object)));
1879     return NIL; /* bogus return value to satisfy static type checking */
1880 }
1881
1882 static long
1883 size_lose(lispobj *where)
1884 {
1885     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1886          (unsigned long)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     unsigned long 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     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1952     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1953 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1954     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1955 #endif
1956     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1957     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1958     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1959         scav_vector_unsigned_byte_2;
1960     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1961         scav_vector_unsigned_byte_4;
1962     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1963         scav_vector_unsigned_byte_8;
1964     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1965         scav_vector_unsigned_byte_8;
1966     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1967         scav_vector_unsigned_byte_16;
1968     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1969         scav_vector_unsigned_byte_16;
1970 #if (N_WORD_BITS == 32)
1971     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1972         scav_vector_unsigned_byte_32;
1973 #endif
1974     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1975         scav_vector_unsigned_byte_32;
1976     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1977         scav_vector_unsigned_byte_32;
1978 #if (N_WORD_BITS == 64)
1979     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1980         scav_vector_unsigned_byte_64;
1981 #endif
1982 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1983     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1984         scav_vector_unsigned_byte_64;
1985 #endif
1986 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1987     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1988         scav_vector_unsigned_byte_64;
1989 #endif
1990 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1991     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1992 #endif
1993 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1994     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1995         scav_vector_unsigned_byte_16;
1996 #endif
1997 #if (N_WORD_BITS == 32)
1998     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
1999         scav_vector_unsigned_byte_32;
2000 #endif
2001 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2002     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2003         scav_vector_unsigned_byte_32;
2004 #endif
2005 #if (N_WORD_BITS == 64)
2006     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2007         scav_vector_unsigned_byte_64;
2008 #endif
2009 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2010     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2011         scav_vector_unsigned_byte_64;
2012 #endif
2013     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2014     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2015 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2016     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2017 #endif
2018 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2019     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2020         scav_vector_complex_single_float;
2021 #endif
2022 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2023     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2024         scav_vector_complex_double_float;
2025 #endif
2026 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2027     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2028         scav_vector_complex_long_float;
2029 #endif
2030     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2031 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2032     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2033 #endif
2034     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2035     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2036     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2037     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2038     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2039 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2040     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2041     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2042 #endif
2043     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2044 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2045     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2046 #else
2047     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2048 #endif
2049     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2050     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2051     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2052     scavtab[SAP_WIDETAG] = scav_unboxed;
2053     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2054     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2055     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2056 #if defined(LISP_FEATURE_SPARC)
2057     scavtab[FDEFN_WIDETAG] = scav_boxed;
2058 #else
2059     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2060 #endif
2061     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2062
2063     /* transport other table, initialized same way as scavtab */
2064     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2065         transother[i] = trans_lose;
2066     transother[BIGNUM_WIDETAG] = trans_unboxed;
2067     transother[RATIO_WIDETAG] = trans_boxed;
2068
2069 #if N_WORD_BITS == 64
2070     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2071 #else
2072     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2073 #endif
2074     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2075 #ifdef LONG_FLOAT_WIDETAG
2076     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2077 #endif
2078     transother[COMPLEX_WIDETAG] = trans_boxed;
2079 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2080     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2081 #endif
2082 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2083     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2084 #endif
2085 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2086     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2087 #endif
2088     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2089     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2090 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2091     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2092 #endif
2093     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2094     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2095     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2096     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2097         trans_vector_unsigned_byte_2;
2098     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2099         trans_vector_unsigned_byte_4;
2100     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2101         trans_vector_unsigned_byte_8;
2102     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2103         trans_vector_unsigned_byte_8;
2104     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2105         trans_vector_unsigned_byte_16;
2106     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2107         trans_vector_unsigned_byte_16;
2108 #if (N_WORD_BITS == 32)
2109     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2110         trans_vector_unsigned_byte_32;
2111 #endif
2112     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2113         trans_vector_unsigned_byte_32;
2114     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2115         trans_vector_unsigned_byte_32;
2116 #if (N_WORD_BITS == 64)
2117     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2118         trans_vector_unsigned_byte_64;
2119 #endif
2120 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2121     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2122         trans_vector_unsigned_byte_64;
2123 #endif
2124 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2125     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2126         trans_vector_unsigned_byte_64;
2127 #endif
2128 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2129     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2130         trans_vector_unsigned_byte_8;
2131 #endif
2132 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2133     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2134         trans_vector_unsigned_byte_16;
2135 #endif
2136 #if (N_WORD_BITS == 32)
2137     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2138         trans_vector_unsigned_byte_32;
2139 #endif
2140 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2141     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2142         trans_vector_unsigned_byte_32;
2143 #endif
2144 #if (N_WORD_BITS == 64)
2145     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2146         trans_vector_unsigned_byte_64;
2147 #endif
2148 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2149     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2150         trans_vector_unsigned_byte_64;
2151 #endif
2152     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2153         trans_vector_single_float;
2154     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2155         trans_vector_double_float;
2156 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2157     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2158         trans_vector_long_float;
2159 #endif
2160 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2161     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2162         trans_vector_complex_single_float;
2163 #endif
2164 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2165     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2166         trans_vector_complex_double_float;
2167 #endif
2168 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2169     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2170         trans_vector_complex_long_float;
2171 #endif
2172     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2173 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2174     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2175 #endif
2176     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2177     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2178     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2179     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2180     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2181     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2182     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2183     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2184     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2185     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2186     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2187     transother[CHARACTER_WIDETAG] = trans_immediate;
2188     transother[SAP_WIDETAG] = trans_unboxed;
2189     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2190     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2191     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2192     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2193     transother[FDEFN_WIDETAG] = trans_boxed;
2194
2195     /* size table, initialized the same way as scavtab */
2196     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2197         sizetab[i] = size_lose;
2198     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2199         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
2200             if (fixnump(j)) {
2201                 sizetab[j|(i<<N_LOWTAG_BITS)] = size_immediate;
2202             }
2203         }
2204         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2205         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2206         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2207         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2208         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2209         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2210     }
2211     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2212     sizetab[RATIO_WIDETAG] = size_boxed;
2213 #if N_WORD_BITS == 64
2214     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2215 #else
2216     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2217 #endif
2218     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2219 #ifdef LONG_FLOAT_WIDETAG
2220     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2221 #endif
2222     sizetab[COMPLEX_WIDETAG] = size_boxed;
2223 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2224     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2225 #endif
2226 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2227     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2228 #endif
2229 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2230     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2231 #endif
2232     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2233     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2234 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2235     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2236 #endif
2237     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2238     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2239     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2240     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2241         size_vector_unsigned_byte_2;
2242     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2243         size_vector_unsigned_byte_4;
2244     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2245         size_vector_unsigned_byte_8;
2246     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2247         size_vector_unsigned_byte_8;
2248     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2249         size_vector_unsigned_byte_16;
2250     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2251         size_vector_unsigned_byte_16;
2252 #if (N_WORD_BITS == 32)
2253     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2254         size_vector_unsigned_byte_32;
2255 #endif
2256     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2257         size_vector_unsigned_byte_32;
2258     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2259         size_vector_unsigned_byte_32;
2260 #if (N_WORD_BITS == 64)
2261     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2262         size_vector_unsigned_byte_64;
2263 #endif
2264 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2265     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2266         size_vector_unsigned_byte_64;
2267 #endif
2268 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2269     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2270         size_vector_unsigned_byte_64;
2271 #endif
2272 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2273     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2274 #endif
2275 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2276     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2277         size_vector_unsigned_byte_16;
2278 #endif
2279 #if (N_WORD_BITS == 32)
2280     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2281         size_vector_unsigned_byte_32;
2282 #endif
2283 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2284     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2285         size_vector_unsigned_byte_32;
2286 #endif
2287 #if (N_WORD_BITS == 64)
2288     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2289         size_vector_unsigned_byte_64;
2290 #endif
2291 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2292     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2293         size_vector_unsigned_byte_64;
2294 #endif
2295     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2296     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2297 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2298     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2299 #endif
2300 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2301     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2302         size_vector_complex_single_float;
2303 #endif
2304 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2305     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2306         size_vector_complex_double_float;
2307 #endif
2308 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2309     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2310         size_vector_complex_long_float;
2311 #endif
2312     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2313 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2314     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2315 #endif
2316     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2317     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2318     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2319     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2320     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2321 #if 0
2322     /* We shouldn't see these, so just lose if it happens. */
2323     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2324     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2325 #endif
2326     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2327     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2328     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2329     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2330     sizetab[CHARACTER_WIDETAG] = size_immediate;
2331     sizetab[SAP_WIDETAG] = size_unboxed;
2332     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2333     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2334     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2335     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2336     sizetab[FDEFN_WIDETAG] = size_boxed;
2337 }
2338
2339 \f
2340 /* Find the code object for the given pc, or return NULL on
2341    failure. */
2342 lispobj *
2343 component_ptr_from_pc(lispobj *pc)
2344 {
2345     lispobj *object = NULL;
2346
2347     if ( (object = search_read_only_space(pc)) )
2348         ;
2349     else if ( (object = search_static_space(pc)) )
2350         ;
2351     else
2352         object = search_dynamic_space(pc);
2353
2354     if (object) /* if we found something */
2355         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2356             return(object);
2357
2358     return (NULL);
2359 }
2360
2361 /* Scan an area looking for an object which encloses the given pointer.
2362  * Return the object start on success or NULL on failure. */
2363 lispobj *
2364 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2365 {
2366     while (words > 0) {
2367         size_t count = 1;
2368         lispobj thing = *start;
2369
2370         /* If thing is an immediate then this is a cons. */
2371         if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
2372             count = 2;
2373         else
2374             count = (sizetab[widetag_of(thing)])(start);
2375
2376         /* Check whether the pointer is within this object. */
2377         if ((pointer >= start) && (pointer < (start+count))) {
2378             /* found it! */
2379             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2380             return(start);
2381         }
2382
2383         /* Round up the count. */
2384         count = CEILING(count,2);
2385
2386         start += count;
2387         words -= count;
2388     }
2389     return (NULL);
2390 }
2391
2392 /* Helper for valid_lisp_pointer_p (below) and
2393  * possibly_valid_dynamic_space_pointer (gencgc).
2394  *
2395  * pointer is the pointer to validate, and start_addr is the address
2396  * of the enclosing object.
2397  */
2398 int
2399 looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr)
2400 {
2401     if (!is_lisp_pointer(pointer)) {
2402         return 0;
2403     }
2404
2405     /* Check that the object pointed to is consistent with the pointer
2406      * low tag. */
2407     switch (lowtag_of(pointer)) {
2408     case FUN_POINTER_LOWTAG:
2409         /* Start_addr should be the enclosing code object, or a closure
2410          * header. */
2411         switch (widetag_of(*start_addr)) {
2412         case CODE_HEADER_WIDETAG:
2413             /* Make sure we actually point to a function in the code object,
2414              * as opposed to a random point there. */
2415             if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(native_pointer(pointer)[0]))
2416                 return 1;
2417             else
2418                 return 0;
2419         case CLOSURE_HEADER_WIDETAG:
2420         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2421             if (pointer != make_lispobj(start_addr, FUN_POINTER_LOWTAG)) {
2422                 return 0;
2423             }
2424             break;
2425         default:
2426             return 0;
2427         }
2428         break;
2429     case LIST_POINTER_LOWTAG:
2430         if (pointer != make_lispobj(start_addr, LIST_POINTER_LOWTAG)) {
2431             return 0;
2432         }
2433         /* Is it plausible cons? */
2434         if ((is_lisp_pointer(start_addr[0]) ||
2435              is_lisp_immediate(start_addr[0])) &&
2436             (is_lisp_pointer(start_addr[1]) ||
2437              is_lisp_immediate(start_addr[1])))
2438             break;
2439         else {
2440             return 0;
2441         }
2442     case INSTANCE_POINTER_LOWTAG:
2443         if (pointer != make_lispobj(start_addr, INSTANCE_POINTER_LOWTAG)) {
2444             return 0;
2445         }
2446         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2447             return 0;
2448         }
2449         break;
2450     case OTHER_POINTER_LOWTAG:
2451
2452 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2453         /* The all-architecture test below is good as far as it goes,
2454          * but an LRA object is similar to a FUN-POINTER: It is
2455          * embedded within a CODE-OBJECT pointed to by start_addr, and
2456          * cannot be found by simply walking the heap, therefore we
2457          * need to check for it. -- AB, 2010-Jun-04 */
2458         if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
2459             lispobj *potential_lra = native_pointer(pointer);
2460             if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
2461                 ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
2462                 return 1; /* It's as good as we can verify. */
2463             }
2464         }
2465 #endif
2466
2467         if (pointer != make_lispobj(start_addr, OTHER_POINTER_LOWTAG)) {
2468             return 0;
2469         }
2470         /* Is it plausible?  Not a cons. XXX should check the headers. */
2471         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2472             return 0;
2473         }
2474         switch (widetag_of(start_addr[0])) {
2475         case UNBOUND_MARKER_WIDETAG:
2476         case NO_TLS_VALUE_MARKER_WIDETAG:
2477         case CHARACTER_WIDETAG:
2478 #if N_WORD_BITS == 64
2479         case SINGLE_FLOAT_WIDETAG:
2480 #endif
2481             return 0;
2482
2483             /* only pointed to by function pointers? */
2484         case CLOSURE_HEADER_WIDETAG:
2485         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2486             return 0;
2487
2488         case INSTANCE_HEADER_WIDETAG:
2489             return 0;
2490
2491             /* the valid other immediate pointer objects */
2492         case SIMPLE_VECTOR_WIDETAG:
2493         case RATIO_WIDETAG:
2494         case COMPLEX_WIDETAG:
2495 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2496         case COMPLEX_SINGLE_FLOAT_WIDETAG:
2497 #endif
2498 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2499         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2500 #endif
2501 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2502         case COMPLEX_LONG_FLOAT_WIDETAG:
2503 #endif
2504         case SIMPLE_ARRAY_WIDETAG:
2505         case COMPLEX_BASE_STRING_WIDETAG:
2506 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2507         case COMPLEX_CHARACTER_STRING_WIDETAG:
2508 #endif
2509         case COMPLEX_VECTOR_NIL_WIDETAG:
2510         case COMPLEX_BIT_VECTOR_WIDETAG:
2511         case COMPLEX_VECTOR_WIDETAG:
2512         case COMPLEX_ARRAY_WIDETAG:
2513         case VALUE_CELL_HEADER_WIDETAG:
2514         case SYMBOL_HEADER_WIDETAG:
2515         case FDEFN_WIDETAG:
2516         case CODE_HEADER_WIDETAG:
2517         case BIGNUM_WIDETAG:
2518 #if N_WORD_BITS != 64
2519         case SINGLE_FLOAT_WIDETAG:
2520 #endif
2521         case DOUBLE_FLOAT_WIDETAG:
2522 #ifdef LONG_FLOAT_WIDETAG
2523         case LONG_FLOAT_WIDETAG:
2524 #endif
2525         case SIMPLE_BASE_STRING_WIDETAG:
2526 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2527         case SIMPLE_CHARACTER_STRING_WIDETAG:
2528 #endif
2529         case SIMPLE_BIT_VECTOR_WIDETAG:
2530         case SIMPLE_ARRAY_NIL_WIDETAG:
2531         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2532         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2533         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2534         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2535         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2536         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2537
2538         case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
2539
2540         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2541         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2542 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2543         case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2544 #endif
2545 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2546         case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2547 #endif
2548 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2549         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2550 #endif
2551 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2552         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2553 #endif
2554
2555         case SIMPLE_ARRAY_FIXNUM_WIDETAG:
2556
2557 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2558         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2559 #endif
2560 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2561         case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2562 #endif
2563         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2564         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2565 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2566         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2567 #endif
2568 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2569         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2570 #endif
2571 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2572         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2573 #endif
2574 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2575         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2576 #endif
2577         case SAP_WIDETAG:
2578         case WEAK_POINTER_WIDETAG:
2579             break;
2580
2581         default:
2582             return 0;
2583         }
2584         break;
2585     default:
2586         return 0;
2587     }
2588
2589     /* looks good */
2590     return 1;
2591 }
2592
2593 /* Used by the debugger to validate possibly bogus pointers before
2594  * calling MAKE-LISP-OBJ on them.
2595  *
2596  * FIXME: We would like to make this perfect, because if the debugger
2597  * constructs a reference to a bugs lisp object, and it ends up in a
2598  * location scavenged by the GC all hell breaks loose.
2599  *
2600  * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2601  * and return true for all valid pointers, this could actually be eager
2602  * and lie about a few pointers without bad results... but that should
2603  * be reflected in the name.
2604  */
2605 int
2606 valid_lisp_pointer_p(lispobj *pointer)
2607 {
2608     lispobj *start;
2609     if (((start=search_dynamic_space(pointer))!=NULL) ||
2610         ((start=search_static_space(pointer))!=NULL) ||
2611         ((start=search_read_only_space(pointer))!=NULL))
2612         return looks_like_valid_lisp_pointer_p((lispobj)pointer, start);
2613     else
2614         return 0;
2615 }
2616
2617 boolean
2618 maybe_gc(os_context_t *context)
2619 {
2620     lispobj gc_happened;
2621     struct thread *thread = arch_os_get_current_thread();
2622
2623     fake_foreign_function_call(context);
2624     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2625      * which case we will be running with no gc trigger barrier
2626      * thing for a while.  But it shouldn't be long until the end
2627      * of WITHOUT-GCING.
2628      *
2629      * FIXME: It would be good to protect the end of dynamic space for
2630      * CheneyGC and signal a storage condition from there.
2631      */
2632
2633     /* Restore the signal mask from the interrupted context before
2634      * calling into Lisp if interrupts are enabled. Why not always?
2635      *
2636      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2637      * interrupt hits while in SUB-GC, it is deferred and the
2638      * os_context_sigmask of that interrupt is set to block further
2639      * deferrable interrupts (until the first one is
2640      * handled). Unfortunately, that context refers to this place and
2641      * when we return from here the signals will not be blocked.
2642      *
2643      * A kludgy alternative is to propagate the sigmask change to the
2644      * outer context.
2645      */
2646 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2647     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2648     unblock_gc_signals(0, 0);
2649 #endif
2650     FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2651     /* FIXME: Nothing must go wrong during GC else we end up running
2652      * the debugger, error handlers, and user code in general in a
2653      * potentially unsafe place. Running out of the control stack or
2654      * the heap in SUB-GC are ways to lose. Of course, deferrables
2655      * cannot be unblocked because there may be a pending handler, or
2656      * we may even be in a WITHOUT-INTERRUPTS. */
2657     gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2658     FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2659            (gc_happened == NIL) ? "NIL" : "T"));
2660     if ((gc_happened != NIL) &&
2661         /* See if interrupts are enabled or it's possible to enable
2662          * them. POST-GC has a similar check, but we don't want to
2663          * unlock deferrables in that case and get a pending interrupt
2664          * here. */
2665         ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2666          (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2667 #ifndef LISP_FEATURE_WIN32
2668         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2669         if (!deferrables_blocked_p(context_sigmask)) {
2670             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2671 #ifndef LISP_FEATURE_SB_SAFEPOINT
2672             check_gc_signals_unblocked_or_lose(0);
2673 #endif
2674 #endif
2675             FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2676             funcall0(StaticSymbolFunction(POST_GC));
2677 #ifndef LISP_FEATURE_WIN32
2678         } else {
2679             FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2680         }
2681 #endif
2682     }
2683     undo_fake_foreign_function_call(context);
2684     FSHOW((stderr, "/maybe_gc: returning\n"));
2685     return (gc_happened != NIL);
2686 }
2687
2688 #define BYTES_ZERO_BEFORE_END (1<<12)
2689
2690 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2691  * Lisp and another called zero_stack() in cheneygc.c, but since it's
2692  * shorter to express in, and more often called from C, I keep only
2693  * the C one after fixing it. -- MG 2009-03-25 */
2694
2695 /* Zero the unused portion of the control stack so that old objects
2696  * are not kept alive because of uninitialized stack variables.
2697  *
2698  * "To summarize the problem, since not all allocated stack frame
2699  * slots are guaranteed to be written by the time you call an another
2700  * function or GC, there may be garbage pointers retained in your dead
2701  * stack locations. The stack scrubbing only affects the part of the
2702  * stack from the SP to the end of the allocated stack." - ram, on
2703  * cmucl-imp, Tue, 25 Sep 2001
2704  *
2705  * So, as an (admittedly lame) workaround, from time to time we call
2706  * scrub-control-stack to zero out all the unused portion. This is
2707  * supposed to happen when the stack is mostly empty, so that we have
2708  * a chance of clearing more of it: callers are currently (2002.07.18)
2709  * REPL, SUB-GC and sig_stop_for_gc_handler. */
2710
2711 /* Take care not to tread on the guard page and the hard guard page as
2712  * it would be unkind to sig_stop_for_gc_handler. Touching the return
2713  * guard page is not dangerous. For this to work the guard page must
2714  * be zeroed when protected. */
2715
2716 /* FIXME: I think there is no guarantee that once
2717  * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2718  * may be what the "lame" adjective in the above comment is for. In
2719  * this case, exact gc may lose badly. */
2720 void
2721 scrub_control_stack(void)
2722 {
2723     struct thread *th = arch_os_get_current_thread();
2724     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2725     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2726 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2727     /* On these targets scrubbing from C is a bad idea, so we punt to
2728      * a routine in $ARCH-assem.S. */
2729     extern void arch_scrub_control_stack(struct thread *, os_vm_address_t, os_vm_address_t);
2730     arch_scrub_control_stack(th, guard_page_address, hard_guard_page_address);
2731 #else
2732     lispobj *sp = access_control_stack_pointer(th);
2733  scrub:
2734     if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2735          ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2736         (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2737          ((os_vm_address_t)sp >= guard_page_address) &&
2738          (th->control_stack_guard_page_protected != NIL)))
2739         return;
2740 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2741     do {
2742         *sp = 0;
2743     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2744     if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2745         return;
2746     do {
2747         if (*sp)
2748             goto scrub;
2749     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2750 #else
2751     do {
2752         *sp = 0;
2753     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2754     if ((os_vm_address_t)sp >= hard_guard_page_address)
2755         return;
2756     do {
2757         if (*sp)
2758             goto scrub;
2759     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2760 #endif
2761 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2762 }
2763 \f
2764 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2765
2766 void
2767 scavenge_control_stack(struct thread *th)
2768 {
2769     lispobj *object_ptr;
2770
2771     /* In order to properly support dynamic-extent allocation of
2772      * non-CONS objects, the control stack requires special handling.
2773      * Rather than calling scavenge() directly, grovel over it fixing
2774      * broken hearts, scavenging pointers to oldspace, and pitching a
2775      * fit when encountering unboxed data.  This prevents stray object
2776      * headers from causing the scavenger to blow past the end of the
2777      * stack (an error case checked in scavenge()).  We don't worry
2778      * about treating unboxed words as boxed or vice versa, because
2779      * the compiler isn't allowed to store unboxed objects on the
2780      * control stack.  -- AB, 2011-Dec-02 */
2781
2782     for (object_ptr = th->control_stack_start;
2783          object_ptr < access_control_stack_pointer(th);
2784          object_ptr++) {
2785
2786         lispobj object = *object_ptr;
2787 #ifdef LISP_FEATURE_GENCGC
2788         if (forwarding_pointer_p(object_ptr))
2789             lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
2790                  object_ptr, th->control_stack_start, access_control_stack_pointer(th));
2791 #endif
2792         if (is_lisp_pointer(object) && from_space_p(object)) {
2793             /* It currently points to old space. Check for a
2794              * forwarding pointer. */
2795             lispobj *ptr = native_pointer(object);
2796             if (forwarding_pointer_p(ptr)) {
2797                 /* Yes, there's a forwarding pointer. */
2798                 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
2799             } else {
2800                 /* Scavenge that pointer. */
2801                 long n_words_scavenged =
2802                     (scavtab[widetag_of(object)])(object_ptr, object);
2803                 gc_assert(n_words_scavenged == 1);
2804             }
2805         } else if (scavtab[widetag_of(object)] == scav_lose) {
2806             lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
2807                  object_ptr, object, th->control_stack_start, access_control_stack_pointer(th));
2808         }
2809     }
2810 }
2811
2812 /* Scavenging Interrupt Contexts */
2813
2814 static int boxed_registers[] = BOXED_REGISTERS;
2815
2816 /* The GC has a notion of an "interior pointer" register, an unboxed
2817  * register that typically contains a pointer to inside an object
2818  * referenced by another pointer.  The most obvious of these is the
2819  * program counter, although many compiler backends define a "Lisp
2820  * Interior Pointer" register known to the runtime as reg_LIP, and
2821  * various CPU architectures have other registers that also partake of
2822  * the interior-pointer nature.  As the code for pairing an interior
2823  * pointer value up with its "base" register, and fixing it up after
2824  * scavenging is complete is horribly repetitive, a few macros paper
2825  * over the monotony.  --AB, 2010-Jul-14 */
2826
2827 /* These macros are only ever used over a lexical environment which
2828  * defines a pointer to an os_context_t called context, thus we don't
2829  * bother to pass that context in as a parameter. */
2830
2831 /* Define how to access a given interior pointer. */
2832 #define ACCESS_INTERIOR_POINTER_pc \
2833     *os_context_pc_addr(context)
2834 #define ACCESS_INTERIOR_POINTER_lip \
2835     *os_context_register_addr(context, reg_LIP)
2836 #define ACCESS_INTERIOR_POINTER_lr \
2837     *os_context_lr_addr(context)
2838 #define ACCESS_INTERIOR_POINTER_npc \
2839     *os_context_npc_addr(context)
2840 #define ACCESS_INTERIOR_POINTER_ctr \
2841     *os_context_ctr_addr(context)
2842
2843 #define INTERIOR_POINTER_VARS(name) \
2844     unsigned long name##_offset;    \
2845     int name##_register_pair
2846
2847 #define PAIR_INTERIOR_POINTER(name)                             \
2848     pair_interior_pointer(context,                              \
2849                           ACCESS_INTERIOR_POINTER_##name,       \
2850                           &name##_offset,                       \
2851                           &name##_register_pair)
2852
2853 /* One complexity here is that if a paired register is not found for
2854  * an interior pointer, then that pointer does not get updated.
2855  * Originally, there was some commentary about using an index of -1
2856  * when calling os_context_register_addr() on SPARC referring to the
2857  * program counter, but the real reason is to allow an interior
2858  * pointer register to point to the runtime, read-only space, or
2859  * static space without problems. */
2860 #define FIXUP_INTERIOR_POINTER(name)                                    \
2861     do {                                                                \
2862         if (name##_register_pair >= 0) {                                \
2863             ACCESS_INTERIOR_POINTER_##name =                            \
2864                 (*os_context_register_addr(context,                     \
2865                                            name##_register_pair)        \
2866                  & ~LOWTAG_MASK)                                        \
2867                 + name##_offset;                                        \
2868         }                                                               \
2869     } while (0)
2870
2871
2872 static void
2873 pair_interior_pointer(os_context_t *context, unsigned long pointer,
2874                       unsigned long *saved_offset, int *register_pair)
2875 {
2876     int i;
2877
2878     /*
2879      * I (RLT) think this is trying to find the boxed register that is
2880      * closest to the LIP address, without going past it.  Usually, it's
2881      * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2882      */
2883     /* 0x7FFFFFFF on 32-bit platforms;
2884        0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2885     *saved_offset = (((unsigned long)1) << (N_WORD_BITS - 1)) - 1;
2886     *register_pair = -1;
2887     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2888         unsigned long reg;
2889         long offset;
2890         int index;
2891
2892         index = boxed_registers[i];
2893         reg = *os_context_register_addr(context, index);
2894
2895         /* An interior pointer is never relative to a non-pointer
2896          * register (an oversight in the original implementation).
2897          * The simplest argument for why this is true is to consider
2898          * the fixnum that happens by coincide to be the word-index in
2899          * memory of the header for some object plus two.  This is
2900          * happenstance would cause the register containing the fixnum
2901          * to be selected as the register_pair if the interior pointer
2902          * is to anywhere after the first two words of the object.
2903          * The fixnum won't be changed during GC, but the object might
2904          * move, thus destroying the interior pointer.  --AB,
2905          * 2010-Jul-14 */
2906
2907         if (is_lisp_pointer(reg) &&
2908             ((reg & ~LOWTAG_MASK) <= pointer)) {
2909             offset = pointer - (reg & ~LOWTAG_MASK);
2910             if (offset < *saved_offset) {
2911                 *saved_offset = offset;
2912                 *register_pair = index;
2913             }
2914         }
2915     }
2916 }
2917
2918 static void
2919 scavenge_interrupt_context(os_context_t * context)
2920 {
2921     int i;
2922
2923     /* FIXME: The various #ifdef noise here is precisely that: noise.
2924      * Is it possible to fold it into the macrology so that we have
2925      * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2926      * compile out for the registers that don't exist on a given
2927      * platform? */
2928
2929     INTERIOR_POINTER_VARS(pc);
2930 #ifdef reg_LIP
2931     INTERIOR_POINTER_VARS(lip);
2932 #endif
2933 #ifdef ARCH_HAS_LINK_REGISTER
2934     INTERIOR_POINTER_VARS(lr);
2935 #endif
2936 #ifdef ARCH_HAS_NPC_REGISTER
2937     INTERIOR_POINTER_VARS(npc);
2938 #endif
2939 #ifdef LISP_FEATURE_PPC
2940     INTERIOR_POINTER_VARS(ctr);
2941 #endif
2942
2943     PAIR_INTERIOR_POINTER(pc);
2944 #ifdef reg_LIP
2945     PAIR_INTERIOR_POINTER(lip);
2946 #endif
2947 #ifdef ARCH_HAS_LINK_REGISTER
2948     PAIR_INTERIOR_POINTER(lr);
2949 #endif
2950 #ifdef ARCH_HAS_NPC_REGISTER
2951     PAIR_INTERIOR_POINTER(npc);
2952 #endif
2953 #ifdef LISP_FEATURE_PPC
2954     PAIR_INTERIOR_POINTER(ctr);
2955 #endif
2956
2957     /* Scavenge all boxed registers in the context. */
2958     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2959         int index;
2960         lispobj foo;
2961
2962         index = boxed_registers[i];
2963         foo = *os_context_register_addr(context, index);
2964         scavenge(&foo, 1);
2965         *os_context_register_addr(context, index) = foo;
2966
2967         /* this is unlikely to work as intended on bigendian
2968          * 64 bit platforms */
2969
2970         scavenge((lispobj *) os_context_register_addr(context, index), 1);
2971     }
2972
2973     /* Now that the scavenging is done, repair the various interior
2974      * pointers. */
2975     FIXUP_INTERIOR_POINTER(pc);
2976 #ifdef reg_LIP
2977     FIXUP_INTERIOR_POINTER(lip);
2978 #endif
2979 #ifdef ARCH_HAS_LINK_REGISTER
2980     FIXUP_INTERIOR_POINTER(lr);
2981 #endif
2982 #ifdef ARCH_HAS_NPC_REGISTER
2983     FIXUP_INTERIOR_POINTER(npc);
2984 #endif
2985 #ifdef LISP_FEATURE_PPC
2986     FIXUP_INTERIOR_POINTER(ctr);
2987 #endif
2988 }
2989
2990 void
2991 scavenge_interrupt_contexts(struct thread *th)
2992 {
2993     int i, index;
2994     os_context_t *context;
2995
2996     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
2997
2998 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2999     printf("Number of active contexts: %d\n", index);
3000 #endif
3001
3002     for (i = 0; i < index; i++) {
3003         context = th->interrupt_contexts[i];
3004         scavenge_interrupt_context(context);
3005     }
3006 }
3007 #endif /* x86oid targets */