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 "fixnump.h"
  41 #include "gc.h"
  42 #include "genesis/primitive-objects.h"
  43 #include "genesis/static-symbols.h"
  44 #include "genesis/layout.h"
  45 #include "genesis/hash-table.h"
  46 #include "gc-internal.h"
  47
  48 #ifdef LISP_FEATURE_SPARC
  49 #define LONG_FLOAT_SIZE 4
  50 #else
  51 #ifdef LISP_FEATURE_X86
  52 #define LONG_FLOAT_SIZE 3
  53 #endif
  54 #endif
  55
  56 size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE;
  57 size_t thread_control_stack_size = DEFAULT_CONTROL_STACK_SIZE;
  58
  59 inline static boolean
  60 forwarding_pointer_p(lispobj *pointer) {
  61     lispobj first_word=*pointer;
  62 #ifdef LISP_FEATURE_GENCGC
  63     return (first_word == 0x01);
  64 #else
  65     return (is_lisp_pointer(first_word)
  66             && new_space_p(first_word));
  67 #endif
  68 }
  69
  70 static inline lispobj *
  71 forwarding_pointer_value(lispobj *pointer) {
  72 #ifdef LISP_FEATURE_GENCGC
  73     return (lispobj *) ((pointer_sized_uint_t) pointer[1]);
  74 #else
  75     return (lispobj *) ((pointer_sized_uint_t) pointer[0]);
  76 #endif
  77 }
  78 static inline lispobj
  79 set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) {
  80 #ifdef LISP_FEATURE_GENCGC
  81     pointer[0]=0x01;
  82     pointer[1]=newspace_copy;
  83 #else
  84     pointer[0]=newspace_copy;
  85 #endif
  86     return newspace_copy;
  87 }
  88
  89 long (*scavtab[256])(lispobj *where, lispobj object);
  90 lispobj (*transother[256])(lispobj object);
  91 long (*sizetab[256])(lispobj *where);
  92 struct weak_pointer *weak_pointers;
  93
  94 unsigned long bytes_consed_between_gcs = 12*1024*1024;
  95
  96
  97 /*
  98  * copying objects
  99  */
 100
 101 /* to copy a boxed object */
 102 lispobj
 103 copy_object(lispobj object, long nwords)
 104 {
 105     int tag;
 106     lispobj *new;
 107
 108     gc_assert(is_lisp_pointer(object));
 109     gc_assert(from_space_p(object));
 110     gc_assert((nwords & 0x01) == 0);
 111
 112     /* Get tag of object. */
 113     tag = lowtag_of(object);
 114
 115     /* Allocate space. */
 116     new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK);
 117
 118     /* Copy the object. */
 119     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
 120     return make_lispobj(new,tag);
 121 }
 122
 123 static long scav_lose(lispobj *where, lispobj object); /* forward decl */
 124
 125 /* FIXME: Most calls end up going to some trouble to compute an
 126  * 'n_words' value for this function. The system might be a little
 127  * simpler if this function used an 'end' parameter instead. */
 128 void
 129 scavenge(lispobj *start, long n_words)
 130 {
 131     lispobj *end = start + n_words;
 132     lispobj *object_ptr;
 133     long n_words_scavenged;
 134
 135     for (object_ptr = start;
 136          object_ptr < end;
 137          object_ptr += n_words_scavenged) {
 138
 139         lispobj object = *object_ptr;
 140 #ifdef LISP_FEATURE_GENCGC
 141         if (forwarding_pointer_p(object_ptr))
 142             lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
 143                  object_ptr, start, n_words);
 144 #endif
 145         if (is_lisp_pointer(object)) {
 146             if (from_space_p(object)) {
 147                 /* It currently points to old space. Check for a
 148                  * forwarding pointer. */
 149                 lispobj *ptr = native_pointer(object);
 150                 if (forwarding_pointer_p(ptr)) {
 151                     /* Yes, there's a forwarding pointer. */
 152                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 153                     n_words_scavenged = 1;
 154                 } else {
 155                     /* Scavenge that pointer. */
 156                     n_words_scavenged =
 157                         (scavtab[widetag_of(object)])(object_ptr, object);
 158                 }
 159             } else {
 160                 /* It points somewhere other than oldspace. Leave it
 161                  * alone. */
 162                 n_words_scavenged = 1;
 163             }
 164         }
 165 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
 166         /* This workaround is probably not needed for those ports
 167            which don't have a partitioned register set (and therefore
 168            scan the stack conservatively for roots). */
 169         else if (n_words == 1) {
 170             /* there are some situations where an other-immediate may
 171                end up in a descriptor register.  I'm not sure whether
 172                this is supposed to happen, but if it does then we
 173                don't want to (a) barf or (b) scavenge over the
 174                data-block, because there isn't one.  So, if we're
 175                checking a single word and it's anything other than a
 176                pointer, just hush it up */
 177             int widetag = widetag_of(object);
 178             n_words_scavenged = 1;
 179
 180             if ((scavtab[widetag] == scav_lose) ||
 181                 (((sizetab[widetag])(object_ptr)) > 1)) {
 182                 fprintf(stderr,"warning: \
 183 attempted to scavenge non-descriptor value %x at %p.\n\n\
 184 If you can reproduce this warning, please send a bug report\n\
 185 (see manual page for details).\n",
 186                         object, object_ptr);
 187             }
 188         }
 189 #endif
 190         else if (fixnump(object)) {
 191             /* It's a fixnum: really easy.. */
 192             n_words_scavenged = 1;
 193         } else {
 194             /* It's some sort of header object or another. */
 195             n_words_scavenged =
 196                 (scavtab[widetag_of(object)])(object_ptr, object);
 197         }
 198     }
 199     gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n",
 200                       object_ptr, start, end);
 201 }
 202
 203 static lispobj trans_fun_header(lispobj object); /* forward decls */
 204 static lispobj trans_boxed(lispobj object);
 205
 206 static long
 207 scav_fun_pointer(lispobj *where, lispobj object)
 208 {
 209     lispobj *first_pointer;
 210     lispobj copy;
 211
 212     gc_assert(is_lisp_pointer(object));
 213
 214     /* Object is a pointer into from_space - not a FP. */
 215     first_pointer = (lispobj *) native_pointer(object);
 216
 217     /* must transport object -- object may point to either a function
 218      * header, a closure function header, or to a closure header. */
 219
 220     switch (widetag_of(*first_pointer)) {
 221     case SIMPLE_FUN_HEADER_WIDETAG:
 222         copy = trans_fun_header(object);
 223         break;
 224     default:
 225         copy = trans_boxed(object);
 226         break;
 227     }
 228
 229     if (copy != object) {
 230         /* Set forwarding pointer */
 231         set_forwarding_pointer(first_pointer,copy);
 232     }
 233
 234     gc_assert(is_lisp_pointer(copy));
 235     gc_assert(!from_space_p(copy));
 236
 237     *where = copy;
 238
 239     return 1;
 240 }
 241
 242
 243 static struct code *
 244 trans_code(struct code *code)
 245 {
 246     struct code *new_code;
 247     lispobj first, l_code, l_new_code;
 248     long nheader_words, ncode_words, nwords;
 249     unsigned long displacement;
 250     lispobj fheaderl, *prev_pointer;
 251
 252     /* if object has already been transported, just return pointer */
 253     first = code->header;
 254     if (forwarding_pointer_p((lispobj *)code)) {
 255 #ifdef DEBUG_CODE_GC
 256         printf("Was already transported\n");
 257 #endif
 258         return (struct code *) forwarding_pointer_value
 259             ((lispobj *)((pointer_sized_uint_t) code));
 260     }
 261
 262     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 263
 264     /* prepare to transport the code vector */
 265     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 266
 267     ncode_words = fixnum_value(code->code_size);
 268     nheader_words = HeaderValue(code->header);
 269     nwords = ncode_words + nheader_words;
 270     nwords = CEILING(nwords, 2);
 271
 272     l_new_code = copy_object(l_code, nwords);
 273     new_code = (struct code *) native_pointer(l_new_code);
 274
 275 #if defined(DEBUG_CODE_GC)
 276     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 277            (unsigned long) code, (unsigned long) new_code);
 278     printf("Code object is %d words long.\n", nwords);
 279 #endif
 280
 281 #ifdef LISP_FEATURE_GENCGC
 282     if (new_code == code)
 283         return new_code;
 284 #endif
 285
 286     displacement = l_new_code - l_code;
 287
 288     set_forwarding_pointer((lispobj *)code, l_new_code);
 289
 290     /* set forwarding pointers for all the function headers in the */
 291     /* code object.  also fix all self pointers */
 292
 293     fheaderl = code->entry_points;
 294     prev_pointer = &new_code->entry_points;
 295
 296     while (fheaderl != NIL) {
 297         struct simple_fun *fheaderp, *nfheaderp;
 298         lispobj nfheaderl;
 299
 300         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 301         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 302
 303         /* Calculate the new function pointer and the new */
 304         /* function header. */
 305         nfheaderl = fheaderl + displacement;
 306         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 307
 308 #ifdef DEBUG_CODE_GC
 309         printf("fheaderp->header (at %x) <- %x\n",
 310                &(fheaderp->header) , nfheaderl);
 311 #endif
 312         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 313
 314         /* fix self pointer. */
 315         nfheaderp->self =
 316 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 317             FUN_RAW_ADDR_OFFSET +
 318 #endif
 319             nfheaderl;
 320
 321         *prev_pointer = nfheaderl;
 322
 323         fheaderl = fheaderp->next;
 324         prev_pointer = &nfheaderp->next;
 325     }
 326 #ifdef LISP_FEATURE_GENCGC
 327     /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
 328        spaces once when all copying is done. */
 329     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
 330                     ncode_words * sizeof(long));
 331
 332 #endif
 333
 334 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 335     gencgc_apply_code_fixups(code, new_code);
 336 #endif
 337
 338     return new_code;
 339 }
 340
 341 static long
 342 scav_code_header(lispobj *where, lispobj object)
 343 {
 344     struct code *code;
 345     long n_header_words, n_code_words, n_words;
 346     lispobj entry_point;        /* tagged pointer to entry point */
 347     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 348
 349     code = (struct code *) where;
 350     n_code_words = fixnum_value(code->code_size);
 351     n_header_words = HeaderValue(object);
 352     n_words = n_code_words + n_header_words;
 353     n_words = CEILING(n_words, 2);
 354
 355     /* Scavenge the boxed section of the code data block. */
 356     scavenge(where + 1, n_header_words - 1);
 357
 358     /* Scavenge the boxed section of each function object in the
 359      * code data block. */
 360     for (entry_point = code->entry_points;
 361          entry_point != NIL;
 362          entry_point = function_ptr->next) {
 363
 364         gc_assert_verbose(is_lisp_pointer(entry_point),
 365                           "Entry point %lx\n is not a lisp pointer.",
 366                           (long)entry_point);
 367
 368         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 369         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 370
 371         scavenge(&function_ptr->name, 1);
 372         scavenge(&function_ptr->arglist, 1);
 373         scavenge(&function_ptr->type, 1);
 374         scavenge(&function_ptr->xrefs, 1);
 375     }
 376
 377     return n_words;
 378 }
 379
 380 static lispobj
 381 trans_code_header(lispobj object)
 382 {
 383     struct code *ncode;
 384
 385     ncode = trans_code((struct code *) native_pointer(object));
 386     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 387 }
 388
 389
 390 static long
 391 size_code_header(lispobj *where)
 392 {
 393     struct code *code;
 394     long nheader_words, ncode_words, nwords;
 395
 396     code = (struct code *) where;
 397
 398     ncode_words = fixnum_value(code->code_size);
 399     nheader_words = HeaderValue(code->header);
 400     nwords = ncode_words + nheader_words;
 401     nwords = CEILING(nwords, 2);
 402
 403     return nwords;
 404 }
 405
 406 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 407 static long
 408 scav_return_pc_header(lispobj *where, lispobj object)
 409 {
 410     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
 411          (unsigned long) where,
 412          (unsigned long) object);
 413     return 0; /* bogus return value to satisfy static type checking */
 414 }
 415 #endif /* LISP_FEATURE_X86 */
 416
 417 static lispobj
 418 trans_return_pc_header(lispobj object)
 419 {
 420     struct simple_fun *return_pc;
 421     unsigned long offset;
 422     struct code *code, *ncode;
 423
 424     return_pc = (struct simple_fun *) native_pointer(object);
 425     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 426     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 427
 428     /* Transport the whole code object */
 429     code = (struct code *) ((unsigned long) return_pc - offset);
 430     ncode = trans_code(code);
 431
 432     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 433 }
 434
 435 /* On the 386, closures hold a pointer to the raw address instead of the
 436  * function object, so we can use CALL [$FDEFN+const] to invoke
 437  * the function without loading it into a register. Given that code
 438  * objects don't move, we don't need to update anything, but we do
 439  * have to figure out that the function is still live. */
 440
 441 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 442 static long
 443 scav_closure_header(lispobj *where, lispobj object)
 444 {
 445     struct closure *closure;
 446     lispobj fun;
 447
 448     closure = (struct closure *)where;
 449     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 450     scavenge(&fun, 1);
 451 #ifdef LISP_FEATURE_GENCGC
 452     /* The function may have moved so update the raw address. But
 453      * don't write unnecessarily. */
 454     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 455         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 456 #endif
 457     return 2;
 458 }
 459 #endif
 460
 461 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 462 static long
 463 scav_fun_header(lispobj *where, lispobj object)
 464 {
 465     lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
 466          (unsigned long) where,
 467          (unsigned long) object);
 468     return 0; /* bogus return value to satisfy static type checking */
 469 }
 470 #endif /* LISP_FEATURE_X86 */
 471
 472 static lispobj
 473 trans_fun_header(lispobj object)
 474 {
 475     struct simple_fun *fheader;
 476     unsigned long offset;
 477     struct code *code, *ncode;
 478
 479     fheader = (struct simple_fun *) native_pointer(object);
 480     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 481     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 482
 483     /* Transport the whole code object */
 484     code = (struct code *) ((unsigned long) fheader - offset);
 485     ncode = trans_code(code);
 486
 487     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 488 }
 489
 490 \f
 491 /*
 492  * instances
 493  */
 494
 495 static long
 496 scav_instance_pointer(lispobj *where, lispobj object)
 497 {
 498     lispobj copy, *first_pointer;
 499
 500     /* Object is a pointer into from space - not a FP. */
 501     copy = trans_boxed(object);
 502
 503 #ifdef LISP_FEATURE_GENCGC
 504     gc_assert(copy != object);
 505 #endif
 506
 507     first_pointer = (lispobj *) native_pointer(object);
 508     set_forwarding_pointer(first_pointer,copy);
 509     *where = copy;
 510
 511     return 1;
 512 }
 513
 514 \f
 515 /*
 516  * lists and conses
 517  */
 518
 519 static lispobj trans_list(lispobj object);
 520
 521 static long
 522 scav_list_pointer(lispobj *where, lispobj object)
 523 {
 524     lispobj first, *first_pointer;
 525
 526     gc_assert(is_lisp_pointer(object));
 527
 528     /* Object is a pointer into from space - not FP. */
 529     first_pointer = (lispobj *) native_pointer(object);
 530
 531     first = trans_list(object);
 532     gc_assert(first != object);
 533
 534     /* Set forwarding pointer */
 535     set_forwarding_pointer(first_pointer, first);
 536
 537     gc_assert(is_lisp_pointer(first));
 538     gc_assert(!from_space_p(first));
 539
 540     *where = first;
 541     return 1;
 542 }
 543
 544
 545 static lispobj
 546 trans_list(lispobj object)
 547 {
 548     lispobj new_list_pointer;
 549     struct cons *cons, *new_cons;
 550     lispobj cdr;
 551
 552     cons = (struct cons *) native_pointer(object);
 553
 554     /* Copy 'object'. */
 555     new_cons = (struct cons *)
 556         gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 557     new_cons->car = cons->car;
 558     new_cons->cdr = cons->cdr; /* updated later */
 559     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 560
 561     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 562     cdr = cons->cdr;
 563
 564     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 565
 566     /* Try to linearize the list in the cdr direction to help reduce
 567      * paging. */
 568     while (1) {
 569         lispobj  new_cdr;
 570         struct cons *cdr_cons, *new_cdr_cons;
 571
 572         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 573            !from_space_p(cdr) ||
 574            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 575             break;
 576
 577         cdr_cons = (struct cons *) native_pointer(cdr);
 578
 579         /* Copy 'cdr'. */
 580         new_cdr_cons = (struct cons*)
 581             gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 582         new_cdr_cons->car = cdr_cons->car;
 583         new_cdr_cons->cdr = cdr_cons->cdr;
 584         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 585
 586         /* Grab the cdr before it is clobbered. */
 587         cdr = cdr_cons->cdr;
 588         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 589
 590         /* Update the cdr of the last cons copied into new space to
 591          * keep the newspace scavenge from having to do it. */
 592         new_cons->cdr = new_cdr;
 593
 594         new_cons = new_cdr_cons;
 595     }
 596
 597     return new_list_pointer;
 598 }
 599
 600 \f
 601 /*
 602  * scavenging and transporting other pointers
 603  */
 604
 605 static long
 606 scav_other_pointer(lispobj *where, lispobj object)
 607 {
 608     lispobj first, *first_pointer;
 609
 610     gc_assert(is_lisp_pointer(object));
 611
 612     /* Object is a pointer into from space - not FP. */
 613     first_pointer = (lispobj *) native_pointer(object);
 614     first = (transother[widetag_of(*first_pointer)])(object);
 615
 616     if (first != object) {
 617         set_forwarding_pointer(first_pointer, first);
 618 #ifdef LISP_FEATURE_GENCGC
 619         *where = first;
 620 #endif
 621     }
 622 #ifndef LISP_FEATURE_GENCGC
 623     *where = first;
 624 #endif
 625     gc_assert(is_lisp_pointer(first));
 626     gc_assert(!from_space_p(first));
 627
 628     return 1;
 629 }
 630 \f
 631 /*
 632  * immediate, boxed, and unboxed objects
 633  */
 634
 635 static long
 636 size_pointer(lispobj *where)
 637 {
 638     return 1;
 639 }
 640
 641 static long
 642 scav_immediate(lispobj *where, lispobj object)
 643 {
 644     return 1;
 645 }
 646
 647 static lispobj
 648 trans_immediate(lispobj object)
 649 {
 650     lose("trying to transport an immediate\n");
 651     return NIL; /* bogus return value to satisfy static type checking */
 652 }
 653
 654 static long
 655 size_immediate(lispobj *where)
 656 {
 657     return 1;
 658 }
 659
 660
 661 static long
 662 scav_boxed(lispobj *where, lispobj object)
 663 {
 664     return 1;
 665 }
 666
 667 static long
 668 scav_instance(lispobj *where, lispobj object)
 669 {
 670     lispobj nuntagged;
 671     long ntotal = HeaderValue(object);
 672     lispobj layout = ((struct instance *)where)->slots[0];
 673
 674     if (!layout)
 675         return 1;
 676     if (forwarding_pointer_p(native_pointer(layout)))
 677         layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
 678
 679     nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
 680     scavenge(where + 1, ntotal - fixnum_value(nuntagged));
 681
 682     return ntotal + 1;
 683 }
 684
 685 static lispobj
 686 trans_boxed(lispobj object)
 687 {
 688     lispobj header;
 689     unsigned long length;
 690
 691     gc_assert(is_lisp_pointer(object));
 692
 693     header = *((lispobj *) native_pointer(object));
 694     length = HeaderValue(header) + 1;
 695     length = CEILING(length, 2);
 696
 697     return copy_object(object, length);
 698 }
 699
 700
 701 static long
 702 size_boxed(lispobj *where)
 703 {
 704     lispobj header;
 705     unsigned long length;
 706
 707     header = *where;
 708     length = HeaderValue(header) + 1;
 709     length = CEILING(length, 2);
 710
 711     return length;
 712 }
 713
 714 /* Note: on the sparc we don't have to do anything special for fdefns, */
 715 /* 'cause the raw-addr has a function lowtag. */
 716 #if !defined(LISP_FEATURE_SPARC)
 717 static long
 718 scav_fdefn(lispobj *where, lispobj object)
 719 {
 720     struct fdefn *fdefn;
 721
 722     fdefn = (struct fdefn *)where;
 723
 724     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 725        fdefn->fun, fdefn->raw_addr)); */
 726
 727     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
 728         == (char *)((unsigned long)(fdefn->raw_addr))) {
 729         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 730
 731         /* Don't write unnecessarily. */
 732         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 733             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 734         /* gc.c has more casts here, which may be relevant or alternatively
 735            may be compiler warning defeaters.  try
 736         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 737         */
 738         return sizeof(struct fdefn) / sizeof(lispobj);
 739     } else {
 740         return 1;
 741     }
 742 }
 743 #endif
 744
 745 static long
 746 scav_unboxed(lispobj *where, lispobj object)
 747 {
 748     unsigned long length;
 749
 750     length = HeaderValue(object) + 1;
 751     length = CEILING(length, 2);
 752
 753     return length;
 754 }
 755
 756 static lispobj
 757 trans_unboxed(lispobj object)
 758 {
 759     lispobj header;
 760     unsigned long length;
 761
 762
 763     gc_assert(is_lisp_pointer(object));
 764
 765     header = *((lispobj *) native_pointer(object));
 766     length = HeaderValue(header) + 1;
 767     length = CEILING(length, 2);
 768
 769     return copy_unboxed_object(object, length);
 770 }
 771
 772 static long
 773 size_unboxed(lispobj *where)
 774 {
 775     lispobj header;
 776     unsigned long length;
 777
 778     header = *where;
 779     length = HeaderValue(header) + 1;
 780     length = CEILING(length, 2);
 781
 782     return length;
 783 }
 784
 785 \f
 786 /* vector-like objects */
 787 static long
 788 scav_base_string(lispobj *where, lispobj object)
 789 {
 790     struct vector *vector;
 791     long length, nwords;
 792
 793     /* NOTE: Strings contain one more byte of data than the length */
 794     /* slot indicates. */
 795
 796     vector = (struct vector *) where;
 797     length = fixnum_value(vector->length) + 1;
 798     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 799
 800     return nwords;
 801 }
 802 static lispobj
 803 trans_base_string(lispobj object)
 804 {
 805     struct vector *vector;
 806     long length, nwords;
 807
 808     gc_assert(is_lisp_pointer(object));
 809
 810     /* NOTE: A string contains one more byte of data (a terminating
 811      * '\0' to help when interfacing with C functions) than indicated
 812      * by the length slot. */
 813
 814     vector = (struct vector *) native_pointer(object);
 815     length = fixnum_value(vector->length) + 1;
 816     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 817
 818     return copy_large_unboxed_object(object, nwords);
 819 }
 820
 821 static long
 822 size_base_string(lispobj *where)
 823 {
 824     struct vector *vector;
 825     long length, nwords;
 826
 827     /* NOTE: A string contains one more byte of data (a terminating
 828      * '\0' to help when interfacing with C functions) than indicated
 829      * by the length slot. */
 830
 831     vector = (struct vector *) where;
 832     length = fixnum_value(vector->length) + 1;
 833     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 834
 835     return nwords;
 836 }
 837
 838 static long
 839 scav_character_string(lispobj *where, lispobj object)
 840 {
 841     struct vector *vector;
 842     int length, nwords;
 843
 844     /* NOTE: Strings contain one more byte of data than the length */
 845     /* slot indicates. */
 846
 847     vector = (struct vector *) where;
 848     length = fixnum_value(vector->length) + 1;
 849     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 850
 851     return nwords;
 852 }
 853 static lispobj
 854 trans_character_string(lispobj object)
 855 {
 856     struct vector *vector;
 857     int length, nwords;
 858
 859     gc_assert(is_lisp_pointer(object));
 860
 861     /* NOTE: A string contains one more byte of data (a terminating
 862      * '\0' to help when interfacing with C functions) than indicated
 863      * by the length slot. */
 864
 865     vector = (struct vector *) native_pointer(object);
 866     length = fixnum_value(vector->length) + 1;
 867     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 868
 869     return copy_large_unboxed_object(object, nwords);
 870 }
 871
 872 static long
 873 size_character_string(lispobj *where)
 874 {
 875     struct vector *vector;
 876     int length, nwords;
 877
 878     /* NOTE: A string contains one more byte of data (a terminating
 879      * '\0' to help when interfacing with C functions) than indicated
 880      * by the length slot. */
 881
 882     vector = (struct vector *) where;
 883     length = fixnum_value(vector->length) + 1;
 884     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 885
 886     return nwords;
 887 }
 888
 889 static lispobj
 890 trans_vector(lispobj object)
 891 {
 892     struct vector *vector;
 893     long length, nwords;
 894
 895     gc_assert(is_lisp_pointer(object));
 896
 897     vector = (struct vector *) native_pointer(object);
 898
 899     length = fixnum_value(vector->length);
 900     nwords = CEILING(length + 2, 2);
 901
 902     return copy_large_object(object, nwords);
 903 }
 904
 905 static long
 906 size_vector(lispobj *where)
 907 {
 908     struct vector *vector;
 909     long length, nwords;
 910
 911     vector = (struct vector *) where;
 912     length = fixnum_value(vector->length);
 913     nwords = CEILING(length + 2, 2);
 914
 915     return nwords;
 916 }
 917
 918 static long
 919 scav_vector_nil(lispobj *where, lispobj object)
 920 {
 921     return 2;
 922 }
 923
 924 static lispobj
 925 trans_vector_nil(lispobj object)
 926 {
 927     gc_assert(is_lisp_pointer(object));
 928     return copy_unboxed_object(object, 2);
 929 }
 930
 931 static long
 932 size_vector_nil(lispobj *where)
 933 {
 934     /* Just the header word and the length word */
 935     return 2;
 936 }
 937
 938 static long
 939 scav_vector_bit(lispobj *where, lispobj object)
 940 {
 941     struct vector *vector;
 942     long length, nwords;
 943
 944     vector = (struct vector *) where;
 945     length = fixnum_value(vector->length);
 946     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 947
 948     return nwords;
 949 }
 950
 951 static lispobj
 952 trans_vector_bit(lispobj object)
 953 {
 954     struct vector *vector;
 955     long length, nwords;
 956
 957     gc_assert(is_lisp_pointer(object));
 958
 959     vector = (struct vector *) native_pointer(object);
 960     length = fixnum_value(vector->length);
 961     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 962
 963     return copy_large_unboxed_object(object, nwords);
 964 }
 965
 966 static long
 967 size_vector_bit(lispobj *where)
 968 {
 969     struct vector *vector;
 970     long length, nwords;
 971
 972     vector = (struct vector *) where;
 973     length = fixnum_value(vector->length);
 974     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 975
 976     return nwords;
 977 }
 978
 979 static long
 980 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 981 {
 982     struct vector *vector;
 983     long length, nwords;
 984
 985     vector = (struct vector *) where;
 986     length = fixnum_value(vector->length);
 987     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 988
 989     return nwords;
 990 }
 991
 992 static lispobj
 993 trans_vector_unsigned_byte_2(lispobj object)
 994 {
 995     struct vector *vector;
 996     long length, nwords;
 997
 998     gc_assert(is_lisp_pointer(object));
 999
1000     vector = (struct vector *) native_pointer(object);
1001     length = fixnum_value(vector->length);
1002     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1003
1004     return copy_large_unboxed_object(object, nwords);
1005 }
1006
1007 static long
1008 size_vector_unsigned_byte_2(lispobj *where)
1009 {
1010     struct vector *vector;
1011     long length, nwords;
1012
1013     vector = (struct vector *) where;
1014     length = fixnum_value(vector->length);
1015     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1016
1017     return nwords;
1018 }
1019
1020 static long
1021 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1022 {
1023     struct vector *vector;
1024     long length, nwords;
1025
1026     vector = (struct vector *) where;
1027     length = fixnum_value(vector->length);
1028     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1029
1030     return nwords;
1031 }
1032
1033 static lispobj
1034 trans_vector_unsigned_byte_4(lispobj object)
1035 {
1036     struct vector *vector;
1037     long length, nwords;
1038
1039     gc_assert(is_lisp_pointer(object));
1040
1041     vector = (struct vector *) native_pointer(object);
1042     length = fixnum_value(vector->length);
1043     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1044
1045     return copy_large_unboxed_object(object, nwords);
1046 }
1047 static long
1048 size_vector_unsigned_byte_4(lispobj *where)
1049 {
1050     struct vector *vector;
1051     long length, nwords;
1052
1053     vector = (struct vector *) where;
1054     length = fixnum_value(vector->length);
1055     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1056
1057     return nwords;
1058 }
1059
1060
1061 static long
1062 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1063 {
1064     struct vector *vector;
1065     long length, nwords;
1066
1067     vector = (struct vector *) where;
1068     length = fixnum_value(vector->length);
1069     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1070
1071     return nwords;
1072 }
1073
1074 /*********************/
1075
1076
1077
1078 static lispobj
1079 trans_vector_unsigned_byte_8(lispobj object)
1080 {
1081     struct vector *vector;
1082     long length, nwords;
1083
1084     gc_assert(is_lisp_pointer(object));
1085
1086     vector = (struct vector *) native_pointer(object);
1087     length = fixnum_value(vector->length);
1088     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1089
1090     return copy_large_unboxed_object(object, nwords);
1091 }
1092
1093 static long
1094 size_vector_unsigned_byte_8(lispobj *where)
1095 {
1096     struct vector *vector;
1097     long length, nwords;
1098
1099     vector = (struct vector *) where;
1100     length = fixnum_value(vector->length);
1101     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1102
1103     return nwords;
1104 }
1105
1106
1107 static long
1108 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1109 {
1110     struct vector *vector;
1111     long length, nwords;
1112
1113     vector = (struct vector *) where;
1114     length = fixnum_value(vector->length);
1115     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1116
1117     return nwords;
1118 }
1119
1120 static lispobj
1121 trans_vector_unsigned_byte_16(lispobj object)
1122 {
1123     struct vector *vector;
1124     long length, nwords;
1125
1126     gc_assert(is_lisp_pointer(object));
1127
1128     vector = (struct vector *) native_pointer(object);
1129     length = fixnum_value(vector->length);
1130     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1131
1132     return copy_large_unboxed_object(object, nwords);
1133 }
1134
1135 static long
1136 size_vector_unsigned_byte_16(lispobj *where)
1137 {
1138     struct vector *vector;
1139     long length, nwords;
1140
1141     vector = (struct vector *) where;
1142     length = fixnum_value(vector->length);
1143     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1144
1145     return nwords;
1146 }
1147
1148 static long
1149 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1150 {
1151     struct vector *vector;
1152     long length, nwords;
1153
1154     vector = (struct vector *) where;
1155     length = fixnum_value(vector->length);
1156     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1157
1158     return nwords;
1159 }
1160
1161 static lispobj
1162 trans_vector_unsigned_byte_32(lispobj object)
1163 {
1164     struct vector *vector;
1165     long length, nwords;
1166
1167     gc_assert(is_lisp_pointer(object));
1168
1169     vector = (struct vector *) native_pointer(object);
1170     length = fixnum_value(vector->length);
1171     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1172
1173     return copy_large_unboxed_object(object, nwords);
1174 }
1175
1176 static long
1177 size_vector_unsigned_byte_32(lispobj *where)
1178 {
1179     struct vector *vector;
1180     long length, nwords;
1181
1182     vector = (struct vector *) where;
1183     length = fixnum_value(vector->length);
1184     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1185
1186     return nwords;
1187 }
1188
1189 #if N_WORD_BITS == 64
1190 static long
1191 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1192 {
1193     struct vector *vector;
1194     long length, nwords;
1195
1196     vector = (struct vector *) where;
1197     length = fixnum_value(vector->length);
1198     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1199
1200     return nwords;
1201 }
1202
1203 static lispobj
1204 trans_vector_unsigned_byte_64(lispobj object)
1205 {
1206     struct vector *vector;
1207     long length, nwords;
1208
1209     gc_assert(is_lisp_pointer(object));
1210
1211     vector = (struct vector *) native_pointer(object);
1212     length = fixnum_value(vector->length);
1213     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1214
1215     return copy_large_unboxed_object(object, nwords);
1216 }
1217
1218 static long
1219 size_vector_unsigned_byte_64(lispobj *where)
1220 {
1221     struct vector *vector;
1222     long length, nwords;
1223
1224     vector = (struct vector *) where;
1225     length = fixnum_value(vector->length);
1226     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1227
1228     return nwords;
1229 }
1230 #endif
1231
1232 static long
1233 scav_vector_single_float(lispobj *where, lispobj object)
1234 {
1235     struct vector *vector;
1236     long length, nwords;
1237
1238     vector = (struct vector *) where;
1239     length = fixnum_value(vector->length);
1240     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1241
1242     return nwords;
1243 }
1244
1245 static lispobj
1246 trans_vector_single_float(lispobj object)
1247 {
1248     struct vector *vector;
1249     long length, nwords;
1250
1251     gc_assert(is_lisp_pointer(object));
1252
1253     vector = (struct vector *) native_pointer(object);
1254     length = fixnum_value(vector->length);
1255     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1256
1257     return copy_large_unboxed_object(object, nwords);
1258 }
1259
1260 static long
1261 size_vector_single_float(lispobj *where)
1262 {
1263     struct vector *vector;
1264     long length, nwords;
1265
1266     vector = (struct vector *) where;
1267     length = fixnum_value(vector->length);
1268     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1269
1270     return nwords;
1271 }
1272
1273 static long
1274 scav_vector_double_float(lispobj *where, lispobj object)
1275 {
1276     struct vector *vector;
1277     long length, nwords;
1278
1279     vector = (struct vector *) where;
1280     length = fixnum_value(vector->length);
1281     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1282
1283     return nwords;
1284 }
1285
1286 static lispobj
1287 trans_vector_double_float(lispobj object)
1288 {
1289     struct vector *vector;
1290     long length, nwords;
1291
1292     gc_assert(is_lisp_pointer(object));
1293
1294     vector = (struct vector *) native_pointer(object);
1295     length = fixnum_value(vector->length);
1296     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1297
1298     return copy_large_unboxed_object(object, nwords);
1299 }
1300
1301 static long
1302 size_vector_double_float(lispobj *where)
1303 {
1304     struct vector *vector;
1305     long length, nwords;
1306
1307     vector = (struct vector *) where;
1308     length = fixnum_value(vector->length);
1309     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1310
1311     return nwords;
1312 }
1313
1314 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1315 static long
1316 scav_vector_long_float(lispobj *where, lispobj object)
1317 {
1318     struct vector *vector;
1319     long length, nwords;
1320
1321     vector = (struct vector *) where;
1322     length = fixnum_value(vector->length);
1323     nwords = CEILING(length *
1324                      LONG_FLOAT_SIZE
1325                      + 2, 2);
1326     return nwords;
1327 }
1328
1329 static lispobj
1330 trans_vector_long_float(lispobj object)
1331 {
1332     struct vector *vector;
1333     long length, nwords;
1334
1335     gc_assert(is_lisp_pointer(object));
1336
1337     vector = (struct vector *) native_pointer(object);
1338     length = fixnum_value(vector->length);
1339     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1340
1341     return copy_large_unboxed_object(object, nwords);
1342 }
1343
1344 static long
1345 size_vector_long_float(lispobj *where)
1346 {
1347     struct vector *vector;
1348     long length, nwords;
1349
1350     vector = (struct vector *) where;
1351     length = fixnum_value(vector->length);
1352     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1353
1354     return nwords;
1355 }
1356 #endif
1357
1358
1359 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1360 static long
1361 scav_vector_complex_single_float(lispobj *where, lispobj object)
1362 {
1363     struct vector *vector;
1364     long length, nwords;
1365
1366     vector = (struct vector *) where;
1367     length = fixnum_value(vector->length);
1368     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1369
1370     return nwords;
1371 }
1372
1373 static lispobj
1374 trans_vector_complex_single_float(lispobj object)
1375 {
1376     struct vector *vector;
1377     long length, nwords;
1378
1379     gc_assert(is_lisp_pointer(object));
1380
1381     vector = (struct vector *) native_pointer(object);
1382     length = fixnum_value(vector->length);
1383     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1384
1385     return copy_large_unboxed_object(object, nwords);
1386 }
1387
1388 static long
1389 size_vector_complex_single_float(lispobj *where)
1390 {
1391     struct vector *vector;
1392     long length, nwords;
1393
1394     vector = (struct vector *) where;
1395     length = fixnum_value(vector->length);
1396     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1397
1398     return nwords;
1399 }
1400 #endif
1401
1402 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1403 static long
1404 scav_vector_complex_double_float(lispobj *where, lispobj object)
1405 {
1406     struct vector *vector;
1407     long length, nwords;
1408
1409     vector = (struct vector *) where;
1410     length = fixnum_value(vector->length);
1411     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1412
1413     return nwords;
1414 }
1415
1416 static lispobj
1417 trans_vector_complex_double_float(lispobj object)
1418 {
1419     struct vector *vector;
1420     long length, nwords;
1421
1422     gc_assert(is_lisp_pointer(object));
1423
1424     vector = (struct vector *) native_pointer(object);
1425     length = fixnum_value(vector->length);
1426     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1427
1428     return copy_large_unboxed_object(object, nwords);
1429 }
1430
1431 static long
1432 size_vector_complex_double_float(lispobj *where)
1433 {
1434     struct vector *vector;
1435     long length, nwords;
1436
1437     vector = (struct vector *) where;
1438     length = fixnum_value(vector->length);
1439     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1440
1441     return nwords;
1442 }
1443 #endif
1444
1445
1446 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1447 static long
1448 scav_vector_complex_long_float(lispobj *where, lispobj object)
1449 {
1450     struct vector *vector;
1451     long length, nwords;
1452
1453     vector = (struct vector *) where;
1454     length = fixnum_value(vector->length);
1455     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1456
1457     return nwords;
1458 }
1459
1460 static lispobj
1461 trans_vector_complex_long_float(lispobj object)
1462 {
1463     struct vector *vector;
1464     long length, nwords;
1465
1466     gc_assert(is_lisp_pointer(object));
1467
1468     vector = (struct vector *) native_pointer(object);
1469     length = fixnum_value(vector->length);
1470     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1471
1472     return copy_large_unboxed_object(object, nwords);
1473 }
1474
1475 static long
1476 size_vector_complex_long_float(lispobj *where)
1477 {
1478     struct vector *vector;
1479     long length, nwords;
1480
1481     vector = (struct vector *) where;
1482     length = fixnum_value(vector->length);
1483     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1484
1485     return nwords;
1486 }
1487 #endif
1488
1489 #define WEAK_POINTER_NWORDS \
1490         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1491
1492 static lispobj
1493 trans_weak_pointer(lispobj object)
1494 {
1495     lispobj copy;
1496 #ifndef LISP_FEATURE_GENCGC
1497     struct weak_pointer *wp;
1498 #endif
1499     gc_assert(is_lisp_pointer(object));
1500
1501 #if defined(DEBUG_WEAK)
1502     printf("Transporting weak pointer from 0x%08x\n", object);
1503 #endif
1504
1505     /* Need to remember where all the weak pointers are that have */
1506     /* been transported so they can be fixed up in a post-GC pass. */
1507
1508     copy = copy_object(object, WEAK_POINTER_NWORDS);
1509 #ifndef LISP_FEATURE_GENCGC
1510     wp = (struct weak_pointer *) native_pointer(copy);
1511
1512     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1513     /* Push the weak pointer onto the list of weak pointers. */
1514     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1515     weak_pointers = wp;
1516 #endif
1517     return copy;
1518 }
1519
1520 static long
1521 size_weak_pointer(lispobj *where)
1522 {
1523     return WEAK_POINTER_NWORDS;
1524 }
1525
1526
1527 void scan_weak_pointers(void)
1528 {
1529     struct weak_pointer *wp, *next_wp;
1530     for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
1531         lispobj value = wp->value;
1532         lispobj *first_pointer;
1533         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1534
1535         next_wp = wp->next;
1536         wp->next = NULL;
1537         if (next_wp == wp) /* gencgc uses a ref to self for end of list */
1538             next_wp = NULL;
1539
1540         if (!(is_lisp_pointer(value) && from_space_p(value)))
1541             continue;
1542
1543         /* Now, we need to check whether the object has been forwarded. If
1544          * it has been, the weak pointer is still good and needs to be
1545          * updated. Otherwise, the weak pointer needs to be nil'ed
1546          * out. */
1547
1548         first_pointer = (lispobj *)native_pointer(value);
1549
1550         if (forwarding_pointer_p(first_pointer)) {
1551             wp->value=
1552                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1553         } else {
1554             /* Break it. */
1555             wp->value = NIL;
1556             wp->broken = T;
1557         }
1558     }
1559 }
1560
1561 \f
1562 /* Hash tables */
1563
1564 #if N_WORD_BITS == 32
1565 #define EQ_HASH_MASK 0x1fffffff
1566 #elif N_WORD_BITS == 64
1567 #define EQ_HASH_MASK 0x1fffffffffffffff
1568 #endif
1569
1570 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1571  * target-hash-table.lisp.  */
1572 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1573
1574 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1575  * slot. Set to NULL at the end of a collection.
1576  *
1577  * This is not optimal because, when a table is tenured, it won't be
1578  * processed automatically; only the yougest generation is GC'd by
1579  * default. On the other hand, all applications will need an
1580  * occasional full GC anyway, so it's not that bad either.  */
1581 struct hash_table *weak_hash_tables = NULL;
1582
1583 /* Return true if OBJ has already survived the current GC. */
1584 static inline int
1585 survived_gc_yet (lispobj obj)
1586 {
1587     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1588             forwarding_pointer_p(native_pointer(obj)));
1589 }
1590
1591 static inline int
1592 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1593 {
1594     switch (weakness) {
1595     case KEY:
1596         return survived_gc_yet(key);
1597     case VALUE:
1598         return survived_gc_yet(value);
1599     case KEY_OR_VALUE:
1600         return (survived_gc_yet(key) || survived_gc_yet(value));
1601     case KEY_AND_VALUE:
1602         return (survived_gc_yet(key) && survived_gc_yet(value));
1603     default:
1604         gc_assert(0);
1605         /* Shut compiler up. */
1606         return 0;
1607     }
1608 }
1609
1610 /* Return the beginning of data in ARRAY (skipping the header and the
1611  * length) or NULL if it isn't an array of the specified widetag after
1612  * all. */
1613 static inline lispobj *
1614 get_array_data (lispobj array, int widetag, unsigned long *length)
1615 {
1616     if (is_lisp_pointer(array) &&
1617         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1618         if (length != NULL)
1619             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1620         return ((lispobj *)native_pointer(array)) + 2;
1621     } else {
1622         return NULL;
1623     }
1624 }
1625
1626 /* Only need to worry about scavenging the _real_ entries in the
1627  * table. Phantom entries such as the hash table itself at index 0 and
1628  * the empty marker at index 1 were scavenged by scav_vector that
1629  * either called this function directly or arranged for it to be
1630  * called later by pushing the hash table onto weak_hash_tables. */
1631 static void
1632 scav_hash_table_entries (struct hash_table *hash_table)
1633 {
1634     lispobj *kv_vector;
1635     unsigned long kv_length;
1636     lispobj *index_vector;
1637     unsigned long length;
1638     lispobj *next_vector;
1639     unsigned long next_vector_length;
1640     lispobj *hash_vector;
1641     unsigned long hash_vector_length;
1642     lispobj empty_symbol;
1643     lispobj weakness = hash_table->weakness;
1644     unsigned long i;
1645
1646     kv_vector = get_array_data(hash_table->table,
1647                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1648     if (kv_vector == NULL)
1649         lose("invalid kv_vector %x\n", hash_table->table);
1650
1651     index_vector = get_array_data(hash_table->index_vector,
1652                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1653     if (index_vector == NULL)
1654         lose("invalid index_vector %x\n", hash_table->index_vector);
1655
1656     next_vector = get_array_data(hash_table->next_vector,
1657                                  SIMPLE_ARRAY_WORD_WIDETAG,
1658                                  &next_vector_length);
1659     if (next_vector == NULL)
1660         lose("invalid next_vector %x\n", hash_table->next_vector);
1661
1662     hash_vector = get_array_data(hash_table->hash_vector,
1663                                  SIMPLE_ARRAY_WORD_WIDETAG,
1664                                  &hash_vector_length);
1665     if (hash_vector != NULL)
1666         gc_assert(hash_vector_length == next_vector_length);
1667
1668      /* These lengths could be different as the index_vector can be a
1669       * different length from the others, a larger index_vector could
1670       * help reduce collisions. */
1671      gc_assert(next_vector_length*2 == kv_length);
1672
1673     empty_symbol = kv_vector[1];
1674     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1675     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1676         SYMBOL_HEADER_WIDETAG) {
1677         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1678              *(lispobj *)native_pointer(empty_symbol));
1679     }
1680
1681     /* Work through the KV vector. */
1682     for (i = 1; i < next_vector_length; i++) {
1683         lispobj old_key = kv_vector[2*i];
1684         lispobj value = kv_vector[2*i+1];
1685         if ((weakness == NIL) ||
1686             weak_hash_entry_alivep(weakness, old_key, value)) {
1687
1688             /* Scavenge the key and value. */
1689             scavenge(&kv_vector[2*i],2);
1690
1691             /* If an EQ-based key has moved, mark the hash-table for
1692              * rehashing. */
1693             if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
1694                 lispobj new_key = kv_vector[2*i];
1695
1696                 if (old_key != new_key && new_key != empty_symbol) {
1697                     hash_table->needs_rehash_p = T;
1698                 }
1699             }
1700         }
1701     }
1702 }
1703
1704 long
1705 scav_vector (lispobj *where, lispobj object)
1706 {
1707     unsigned long kv_length;
1708     lispobj *kv_vector;
1709     struct hash_table *hash_table;
1710
1711     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1712      * hash tables in the Lisp HASH-TABLE code to indicate need for
1713      * special GC support. */
1714     if (HeaderValue(object) == subtype_VectorNormal)
1715         return 1;
1716
1717     kv_length = fixnum_value(where[1]);
1718     kv_vector = where + 2;  /* Skip the header and length. */
1719     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1720
1721     /* Scavenge element 0, which may be a hash-table structure. */
1722     scavenge(where+2, 1);
1723     if (!is_lisp_pointer(where[2])) {
1724         /* This'll happen when REHASH clears the header of old-kv-vector
1725          * and fills it with zero, but some other thread simulatenously
1726          * sets the header in %%PUTHASH.
1727          */
1728         fprintf(stderr,
1729                 "Warning: no pointer at %lx in hash table: this indicates "
1730                 "non-fatal corruption caused by concurrent access to a "
1731                 "hash-table from multiple threads. Any accesses to "
1732                 "hash-tables shared between threads should be protected "
1733                 "by locks.\n", (unsigned long)&where[2]);
1734         // We've scavenged three words.
1735         return 3;
1736     }
1737     hash_table = (struct hash_table *)native_pointer(where[2]);
1738     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1739     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1740         lose("hash table not instance (%x at %x)\n",
1741              hash_table->header,
1742              hash_table);
1743     }
1744
1745     /* Scavenge element 1, which should be some internal symbol that
1746      * the hash table code reserves for marking empty slots. */
1747     scavenge(where+3, 1);
1748     if (!is_lisp_pointer(where[3])) {
1749         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1750     }
1751
1752     /* Scavenge hash table, which will fix the positions of the other
1753      * needed objects. */
1754     scavenge((lispobj *)hash_table,
1755              sizeof(struct hash_table) / sizeof(lispobj));
1756
1757     /* Cross-check the kv_vector. */
1758     if (where != (lispobj *)native_pointer(hash_table->table)) {
1759         lose("hash_table table!=this table %x\n", hash_table->table);
1760     }
1761
1762     if (hash_table->weakness == NIL) {
1763         scav_hash_table_entries(hash_table);
1764     } else {
1765         /* Delay scavenging of this table by pushing it onto
1766          * weak_hash_tables (if it's not there already) for the weak
1767          * object phase. */
1768         if (hash_table->next_weak_hash_table == NIL) {
1769             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1770             weak_hash_tables = hash_table;
1771         }
1772     }
1773
1774     return (CEILING(kv_length + 2, 2));
1775 }
1776
1777 void
1778 scav_weak_hash_tables (void)
1779 {
1780     struct hash_table *table;
1781
1782     /* Scavenge entries whose triggers are known to survive. */
1783     for (table = weak_hash_tables; table != NULL;
1784          table = (struct hash_table *)table->next_weak_hash_table) {
1785         scav_hash_table_entries(table);
1786     }
1787 }
1788
1789 /* Walk through the chain whose first element is *FIRST and remove
1790  * dead weak entries. */
1791 static inline void
1792 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1793                             lispobj *kv_vector, lispobj *index_vector,
1794                             lispobj *next_vector, lispobj *hash_vector,
1795                             lispobj empty_symbol, lispobj weakness)
1796 {
1797     unsigned index = *prev;
1798     while (index) {
1799         unsigned next = next_vector[index];
1800         lispobj key = kv_vector[2 * index];
1801         lispobj value = kv_vector[2 * index + 1];
1802         gc_assert(key != empty_symbol);
1803         gc_assert(value != empty_symbol);
1804         if (!weak_hash_entry_alivep(weakness, key, value)) {
1805             unsigned count = fixnum_value(hash_table->number_entries);
1806             gc_assert(count > 0);
1807             *prev = next;
1808             hash_table->number_entries = make_fixnum(count - 1);
1809             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1810             hash_table->next_free_kv = make_fixnum(index);
1811             kv_vector[2 * index] = empty_symbol;
1812             kv_vector[2 * index + 1] = empty_symbol;
1813             if (hash_vector)
1814                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1815         } else {
1816             prev = &next_vector[index];
1817         }
1818         index = next;
1819     }
1820 }
1821
1822 static void
1823 scan_weak_hash_table (struct hash_table *hash_table)
1824 {
1825     lispobj *kv_vector;
1826     lispobj *index_vector;
1827     unsigned long length = 0; /* prevent warning */
1828     lispobj *next_vector;
1829     unsigned long next_vector_length = 0; /* prevent warning */
1830     lispobj *hash_vector;
1831     lispobj empty_symbol;
1832     lispobj weakness = hash_table->weakness;
1833     unsigned long i;
1834
1835     kv_vector = get_array_data(hash_table->table,
1836                                SIMPLE_VECTOR_WIDETAG, NULL);
1837     index_vector = get_array_data(hash_table->index_vector,
1838                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1839     next_vector = get_array_data(hash_table->next_vector,
1840                                  SIMPLE_ARRAY_WORD_WIDETAG,
1841                                  &next_vector_length);
1842     hash_vector = get_array_data(hash_table->hash_vector,
1843                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1844     empty_symbol = kv_vector[1];
1845
1846     for (i = 0; i < length; i++) {
1847         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1848                                    kv_vector, index_vector, next_vector,
1849                                    hash_vector, empty_symbol, weakness);
1850     }
1851 }
1852
1853 /* Remove dead entries from weak hash tables. */
1854 void
1855 scan_weak_hash_tables (void)
1856 {
1857     struct hash_table *table, *next;
1858
1859     for (table = weak_hash_tables; table != NULL; table = next) {
1860         next = (struct hash_table *)table->next_weak_hash_table;
1861         table->next_weak_hash_table = NIL;
1862         scan_weak_hash_table(table);
1863     }
1864
1865     weak_hash_tables = NULL;
1866 }
1867
1868 \f
1869 /*
1870  * initialization
1871  */
1872
1873 static long
1874 scav_lose(lispobj *where, lispobj object)
1875 {
1876     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1877          (unsigned long)object,
1878          widetag_of(*(lispobj*)native_pointer(object)));
1879
1880     return 0; /* bogus return value to satisfy static type checking */
1881 }
1882
1883 static lispobj
1884 trans_lose(lispobj object)
1885 {
1886     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1887          (unsigned long)object,
1888          widetag_of(*(lispobj*)native_pointer(object)));
1889     return NIL; /* bogus return value to satisfy static type checking */
1890 }
1891
1892 static long
1893 size_lose(lispobj *where)
1894 {
1895     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1896          (unsigned long)where,
1897          widetag_of(LOW_WORD(where)));
1898     return 1; /* bogus return value to satisfy static type checking */
1899 }
1900
1901 \f
1902 /*
1903  * initialization
1904  */
1905
1906 void
1907 gc_init_tables(void)
1908 {
1909     unsigned long i;
1910
1911     /* Set default value in all slots of scavenge table.  FIXME
1912      * replace this gnarly sizeof with something based on
1913      * N_WIDETAG_BITS */
1914     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1915         scavtab[i] = scav_lose;
1916     }
1917
1918     /* For each type which can be selected by the lowtag alone, set
1919      * multiple entries in our widetag scavenge table (one for each
1920      * possible value of the high bits).
1921      */
1922
1923     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1924         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1925         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1926         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1927         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1928         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1929         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1930         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1931         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1932     }
1933
1934     /* Other-pointer types (those selected by all eight bits of the
1935      * tag) get one entry each in the scavenge table. */
1936     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1937     scavtab[RATIO_WIDETAG] = scav_boxed;
1938 #if N_WORD_BITS == 64
1939     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1940 #else
1941     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1942 #endif
1943     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1944 #ifdef LONG_FLOAT_WIDETAG
1945     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1946 #endif
1947     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1948 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1949     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1950 #endif
1951 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1952     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1953 #endif
1954 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1955     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1956 #endif
1957     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1958     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1959 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1960     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1961 #endif
1962     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1963     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1964     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1965         scav_vector_unsigned_byte_2;
1966     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1967         scav_vector_unsigned_byte_4;
1968     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1969         scav_vector_unsigned_byte_8;
1970     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1971         scav_vector_unsigned_byte_8;
1972     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1973         scav_vector_unsigned_byte_16;
1974     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1975         scav_vector_unsigned_byte_16;
1976 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1978         scav_vector_unsigned_byte_32;
1979 #endif
1980     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1981         scav_vector_unsigned_byte_32;
1982     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1983         scav_vector_unsigned_byte_32;
1984 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1985     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1986         scav_vector_unsigned_byte_64;
1987 #endif
1988 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1989     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1990         scav_vector_unsigned_byte_64;
1991 #endif
1992 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1993     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1994         scav_vector_unsigned_byte_64;
1995 #endif
1996 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1997     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1998 #endif
1999 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2000     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2001         scav_vector_unsigned_byte_16;
2002 #endif
2003 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2004     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2005         scav_vector_unsigned_byte_32;
2006 #endif
2007 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2008     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2009         scav_vector_unsigned_byte_32;
2010 #endif
2011 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2012     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2013         scav_vector_unsigned_byte_64;
2014 #endif
2015 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2016     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2017         scav_vector_unsigned_byte_64;
2018 #endif
2019     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2020     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2021 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2022     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2023 #endif
2024 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2025     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2026         scav_vector_complex_single_float;
2027 #endif
2028 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2029     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2030         scav_vector_complex_double_float;
2031 #endif
2032 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2033     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2034         scav_vector_complex_long_float;
2035 #endif
2036     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2037 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2038     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2039 #endif
2040     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2041     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2042     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2043     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2044     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2045 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2046     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2047     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2048 #endif
2049     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2050 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2051     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2052 #else
2053     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2054 #endif
2055     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2056     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2057     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2058     scavtab[SAP_WIDETAG] = scav_unboxed;
2059     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2060     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2061     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2062 #if defined(LISP_FEATURE_SPARC)
2063     scavtab[FDEFN_WIDETAG] = scav_boxed;
2064 #else
2065     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2066 #endif
2067     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2068
2069     /* transport other table, initialized same way as scavtab */
2070     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2071         transother[i] = trans_lose;
2072     transother[BIGNUM_WIDETAG] = trans_unboxed;
2073     transother[RATIO_WIDETAG] = trans_boxed;
2074
2075 #if N_WORD_BITS == 64
2076     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2077 #else
2078     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2079 #endif
2080     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2081 #ifdef LONG_FLOAT_WIDETAG
2082     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2083 #endif
2084     transother[COMPLEX_WIDETAG] = trans_boxed;
2085 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2086     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2087 #endif
2088 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2089     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2090 #endif
2091 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2092     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2093 #endif
2094     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2095     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2096 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2097     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2098 #endif
2099     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2100     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2101     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2102     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2103         trans_vector_unsigned_byte_2;
2104     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2105         trans_vector_unsigned_byte_4;
2106     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2107         trans_vector_unsigned_byte_8;
2108     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2109         trans_vector_unsigned_byte_8;
2110     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2111         trans_vector_unsigned_byte_16;
2112     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2113         trans_vector_unsigned_byte_16;
2114 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2116         trans_vector_unsigned_byte_32;
2117 #endif
2118     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2119         trans_vector_unsigned_byte_32;
2120     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2121         trans_vector_unsigned_byte_32;
2122 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2123     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2124         trans_vector_unsigned_byte_64;
2125 #endif
2126 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2127     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2128         trans_vector_unsigned_byte_64;
2129 #endif
2130 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2131     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2132         trans_vector_unsigned_byte_64;
2133 #endif
2134 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2135     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2136         trans_vector_unsigned_byte_8;
2137 #endif
2138 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2139     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2140         trans_vector_unsigned_byte_16;
2141 #endif
2142 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2143     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2144         trans_vector_unsigned_byte_32;
2145 #endif
2146 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2147     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2148         trans_vector_unsigned_byte_32;
2149 #endif
2150 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2151     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2152         trans_vector_unsigned_byte_64;
2153 #endif
2154 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2155     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2156         trans_vector_unsigned_byte_64;
2157 #endif
2158     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2159         trans_vector_single_float;
2160     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2161         trans_vector_double_float;
2162 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2163     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2164         trans_vector_long_float;
2165 #endif
2166 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2167     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2168         trans_vector_complex_single_float;
2169 #endif
2170 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2171     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2172         trans_vector_complex_double_float;
2173 #endif
2174 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2175     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2176         trans_vector_complex_long_float;
2177 #endif
2178     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2179 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2180     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2181 #endif
2182     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2183     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2184     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2185     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2186     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2187     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2188     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2189     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2190     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2191     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2192     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2193     transother[CHARACTER_WIDETAG] = trans_immediate;
2194     transother[SAP_WIDETAG] = trans_unboxed;
2195     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2196     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2197     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2198     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2199     transother[FDEFN_WIDETAG] = trans_boxed;
2200
2201     /* size table, initialized the same way as scavtab */
2202     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2203         sizetab[i] = size_lose;
2204     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2205         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2206         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2207         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2208         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2209         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2210         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2211         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2212         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2213     }
2214     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2215     sizetab[RATIO_WIDETAG] = size_boxed;
2216 #if N_WORD_BITS == 64
2217     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2218 #else
2219     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2220 #endif
2221     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2222 #ifdef LONG_FLOAT_WIDETAG
2223     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2224 #endif
2225     sizetab[COMPLEX_WIDETAG] = size_boxed;
2226 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2227     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2228 #endif
2229 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2230     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2231 #endif
2232 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2233     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2234 #endif
2235     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2236     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2237 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2238     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2239 #endif
2240     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2241     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2242     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2243     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2244         size_vector_unsigned_byte_2;
2245     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2246         size_vector_unsigned_byte_4;
2247     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2248         size_vector_unsigned_byte_8;
2249     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2250         size_vector_unsigned_byte_8;
2251     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2252         size_vector_unsigned_byte_16;
2253     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2254         size_vector_unsigned_byte_16;
2255 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2256     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2257         size_vector_unsigned_byte_32;
2258 #endif
2259     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2260         size_vector_unsigned_byte_32;
2261     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2262         size_vector_unsigned_byte_32;
2263 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2264     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2265         size_vector_unsigned_byte_64;
2266 #endif
2267 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2268     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2269         size_vector_unsigned_byte_64;
2270 #endif
2271 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2272     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2273         size_vector_unsigned_byte_64;
2274 #endif
2275 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2276     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2277 #endif
2278 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2279     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2280         size_vector_unsigned_byte_16;
2281 #endif
2282 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2283     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2284         size_vector_unsigned_byte_32;
2285 #endif
2286 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2287     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2288         size_vector_unsigned_byte_32;
2289 #endif
2290 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2291     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2292         size_vector_unsigned_byte_64;
2293 #endif
2294 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2295     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2296         size_vector_unsigned_byte_64;
2297 #endif
2298     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2299     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2300 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2301     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2302 #endif
2303 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2304     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2305         size_vector_complex_single_float;
2306 #endif
2307 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2308     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2309         size_vector_complex_double_float;
2310 #endif
2311 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2312     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2313         size_vector_complex_long_float;
2314 #endif
2315     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2316 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2317     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2318 #endif
2319     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2320     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2321     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2322     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2323     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2324 #if 0
2325     /* We shouldn't see these, so just lose if it happens. */
2326     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2327     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2328 #endif
2329     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2330     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2331     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2332     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2333     sizetab[CHARACTER_WIDETAG] = size_immediate;
2334     sizetab[SAP_WIDETAG] = size_unboxed;
2335     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2336     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2337     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2338     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2339     sizetab[FDEFN_WIDETAG] = size_boxed;
2340 }
2341
2342 \f
2343 /* Find the code object for the given pc, or return NULL on
2344    failure. */
2345 lispobj *
2346 component_ptr_from_pc(lispobj *pc)
2347 {
2348     lispobj *object = NULL;
2349
2350     if ( (object = search_read_only_space(pc)) )
2351         ;
2352     else if ( (object = search_static_space(pc)) )
2353         ;
2354     else
2355         object = search_dynamic_space(pc);
2356
2357     if (object) /* if we found something */
2358         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2359             return(object);
2360
2361     return (NULL);
2362 }
2363
2364 /* Scan an area looking for an object which encloses the given pointer.
2365  * Return the object start on success or NULL on failure. */
2366 lispobj *
2367 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2368 {
2369     while (words > 0) {
2370         size_t count = 1;
2371         lispobj thing = *start;
2372
2373         /* If thing is an immediate then this is a cons. */
2374         if (is_lisp_pointer(thing)
2375             || (fixnump(thing))
2376             || (widetag_of(thing) == CHARACTER_WIDETAG)
2377 #if N_WORD_BITS == 64
2378             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2379 #endif
2380             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2381             count = 2;
2382         else
2383             count = (sizetab[widetag_of(thing)])(start);
2384
2385         /* Check whether the pointer is within this object. */
2386         if ((pointer >= start) && (pointer < (start+count))) {
2387             /* found it! */
2388             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2389             return(start);
2390         }
2391
2392         /* Round up the count. */
2393         count = CEILING(count,2);
2394
2395         start += count;
2396         words -= count;
2397     }
2398     return (NULL);
2399 }
2400
2401 boolean
2402 maybe_gc(os_context_t *context)
2403 {
2404 #ifndef LISP_FEATURE_WIN32
2405     struct thread *thread = arch_os_get_current_thread();
2406 #endif
2407
2408     fake_foreign_function_call(context);
2409     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2410      * which case we will be running with no gc trigger barrier
2411      * thing for a while.  But it shouldn't be long until the end
2412      * of WITHOUT-GCING.
2413      *
2414      * FIXME: It would be good to protect the end of dynamic space for
2415      * CheneyGC and signal a storage condition from there.
2416      */
2417
2418     /* Restore the signal mask from the interrupted context before
2419      * calling into Lisp if interrupts are enabled. Why not always?
2420      *
2421      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2422      * interrupt hits while in SUB-GC, it is deferred and the
2423      * os_context_sigmask of that interrupt is set to block further
2424      * deferrable interrupts (until the first one is
2425      * handled). Unfortunately, that context refers to this place and
2426      * when we return from here the signals will not be blocked.
2427      *
2428      * A kludgy alternative is to propagate the sigmask change to the
2429      * outer context.
2430      */
2431 #ifndef LISP_FEATURE_WIN32
2432     if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) {
2433         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2434 #ifdef LISP_FEATURE_SB_THREAD
2435         /* What if the context we'd like to restore has GC signals
2436          * blocked? Just skip the GC: we can't set GC_PENDING, because
2437          * that would block the next attempt, and we don't know when
2438          * we'd next check for it -- and it's hard to be sure that
2439          * unblocking would be safe.
2440          *
2441          * FIXME: This is not actually much better: we may already have
2442          * GC_PENDING set, and presumably our caller assumes that we will
2443          * clear it. Perhaps we should, even though we don't actually GC? */
2444         if (sigismember(context_sigmask,SIG_STOP_FOR_GC)) {
2445             undo_fake_foreign_function_call(context);
2446             return 1;
2447         }
2448 #endif
2449         thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2450     }
2451     else
2452         unblock_gc_signals();
2453 #endif
2454     /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
2455      * otherwise two threads racing here may deadlock: the other will
2456      * wait on the GC lock, and the other cannot stop the first one... */
2457     funcall0(StaticSymbolFunction(SUB_GC));
2458     undo_fake_foreign_function_call(context);
2459     return 1;
2460 }