src/runtime/gc-common.c

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