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