src/runtime/gc-common.c

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