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, BOXED_PAGE_FLAG, 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), BOXED_PAGE_FLAG, 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), BOXED_PAGE_FLAG, 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) == fdefn->raw_addr) {
 727         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 728
 729         /* Don't write unnecessarily. */
 730         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 731             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 732         /* gc.c has more casts here, which may be relevant or alternatively
 733            may be compiler warning defeaters.  try
 734         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 735         */
 736         return sizeof(struct fdefn) / sizeof(lispobj);
 737     } else {
 738         return 1;
 739     }
 740 }
 741 #endif
 742
 743 static long
 744 scav_unboxed(lispobj *where, lispobj object)
 745 {
 746     unsigned long length;
 747
 748     length = HeaderValue(object) + 1;
 749     length = CEILING(length, 2);
 750
 751     return length;
 752 }
 753
 754 static lispobj
 755 trans_unboxed(lispobj object)
 756 {
 757     lispobj header;
 758     unsigned long length;
 759
 760
 761     gc_assert(is_lisp_pointer(object));
 762
 763     header = *((lispobj *) native_pointer(object));
 764     length = HeaderValue(header) + 1;
 765     length = CEILING(length, 2);
 766
 767     return copy_unboxed_object(object, length);
 768 }
 769
 770 static long
 771 size_unboxed(lispobj *where)
 772 {
 773     lispobj header;
 774     unsigned long length;
 775
 776     header = *where;
 777     length = HeaderValue(header) + 1;
 778     length = CEILING(length, 2);
 779
 780     return length;
 781 }
 782
 783 \f
 784 /* vector-like objects */
 785 static long
 786 scav_base_string(lispobj *where, lispobj object)
 787 {
 788     struct vector *vector;
 789     long length, nwords;
 790
 791     /* NOTE: Strings contain one more byte of data than the length */
 792     /* slot indicates. */
 793
 794     vector = (struct vector *) where;
 795     length = fixnum_value(vector->length) + 1;
 796     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 797
 798     return nwords;
 799 }
 800 static lispobj
 801 trans_base_string(lispobj object)
 802 {
 803     struct vector *vector;
 804     long length, nwords;
 805
 806     gc_assert(is_lisp_pointer(object));
 807
 808     /* NOTE: A string contains one more byte of data (a terminating
 809      * '\0' to help when interfacing with C functions) than indicated
 810      * by the length slot. */
 811
 812     vector = (struct vector *) native_pointer(object);
 813     length = fixnum_value(vector->length) + 1;
 814     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 815
 816     return copy_large_unboxed_object(object, nwords);
 817 }
 818
 819 static long
 820 size_base_string(lispobj *where)
 821 {
 822     struct vector *vector;
 823     long length, nwords;
 824
 825     /* NOTE: A string contains one more byte of data (a terminating
 826      * '\0' to help when interfacing with C functions) than indicated
 827      * by the length slot. */
 828
 829     vector = (struct vector *) where;
 830     length = fixnum_value(vector->length) + 1;
 831     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 832
 833     return nwords;
 834 }
 835
 836 static long
 837 scav_character_string(lispobj *where, lispobj object)
 838 {
 839     struct vector *vector;
 840     int length, nwords;
 841
 842     /* NOTE: Strings contain one more byte of data than the length */
 843     /* slot indicates. */
 844
 845     vector = (struct vector *) where;
 846     length = fixnum_value(vector->length) + 1;
 847     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 848
 849     return nwords;
 850 }
 851 static lispobj
 852 trans_character_string(lispobj object)
 853 {
 854     struct vector *vector;
 855     int length, nwords;
 856
 857     gc_assert(is_lisp_pointer(object));
 858
 859     /* NOTE: A string contains one more byte of data (a terminating
 860      * '\0' to help when interfacing with C functions) than indicated
 861      * by the length slot. */
 862
 863     vector = (struct vector *) native_pointer(object);
 864     length = fixnum_value(vector->length) + 1;
 865     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 866
 867     return copy_large_unboxed_object(object, nwords);
 868 }
 869
 870 static long
 871 size_character_string(lispobj *where)
 872 {
 873     struct vector *vector;
 874     int length, nwords;
 875
 876     /* NOTE: A string contains one more byte of data (a terminating
 877      * '\0' to help when interfacing with C functions) than indicated
 878      * by the length slot. */
 879
 880     vector = (struct vector *) where;
 881     length = fixnum_value(vector->length) + 1;
 882     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 883
 884     return nwords;
 885 }
 886
 887 static lispobj
 888 trans_vector(lispobj object)
 889 {
 890     struct vector *vector;
 891     long length, nwords;
 892
 893     gc_assert(is_lisp_pointer(object));
 894
 895     vector = (struct vector *) native_pointer(object);
 896
 897     length = fixnum_value(vector->length);
 898     nwords = CEILING(length + 2, 2);
 899
 900     return copy_large_object(object, nwords);
 901 }
 902
 903 static long
 904 size_vector(lispobj *where)
 905 {
 906     struct vector *vector;
 907     long length, nwords;
 908
 909     vector = (struct vector *) where;
 910     length = fixnum_value(vector->length);
 911     nwords = CEILING(length + 2, 2);
 912
 913     return nwords;
 914 }
 915
 916 static long
 917 scav_vector_nil(lispobj *where, lispobj object)
 918 {
 919     return 2;
 920 }
 921
 922 static lispobj
 923 trans_vector_nil(lispobj object)
 924 {
 925     gc_assert(is_lisp_pointer(object));
 926     return copy_unboxed_object(object, 2);
 927 }
 928
 929 static long
 930 size_vector_nil(lispobj *where)
 931 {
 932     /* Just the header word and the length word */
 933     return 2;
 934 }
 935
 936 static long
 937 scav_vector_bit(lispobj *where, lispobj object)
 938 {
 939     struct vector *vector;
 940     long length, nwords;
 941
 942     vector = (struct vector *) where;
 943     length = fixnum_value(vector->length);
 944     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 945
 946     return nwords;
 947 }
 948
 949 static lispobj
 950 trans_vector_bit(lispobj object)
 951 {
 952     struct vector *vector;
 953     long length, nwords;
 954
 955     gc_assert(is_lisp_pointer(object));
 956
 957     vector = (struct vector *) native_pointer(object);
 958     length = fixnum_value(vector->length);
 959     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 960
 961     return copy_large_unboxed_object(object, nwords);
 962 }
 963
 964 static long
 965 size_vector_bit(lispobj *where)
 966 {
 967     struct vector *vector;
 968     long length, nwords;
 969
 970     vector = (struct vector *) where;
 971     length = fixnum_value(vector->length);
 972     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 973
 974     return nwords;
 975 }
 976
 977 static long
 978 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 979 {
 980     struct vector *vector;
 981     long length, nwords;
 982
 983     vector = (struct vector *) where;
 984     length = fixnum_value(vector->length);
 985     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 986
 987     return nwords;
 988 }
 989
 990 static lispobj
 991 trans_vector_unsigned_byte_2(lispobj object)
 992 {
 993     struct vector *vector;
 994     long length, nwords;
 995
 996     gc_assert(is_lisp_pointer(object));
 997
 998     vector = (struct vector *) native_pointer(object);
 999     length = fixnum_value(vector->length);
1000     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1001
1002     return copy_large_unboxed_object(object, nwords);
1003 }
1004
1005 static long
1006 size_vector_unsigned_byte_2(lispobj *where)
1007 {
1008     struct vector *vector;
1009     long length, nwords;
1010
1011     vector = (struct vector *) where;
1012     length = fixnum_value(vector->length);
1013     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1014
1015     return nwords;
1016 }
1017
1018 static long
1019 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1020 {
1021     struct vector *vector;
1022     long length, nwords;
1023
1024     vector = (struct vector *) where;
1025     length = fixnum_value(vector->length);
1026     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1027
1028     return nwords;
1029 }
1030
1031 static lispobj
1032 trans_vector_unsigned_byte_4(lispobj object)
1033 {
1034     struct vector *vector;
1035     long length, nwords;
1036
1037     gc_assert(is_lisp_pointer(object));
1038
1039     vector = (struct vector *) native_pointer(object);
1040     length = fixnum_value(vector->length);
1041     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1042
1043     return copy_large_unboxed_object(object, nwords);
1044 }
1045 static long
1046 size_vector_unsigned_byte_4(lispobj *where)
1047 {
1048     struct vector *vector;
1049     long length, nwords;
1050
1051     vector = (struct vector *) where;
1052     length = fixnum_value(vector->length);
1053     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1054
1055     return nwords;
1056 }
1057
1058
1059 static long
1060 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1061 {
1062     struct vector *vector;
1063     long length, nwords;
1064
1065     vector = (struct vector *) where;
1066     length = fixnum_value(vector->length);
1067     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1068
1069     return nwords;
1070 }
1071
1072 /*********************/
1073
1074
1075
1076 static lispobj
1077 trans_vector_unsigned_byte_8(lispobj object)
1078 {
1079     struct vector *vector;
1080     long length, nwords;
1081
1082     gc_assert(is_lisp_pointer(object));
1083
1084     vector = (struct vector *) native_pointer(object);
1085     length = fixnum_value(vector->length);
1086     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1087
1088     return copy_large_unboxed_object(object, nwords);
1089 }
1090
1091 static long
1092 size_vector_unsigned_byte_8(lispobj *where)
1093 {
1094     struct vector *vector;
1095     long length, nwords;
1096
1097     vector = (struct vector *) where;
1098     length = fixnum_value(vector->length);
1099     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1100
1101     return nwords;
1102 }
1103
1104
1105 static long
1106 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1107 {
1108     struct vector *vector;
1109     long length, nwords;
1110
1111     vector = (struct vector *) where;
1112     length = fixnum_value(vector->length);
1113     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1114
1115     return nwords;
1116 }
1117
1118 static lispobj
1119 trans_vector_unsigned_byte_16(lispobj object)
1120 {
1121     struct vector *vector;
1122     long length, nwords;
1123
1124     gc_assert(is_lisp_pointer(object));
1125
1126     vector = (struct vector *) native_pointer(object);
1127     length = fixnum_value(vector->length);
1128     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1129
1130     return copy_large_unboxed_object(object, nwords);
1131 }
1132
1133 static long
1134 size_vector_unsigned_byte_16(lispobj *where)
1135 {
1136     struct vector *vector;
1137     long length, nwords;
1138
1139     vector = (struct vector *) where;
1140     length = fixnum_value(vector->length);
1141     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1142
1143     return nwords;
1144 }
1145
1146 static long
1147 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1148 {
1149     struct vector *vector;
1150     long length, nwords;
1151
1152     vector = (struct vector *) where;
1153     length = fixnum_value(vector->length);
1154     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1155
1156     return nwords;
1157 }
1158
1159 static lispobj
1160 trans_vector_unsigned_byte_32(lispobj object)
1161 {
1162     struct vector *vector;
1163     long length, nwords;
1164
1165     gc_assert(is_lisp_pointer(object));
1166
1167     vector = (struct vector *) native_pointer(object);
1168     length = fixnum_value(vector->length);
1169     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1170
1171     return copy_large_unboxed_object(object, nwords);
1172 }
1173
1174 static long
1175 size_vector_unsigned_byte_32(lispobj *where)
1176 {
1177     struct vector *vector;
1178     long length, nwords;
1179
1180     vector = (struct vector *) where;
1181     length = fixnum_value(vector->length);
1182     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1183
1184     return nwords;
1185 }
1186
1187 #if N_WORD_BITS == 64
1188 static long
1189 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1190 {
1191     struct vector *vector;
1192     long length, nwords;
1193
1194     vector = (struct vector *) where;
1195     length = fixnum_value(vector->length);
1196     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1197
1198     return nwords;
1199 }
1200
1201 static lispobj
1202 trans_vector_unsigned_byte_64(lispobj object)
1203 {
1204     struct vector *vector;
1205     long length, nwords;
1206
1207     gc_assert(is_lisp_pointer(object));
1208
1209     vector = (struct vector *) native_pointer(object);
1210     length = fixnum_value(vector->length);
1211     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1212
1213     return copy_large_unboxed_object(object, nwords);
1214 }
1215
1216 static long
1217 size_vector_unsigned_byte_64(lispobj *where)
1218 {
1219     struct vector *vector;
1220     long length, nwords;
1221
1222     vector = (struct vector *) where;
1223     length = fixnum_value(vector->length);
1224     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1225
1226     return nwords;
1227 }
1228 #endif
1229
1230 static long
1231 scav_vector_single_float(lispobj *where, lispobj object)
1232 {
1233     struct vector *vector;
1234     long length, nwords;
1235
1236     vector = (struct vector *) where;
1237     length = fixnum_value(vector->length);
1238     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1239
1240     return nwords;
1241 }
1242
1243 static lispobj
1244 trans_vector_single_float(lispobj object)
1245 {
1246     struct vector *vector;
1247     long length, nwords;
1248
1249     gc_assert(is_lisp_pointer(object));
1250
1251     vector = (struct vector *) native_pointer(object);
1252     length = fixnum_value(vector->length);
1253     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1254
1255     return copy_large_unboxed_object(object, nwords);
1256 }
1257
1258 static long
1259 size_vector_single_float(lispobj *where)
1260 {
1261     struct vector *vector;
1262     long length, nwords;
1263
1264     vector = (struct vector *) where;
1265     length = fixnum_value(vector->length);
1266     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1267
1268     return nwords;
1269 }
1270
1271 static long
1272 scav_vector_double_float(lispobj *where, lispobj object)
1273 {
1274     struct vector *vector;
1275     long length, nwords;
1276
1277     vector = (struct vector *) where;
1278     length = fixnum_value(vector->length);
1279     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1280
1281     return nwords;
1282 }
1283
1284 static lispobj
1285 trans_vector_double_float(lispobj object)
1286 {
1287     struct vector *vector;
1288     long length, nwords;
1289
1290     gc_assert(is_lisp_pointer(object));
1291
1292     vector = (struct vector *) native_pointer(object);
1293     length = fixnum_value(vector->length);
1294     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1295
1296     return copy_large_unboxed_object(object, nwords);
1297 }
1298
1299 static long
1300 size_vector_double_float(lispobj *where)
1301 {
1302     struct vector *vector;
1303     long length, nwords;
1304
1305     vector = (struct vector *) where;
1306     length = fixnum_value(vector->length);
1307     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1308
1309     return nwords;
1310 }
1311
1312 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1313 static long
1314 scav_vector_long_float(lispobj *where, lispobj object)
1315 {
1316     struct vector *vector;
1317     long length, nwords;
1318
1319     vector = (struct vector *) where;
1320     length = fixnum_value(vector->length);
1321     nwords = CEILING(length *
1322                      LONG_FLOAT_SIZE
1323                      + 2, 2);
1324     return nwords;
1325 }
1326
1327 static lispobj
1328 trans_vector_long_float(lispobj object)
1329 {
1330     struct vector *vector;
1331     long length, nwords;
1332
1333     gc_assert(is_lisp_pointer(object));
1334
1335     vector = (struct vector *) native_pointer(object);
1336     length = fixnum_value(vector->length);
1337     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1338
1339     return copy_large_unboxed_object(object, nwords);
1340 }
1341
1342 static long
1343 size_vector_long_float(lispobj *where)
1344 {
1345     struct vector *vector;
1346     long length, nwords;
1347
1348     vector = (struct vector *) where;
1349     length = fixnum_value(vector->length);
1350     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1351
1352     return nwords;
1353 }
1354 #endif
1355
1356
1357 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1358 static long
1359 scav_vector_complex_single_float(lispobj *where, lispobj object)
1360 {
1361     struct vector *vector;
1362     long length, nwords;
1363
1364     vector = (struct vector *) where;
1365     length = fixnum_value(vector->length);
1366     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1367
1368     return nwords;
1369 }
1370
1371 static lispobj
1372 trans_vector_complex_single_float(lispobj object)
1373 {
1374     struct vector *vector;
1375     long length, nwords;
1376
1377     gc_assert(is_lisp_pointer(object));
1378
1379     vector = (struct vector *) native_pointer(object);
1380     length = fixnum_value(vector->length);
1381     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1382
1383     return copy_large_unboxed_object(object, nwords);
1384 }
1385
1386 static long
1387 size_vector_complex_single_float(lispobj *where)
1388 {
1389     struct vector *vector;
1390     long length, nwords;
1391
1392     vector = (struct vector *) where;
1393     length = fixnum_value(vector->length);
1394     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1395
1396     return nwords;
1397 }
1398 #endif
1399
1400 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1401 static long
1402 scav_vector_complex_double_float(lispobj *where, lispobj object)
1403 {
1404     struct vector *vector;
1405     long length, nwords;
1406
1407     vector = (struct vector *) where;
1408     length = fixnum_value(vector->length);
1409     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1410
1411     return nwords;
1412 }
1413
1414 static lispobj
1415 trans_vector_complex_double_float(lispobj object)
1416 {
1417     struct vector *vector;
1418     long length, nwords;
1419
1420     gc_assert(is_lisp_pointer(object));
1421
1422     vector = (struct vector *) native_pointer(object);
1423     length = fixnum_value(vector->length);
1424     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1425
1426     return copy_large_unboxed_object(object, nwords);
1427 }
1428
1429 static long
1430 size_vector_complex_double_float(lispobj *where)
1431 {
1432     struct vector *vector;
1433     long length, nwords;
1434
1435     vector = (struct vector *) where;
1436     length = fixnum_value(vector->length);
1437     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1438
1439     return nwords;
1440 }
1441 #endif
1442
1443
1444 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1445 static long
1446 scav_vector_complex_long_float(lispobj *where, lispobj object)
1447 {
1448     struct vector *vector;
1449     long length, nwords;
1450
1451     vector = (struct vector *) where;
1452     length = fixnum_value(vector->length);
1453     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1454
1455     return nwords;
1456 }
1457
1458 static lispobj
1459 trans_vector_complex_long_float(lispobj object)
1460 {
1461     struct vector *vector;
1462     long length, nwords;
1463
1464     gc_assert(is_lisp_pointer(object));
1465
1466     vector = (struct vector *) native_pointer(object);
1467     length = fixnum_value(vector->length);
1468     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1469
1470     return copy_large_unboxed_object(object, nwords);
1471 }
1472
1473 static long
1474 size_vector_complex_long_float(lispobj *where)
1475 {
1476     struct vector *vector;
1477     long length, nwords;
1478
1479     vector = (struct vector *) where;
1480     length = fixnum_value(vector->length);
1481     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1482
1483     return nwords;
1484 }
1485 #endif
1486
1487 #define WEAK_POINTER_NWORDS \
1488         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1489
1490 static lispobj
1491 trans_weak_pointer(lispobj object)
1492 {
1493     lispobj copy;
1494 #ifndef LISP_FEATURE_GENCGC
1495     struct weak_pointer *wp;
1496 #endif
1497     gc_assert(is_lisp_pointer(object));
1498
1499 #if defined(DEBUG_WEAK)
1500     printf("Transporting weak pointer from 0x%08x\n", object);
1501 #endif
1502
1503     /* Need to remember where all the weak pointers are that have */
1504     /* been transported so they can be fixed up in a post-GC pass. */
1505
1506     copy = copy_object(object, WEAK_POINTER_NWORDS);
1507 #ifndef LISP_FEATURE_GENCGC
1508     wp = (struct weak_pointer *) native_pointer(copy);
1509
1510     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1511     /* Push the weak pointer onto the list of weak pointers. */
1512     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1513     weak_pointers = wp;
1514 #endif
1515     return copy;
1516 }
1517
1518 static long
1519 size_weak_pointer(lispobj *where)
1520 {
1521     return WEAK_POINTER_NWORDS;
1522 }
1523
1524
1525 void scan_weak_pointers(void)
1526 {
1527     struct weak_pointer *wp, *next_wp;
1528     for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
1529         lispobj value = wp->value;
1530         lispobj *first_pointer;
1531         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1532
1533         next_wp = wp->next;
1534         wp->next = NULL;
1535         if (next_wp == wp) /* gencgc uses a ref to self for end of list */
1536             next_wp = NULL;
1537
1538         if (!(is_lisp_pointer(value) && from_space_p(value)))
1539             continue;
1540
1541         /* Now, we need to check whether the object has been forwarded. If
1542          * it has been, the weak pointer is still good and needs to be
1543          * updated. Otherwise, the weak pointer needs to be nil'ed
1544          * out. */
1545
1546         first_pointer = (lispobj *)native_pointer(value);
1547
1548         if (forwarding_pointer_p(first_pointer)) {
1549             wp->value=
1550                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1551         } else {
1552             /* Break it. */
1553             wp->value = NIL;
1554             wp->broken = T;
1555         }
1556     }
1557 }
1558
1559 \f
1560 /* Hash tables */
1561
1562 #if N_WORD_BITS == 32
1563 #define EQ_HASH_MASK 0x1fffffff
1564 #elif N_WORD_BITS == 64
1565 #define EQ_HASH_MASK 0x1fffffffffffffff
1566 #endif
1567
1568 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1569  * target-hash-table.lisp.  */
1570 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1571
1572 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1573  * slot. Set to NULL at the end of a collection.
1574  *
1575  * This is not optimal because, when a table is tenured, it won't be
1576  * processed automatically; only the yougest generation is GC'd by
1577  * default. On the other hand, all applications will need an
1578  * occasional full GC anyway, so it's not that bad either.  */
1579 struct hash_table *weak_hash_tables = NULL;
1580
1581 /* Return true if OBJ has already survived the current GC. */
1582 static inline int
1583 survived_gc_yet (lispobj obj)
1584 {
1585     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1586             forwarding_pointer_p(native_pointer(obj)));
1587 }
1588
1589 static inline int
1590 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1591 {
1592     switch (weakness) {
1593     case KEY:
1594         return survived_gc_yet(key);
1595     case VALUE:
1596         return survived_gc_yet(value);
1597     case KEY_OR_VALUE:
1598         return (survived_gc_yet(key) || survived_gc_yet(value));
1599     case KEY_AND_VALUE:
1600         return (survived_gc_yet(key) && survived_gc_yet(value));
1601     default:
1602         gc_assert(0);
1603         /* Shut compiler up. */
1604         return 0;
1605     }
1606 }
1607
1608 /* Return the beginning of data in ARRAY (skipping the header and the
1609  * length) or NULL if it isn't an array of the specified widetag after
1610  * all. */
1611 static inline lispobj *
1612 get_array_data (lispobj array, int widetag, unsigned long *length)
1613 {
1614     if (is_lisp_pointer(array) &&
1615         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1616         if (length != NULL)
1617             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1618         return ((lispobj *)native_pointer(array)) + 2;
1619     } else {
1620         return NULL;
1621     }
1622 }
1623
1624 /* Only need to worry about scavenging the _real_ entries in the
1625  * table. Phantom entries such as the hash table itself at index 0 and
1626  * the empty marker at index 1 were scavenged by scav_vector that
1627  * either called this function directly or arranged for it to be
1628  * called later by pushing the hash table onto weak_hash_tables. */
1629 static void
1630 scav_hash_table_entries (struct hash_table *hash_table)
1631 {
1632     lispobj *kv_vector;
1633     unsigned long kv_length;
1634     lispobj *index_vector;
1635     unsigned long length;
1636     lispobj *next_vector;
1637     unsigned long next_vector_length;
1638     lispobj *hash_vector;
1639     unsigned long hash_vector_length;
1640     lispobj empty_symbol;
1641     lispobj weakness = hash_table->weakness;
1642     unsigned long i;
1643
1644     kv_vector = get_array_data(hash_table->table,
1645                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1646     if (kv_vector == NULL)
1647         lose("invalid kv_vector %x\n", hash_table->table);
1648
1649     index_vector = get_array_data(hash_table->index_vector,
1650                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1651     if (index_vector == NULL)
1652         lose("invalid index_vector %x\n", hash_table->index_vector);
1653
1654     next_vector = get_array_data(hash_table->next_vector,
1655                                  SIMPLE_ARRAY_WORD_WIDETAG,
1656                                  &next_vector_length);
1657     if (next_vector == NULL)
1658         lose("invalid next_vector %x\n", hash_table->next_vector);
1659
1660     hash_vector = get_array_data(hash_table->hash_vector,
1661                                  SIMPLE_ARRAY_WORD_WIDETAG,
1662                                  &hash_vector_length);
1663     if (hash_vector != NULL)
1664         gc_assert(hash_vector_length == next_vector_length);
1665
1666      /* These lengths could be different as the index_vector can be a
1667       * different length from the others, a larger index_vector could
1668       * help reduce collisions. */
1669      gc_assert(next_vector_length*2 == kv_length);
1670
1671     empty_symbol = kv_vector[1];
1672     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1673     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1674         SYMBOL_HEADER_WIDETAG) {
1675         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1676              *(lispobj *)native_pointer(empty_symbol));
1677     }
1678
1679     /* Work through the KV vector. */
1680     for (i = 1; i < next_vector_length; i++) {
1681         lispobj old_key = kv_vector[2*i];
1682         lispobj value = kv_vector[2*i+1];
1683         if ((weakness == NIL) ||
1684             weak_hash_entry_alivep(weakness, old_key, value)) {
1685
1686             /* Scavenge the key and value. */
1687             scavenge(&kv_vector[2*i],2);
1688
1689             /* If an EQ-based key has moved, mark the hash-table for
1690              * rehashing. */
1691             if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
1692                 lispobj new_key = kv_vector[2*i];
1693
1694                 if (old_key != new_key && new_key != empty_symbol) {
1695                     hash_table->needs_rehash_p = T;
1696                 }
1697             }
1698         }
1699     }
1700 }
1701
1702 long
1703 scav_vector (lispobj *where, lispobj object)
1704 {
1705     unsigned long kv_length;
1706     lispobj *kv_vector;
1707     struct hash_table *hash_table;
1708
1709     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1710      * hash tables in the Lisp HASH-TABLE code to indicate need for
1711      * special GC support. */
1712     if (HeaderValue(object) == subtype_VectorNormal)
1713         return 1;
1714
1715     kv_length = fixnum_value(where[1]);
1716     kv_vector = where + 2;  /* Skip the header and length. */
1717     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1718
1719     /* Scavenge element 0, which may be a hash-table structure. */
1720     scavenge(where+2, 1);
1721     if (!is_lisp_pointer(where[2])) {
1722         /* This'll happen when REHASH clears the header of old-kv-vector
1723          * and fills it with zero, but some other thread simulatenously
1724          * sets the header in %%PUTHASH.
1725          */
1726         fprintf(stderr,
1727                 "Warning: no pointer at %lx in hash table: this indicates "
1728                 "non-fatal corruption caused by concurrent access to a "
1729                 "hash-table from multiple threads. Any accesses to "
1730                 "hash-tables shared between threads should be protected "
1731                 "by locks.\n", (unsigned long)&where[2]);
1732         // We've scavenged three words.
1733         return 3;
1734     }
1735     hash_table = (struct hash_table *)native_pointer(where[2]);
1736     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1737     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1738         lose("hash table not instance (%x at %x)\n",
1739              hash_table->header,
1740              hash_table);
1741     }
1742
1743     /* Scavenge element 1, which should be some internal symbol that
1744      * the hash table code reserves for marking empty slots. */
1745     scavenge(where+3, 1);
1746     if (!is_lisp_pointer(where[3])) {
1747         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1748     }
1749
1750     /* Scavenge hash table, which will fix the positions of the other
1751      * needed objects. */
1752     scavenge((lispobj *)hash_table,
1753              sizeof(struct hash_table) / sizeof(lispobj));
1754
1755     /* Cross-check the kv_vector. */
1756     if (where != (lispobj *)native_pointer(hash_table->table)) {
1757         lose("hash_table table!=this table %x\n", hash_table->table);
1758     }
1759
1760     if (hash_table->weakness == NIL) {
1761         scav_hash_table_entries(hash_table);
1762     } else {
1763         /* Delay scavenging of this table by pushing it onto
1764          * weak_hash_tables (if it's not there already) for the weak
1765          * object phase. */
1766         if (hash_table->next_weak_hash_table == NIL) {
1767             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1768             weak_hash_tables = hash_table;
1769         }
1770     }
1771
1772     return (CEILING(kv_length + 2, 2));
1773 }
1774
1775 void
1776 scav_weak_hash_tables (void)
1777 {
1778     struct hash_table *table;
1779
1780     /* Scavenge entries whose triggers are known to survive. */
1781     for (table = weak_hash_tables; table != NULL;
1782          table = (struct hash_table *)table->next_weak_hash_table) {
1783         scav_hash_table_entries(table);
1784     }
1785 }
1786
1787 /* Walk through the chain whose first element is *FIRST and remove
1788  * dead weak entries. */
1789 static inline void
1790 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1791                             lispobj *kv_vector, lispobj *index_vector,
1792                             lispobj *next_vector, lispobj *hash_vector,
1793                             lispobj empty_symbol, lispobj weakness)
1794 {
1795     unsigned index = *prev;
1796     while (index) {
1797         unsigned next = next_vector[index];
1798         lispobj key = kv_vector[2 * index];
1799         lispobj value = kv_vector[2 * index + 1];
1800         gc_assert(key != empty_symbol);
1801         gc_assert(value != empty_symbol);
1802         if (!weak_hash_entry_alivep(weakness, key, value)) {
1803             unsigned count = fixnum_value(hash_table->number_entries);
1804             gc_assert(count > 0);
1805             *prev = next;
1806             hash_table->number_entries = make_fixnum(count - 1);
1807             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1808             hash_table->next_free_kv = make_fixnum(index);
1809             kv_vector[2 * index] = empty_symbol;
1810             kv_vector[2 * index + 1] = empty_symbol;
1811             if (hash_vector)
1812                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1813         } else {
1814             prev = &next_vector[index];
1815         }
1816         index = next;
1817     }
1818 }
1819
1820 static void
1821 scan_weak_hash_table (struct hash_table *hash_table)
1822 {
1823     lispobj *kv_vector;
1824     lispobj *index_vector;
1825     unsigned long length = 0; /* prevent warning */
1826     lispobj *next_vector;
1827     unsigned long next_vector_length = 0; /* prevent warning */
1828     lispobj *hash_vector;
1829     lispobj empty_symbol;
1830     lispobj weakness = hash_table->weakness;
1831     unsigned long i;
1832
1833     kv_vector = get_array_data(hash_table->table,
1834                                SIMPLE_VECTOR_WIDETAG, NULL);
1835     index_vector = get_array_data(hash_table->index_vector,
1836                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1837     next_vector = get_array_data(hash_table->next_vector,
1838                                  SIMPLE_ARRAY_WORD_WIDETAG,
1839                                  &next_vector_length);
1840     hash_vector = get_array_data(hash_table->hash_vector,
1841                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1842     empty_symbol = kv_vector[1];
1843
1844     for (i = 0; i < length; i++) {
1845         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1846                                    kv_vector, index_vector, next_vector,
1847                                    hash_vector, empty_symbol, weakness);
1848     }
1849 }
1850
1851 /* Remove dead entries from weak hash tables. */
1852 void
1853 scan_weak_hash_tables (void)
1854 {
1855     struct hash_table *table, *next;
1856
1857     for (table = weak_hash_tables; table != NULL; table = next) {
1858         next = (struct hash_table *)table->next_weak_hash_table;
1859         table->next_weak_hash_table = NIL;
1860         scan_weak_hash_table(table);
1861     }
1862
1863     weak_hash_tables = NULL;
1864 }
1865
1866 \f
1867 /*
1868  * initialization
1869  */
1870
1871 static long
1872 scav_lose(lispobj *where, lispobj object)
1873 {
1874     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1875          (unsigned long)object,
1876          widetag_of(*(lispobj*)native_pointer(object)));
1877
1878     return 0; /* bogus return value to satisfy static type checking */
1879 }
1880
1881 static lispobj
1882 trans_lose(lispobj object)
1883 {
1884     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1885          (unsigned long)object,
1886          widetag_of(*(lispobj*)native_pointer(object)));
1887     return NIL; /* bogus return value to satisfy static type checking */
1888 }
1889
1890 static long
1891 size_lose(lispobj *where)
1892 {
1893     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1894          (unsigned long)where,
1895          widetag_of(LOW_WORD(where)));
1896     return 1; /* bogus return value to satisfy static type checking */
1897 }
1898
1899 \f
1900 /*
1901  * initialization
1902  */
1903
1904 void
1905 gc_init_tables(void)
1906 {
1907     unsigned long i;
1908
1909     /* Set default value in all slots of scavenge table.  FIXME
1910      * replace this gnarly sizeof with something based on
1911      * N_WIDETAG_BITS */
1912     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1913         scavtab[i] = scav_lose;
1914     }
1915
1916     /* For each type which can be selected by the lowtag alone, set
1917      * multiple entries in our widetag scavenge table (one for each
1918      * possible value of the high bits).
1919      */
1920
1921     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1922         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1923         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1924         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1925         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1926         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1927         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1928             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 }