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