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