src/runtime/gc-common.c

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