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     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, "Warning: no pointer at %x in hash table: this indicates non-fatal corruption caused by concurrent access to a hash-table from multiple threads. Any accesses to hash-tables shared between threads should be protected by locks.\n", &where[2]);
1726         // We've scavenged three words.
1727         return 3;
1728     }
1729     hash_table = (struct hash_table *)native_pointer(where[2]);
1730     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1731     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1732         lose("hash table not instance (%x at %x)\n",
1733              hash_table->header,
1734              hash_table);
1735     }
1736
1737     /* Scavenge element 1, which should be some internal symbol that
1738      * the hash table code reserves for marking empty slots. */
1739     scavenge(where+3, 1);
1740     if (!is_lisp_pointer(where[3])) {
1741         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1742     }
1743
1744     /* Scavenge hash table, which will fix the positions of the other
1745      * needed objects. */
1746     scavenge((lispobj *)hash_table,
1747              sizeof(struct hash_table) / sizeof(lispobj));
1748
1749     /* Cross-check the kv_vector. */
1750     if (where != (lispobj *)native_pointer(hash_table->table)) {
1751         lose("hash_table table!=this table %x\n", hash_table->table);
1752     }
1753
1754     if (hash_table->weakness == NIL) {
1755         scav_hash_table_entries(hash_table);
1756     } else {
1757         /* Delay scavenging of this table by pushing it onto
1758          * weak_hash_tables (if it's not there already) for the weak
1759          * object phase. */
1760         if (hash_table->next_weak_hash_table == NIL) {
1761             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1762             weak_hash_tables = hash_table;
1763         }
1764     }
1765
1766     return (CEILING(kv_length + 2, 2));
1767 }
1768
1769 void
1770 scav_weak_hash_tables (void)
1771 {
1772     struct hash_table *table;
1773
1774     /* Scavenge entries whose triggers are known to survive. */
1775     for (table = weak_hash_tables; table != NULL;
1776          table = (struct hash_table *)table->next_weak_hash_table) {
1777         scav_hash_table_entries(table);
1778     }
1779 }
1780
1781 /* Walk through the chain whose first element is *FIRST and remove
1782  * dead weak entries. */
1783 static inline void
1784 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1785                             lispobj *kv_vector, lispobj *index_vector,
1786                             lispobj *next_vector, lispobj *hash_vector,
1787                             lispobj empty_symbol, lispobj weakness)
1788 {
1789     unsigned index = *prev;
1790     while (index) {
1791         unsigned next = next_vector[index];
1792         lispobj key = kv_vector[2 * index];
1793         lispobj value = kv_vector[2 * index + 1];
1794         gc_assert(key != empty_symbol);
1795         gc_assert(value != empty_symbol);
1796         if (!weak_hash_entry_alivep(weakness, key, value)) {
1797             unsigned count = fixnum_value(hash_table->number_entries);
1798             gc_assert(count > 0);
1799             *prev = next;
1800             hash_table->number_entries = make_fixnum(count - 1);
1801             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1802             hash_table->next_free_kv = make_fixnum(index);
1803             kv_vector[2 * index] = empty_symbol;
1804             kv_vector[2 * index + 1] = empty_symbol;
1805             if (hash_vector)
1806                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1807         } else {
1808             prev = &next_vector[index];
1809         }
1810         index = next;
1811     }
1812 }
1813
1814 static void
1815 scan_weak_hash_table (struct hash_table *hash_table)
1816 {
1817     lispobj *kv_vector;
1818     lispobj *index_vector;
1819     unsigned long length = 0; /* prevent warning */
1820     lispobj *next_vector;
1821     unsigned long next_vector_length = 0; /* prevent warning */
1822     lispobj *hash_vector;
1823     lispobj empty_symbol;
1824     lispobj weakness = hash_table->weakness;
1825     long i;
1826
1827     kv_vector = get_array_data(hash_table->table,
1828                                SIMPLE_VECTOR_WIDETAG, NULL);
1829     index_vector = get_array_data(hash_table->index_vector,
1830                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1831     next_vector = get_array_data(hash_table->next_vector,
1832                                  SIMPLE_ARRAY_WORD_WIDETAG,
1833                                  &next_vector_length);
1834     hash_vector = get_array_data(hash_table->hash_vector,
1835                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1836     empty_symbol = kv_vector[1];
1837
1838     for (i = 0; i < length; i++) {
1839         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1840                                    kv_vector, index_vector, next_vector,
1841                                    hash_vector, empty_symbol, weakness);
1842     }
1843 }
1844
1845 /* Remove dead entries from weak hash tables. */
1846 void
1847 scan_weak_hash_tables (void)
1848 {
1849     struct hash_table *table, *next;
1850
1851     for (table = weak_hash_tables; table != NULL; table = next) {
1852         next = (struct hash_table *)table->next_weak_hash_table;
1853         table->next_weak_hash_table = NIL;
1854         scan_weak_hash_table(table);
1855     }
1856
1857     weak_hash_tables = NULL;
1858 }
1859
1860 \f
1861 /*
1862  * initialization
1863  */
1864
1865 static long
1866 scav_lose(lispobj *where, lispobj object)
1867 {
1868     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1869          (unsigned long)object,
1870          widetag_of(*(lispobj*)native_pointer(object)));
1871
1872     return 0; /* bogus return value to satisfy static type checking */
1873 }
1874
1875 static lispobj
1876 trans_lose(lispobj object)
1877 {
1878     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1879          (unsigned long)object,
1880          widetag_of(*(lispobj*)native_pointer(object)));
1881     return NIL; /* bogus return value to satisfy static type checking */
1882 }
1883
1884 static long
1885 size_lose(lispobj *where)
1886 {
1887     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1888          (unsigned long)where,
1889          widetag_of(LOW_WORD(where)));
1890     return 1; /* bogus return value to satisfy static type checking */
1891 }
1892
1893 \f
1894 /*
1895  * initialization
1896  */
1897
1898 void
1899 gc_init_tables(void)
1900 {
1901     long i;
1902
1903     /* Set default value in all slots of scavenge table.  FIXME
1904      * replace this gnarly sizeof with something based on
1905      * N_WIDETAG_BITS */
1906     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1907         scavtab[i] = scav_lose;
1908     }
1909
1910     /* For each type which can be selected by the lowtag alone, set
1911      * multiple entries in our widetag scavenge table (one for each
1912      * possible value of the high bits).
1913      */
1914
1915     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1916         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1917         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1918         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1919         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1920         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1921         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1922         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1923         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1924     }
1925
1926     /* Other-pointer types (those selected by all eight bits of the
1927      * tag) get one entry each in the scavenge table. */
1928     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1929     scavtab[RATIO_WIDETAG] = scav_boxed;
1930 #if N_WORD_BITS == 64
1931     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1932 #else
1933     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1934 #endif
1935     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1936 #ifdef LONG_FLOAT_WIDETAG
1937     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1938 #endif
1939     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1940 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1941     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1942 #endif
1943 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1944     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1945 #endif
1946 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1947     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1948 #endif
1949     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1950     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1951 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1952     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1953 #endif
1954     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1955     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1956     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1957         scav_vector_unsigned_byte_2;
1958     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1959         scav_vector_unsigned_byte_4;
1960     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1961         scav_vector_unsigned_byte_8;
1962     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1963         scav_vector_unsigned_byte_8;
1964     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1965         scav_vector_unsigned_byte_16;
1966     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1967         scav_vector_unsigned_byte_16;
1968 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1969     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1970         scav_vector_unsigned_byte_32;
1971 #endif
1972     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1973         scav_vector_unsigned_byte_32;
1974     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1975         scav_vector_unsigned_byte_32;
1976 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1978         scav_vector_unsigned_byte_64;
1979 #endif
1980 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1981     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1982         scav_vector_unsigned_byte_64;
1983 #endif
1984 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1985     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1986         scav_vector_unsigned_byte_64;
1987 #endif
1988 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1989     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1990 #endif
1991 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1992     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1993         scav_vector_unsigned_byte_16;
1994 #endif
1995 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1996     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1997         scav_vector_unsigned_byte_32;
1998 #endif
1999 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2000     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2001         scav_vector_unsigned_byte_32;
2002 #endif
2003 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2004     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2005         scav_vector_unsigned_byte_64;
2006 #endif
2007 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2008     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2009         scav_vector_unsigned_byte_64;
2010 #endif
2011     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2012     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2013 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2014     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2015 #endif
2016 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2017     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2018         scav_vector_complex_single_float;
2019 #endif
2020 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2021     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2022         scav_vector_complex_double_float;
2023 #endif
2024 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2025     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2026         scav_vector_complex_long_float;
2027 #endif
2028     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2029 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2030     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2031 #endif
2032     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2033     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2034     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2035     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2036     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2037 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2038     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2039     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2040 #endif
2041     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2042 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2043     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2044 #else
2045     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2046 #endif
2047     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2048     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2049     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2050     scavtab[SAP_WIDETAG] = scav_unboxed;
2051     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2052     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2053     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2054 #if defined(LISP_FEATURE_SPARC)
2055     scavtab[FDEFN_WIDETAG] = scav_boxed;
2056 #else
2057     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2058 #endif
2059     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2060
2061     /* transport other table, initialized same way as scavtab */
2062     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2063         transother[i] = trans_lose;
2064     transother[BIGNUM_WIDETAG] = trans_unboxed;
2065     transother[RATIO_WIDETAG] = trans_boxed;
2066
2067 #if N_WORD_BITS == 64
2068     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2069 #else
2070     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2071 #endif
2072     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2073 #ifdef LONG_FLOAT_WIDETAG
2074     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2075 #endif
2076     transother[COMPLEX_WIDETAG] = trans_boxed;
2077 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2078     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2079 #endif
2080 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2081     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2082 #endif
2083 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2084     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2085 #endif
2086     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2087     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2088 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2089     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2090 #endif
2091     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2092     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2093     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2094     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2095         trans_vector_unsigned_byte_2;
2096     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2097         trans_vector_unsigned_byte_4;
2098     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2099         trans_vector_unsigned_byte_8;
2100     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2101         trans_vector_unsigned_byte_8;
2102     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2103         trans_vector_unsigned_byte_16;
2104     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2105         trans_vector_unsigned_byte_16;
2106 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2107     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2108         trans_vector_unsigned_byte_32;
2109 #endif
2110     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2111         trans_vector_unsigned_byte_32;
2112     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2113         trans_vector_unsigned_byte_32;
2114 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2116         trans_vector_unsigned_byte_64;
2117 #endif
2118 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2119     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2120         trans_vector_unsigned_byte_64;
2121 #endif
2122 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2123     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2124         trans_vector_unsigned_byte_64;
2125 #endif
2126 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2127     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2128         trans_vector_unsigned_byte_8;
2129 #endif
2130 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2131     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2132         trans_vector_unsigned_byte_16;
2133 #endif
2134 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2135     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2136         trans_vector_unsigned_byte_32;
2137 #endif
2138 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2139     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2140         trans_vector_unsigned_byte_32;
2141 #endif
2142 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2143     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2144         trans_vector_unsigned_byte_64;
2145 #endif
2146 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2147     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2148         trans_vector_unsigned_byte_64;
2149 #endif
2150     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2151         trans_vector_single_float;
2152     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2153         trans_vector_double_float;
2154 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2155     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2156         trans_vector_long_float;
2157 #endif
2158 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2159     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2160         trans_vector_complex_single_float;
2161 #endif
2162 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2163     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2164         trans_vector_complex_double_float;
2165 #endif
2166 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2167     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2168         trans_vector_complex_long_float;
2169 #endif
2170     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2171 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2172     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2173 #endif
2174     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2175     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2176     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2177     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2178     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2179     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2180     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2181     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2182     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2183     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2184     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2185     transother[CHARACTER_WIDETAG] = trans_immediate;
2186     transother[SAP_WIDETAG] = trans_unboxed;
2187     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2188     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2189     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2190     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2191     transother[FDEFN_WIDETAG] = trans_boxed;
2192
2193     /* size table, initialized the same way as scavtab */
2194     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2195         sizetab[i] = size_lose;
2196     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2197         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2198         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2199         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2200         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2201         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2202         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2203         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2204         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2205     }
2206     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2207     sizetab[RATIO_WIDETAG] = size_boxed;
2208 #if N_WORD_BITS == 64
2209     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2210 #else
2211     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2212 #endif
2213     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2214 #ifdef LONG_FLOAT_WIDETAG
2215     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2216 #endif
2217     sizetab[COMPLEX_WIDETAG] = size_boxed;
2218 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2219     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2220 #endif
2221 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2222     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2223 #endif
2224 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2225     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2226 #endif
2227     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2228     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2229 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2230     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2231 #endif
2232     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2233     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2234     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2235     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2236         size_vector_unsigned_byte_2;
2237     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2238         size_vector_unsigned_byte_4;
2239     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2240         size_vector_unsigned_byte_8;
2241     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2242         size_vector_unsigned_byte_8;
2243     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2244         size_vector_unsigned_byte_16;
2245     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2246         size_vector_unsigned_byte_16;
2247 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2248     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2249         size_vector_unsigned_byte_32;
2250 #endif
2251     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2252         size_vector_unsigned_byte_32;
2253     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2254         size_vector_unsigned_byte_32;
2255 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2256     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2257         size_vector_unsigned_byte_64;
2258 #endif
2259 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2260     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2261         size_vector_unsigned_byte_64;
2262 #endif
2263 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2264     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2265         size_vector_unsigned_byte_64;
2266 #endif
2267 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2268     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2269 #endif
2270 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2271     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2272         size_vector_unsigned_byte_16;
2273 #endif
2274 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2275     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2276         size_vector_unsigned_byte_32;
2277 #endif
2278 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2279     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2280         size_vector_unsigned_byte_32;
2281 #endif
2282 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2283     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2284         size_vector_unsigned_byte_64;
2285 #endif
2286 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2287     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2288         size_vector_unsigned_byte_64;
2289 #endif
2290     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2291     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2292 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2293     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2294 #endif
2295 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2296     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2297         size_vector_complex_single_float;
2298 #endif
2299 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2300     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2301         size_vector_complex_double_float;
2302 #endif
2303 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2304     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2305         size_vector_complex_long_float;
2306 #endif
2307     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2308 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2309     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2310 #endif
2311     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2312     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2313     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2314     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2315     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2316 #if 0
2317     /* We shouldn't see these, so just lose if it happens. */
2318     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2319     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2320 #endif
2321     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2322     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2323     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2324     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2325     sizetab[CHARACTER_WIDETAG] = size_immediate;
2326     sizetab[SAP_WIDETAG] = size_unboxed;
2327     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2328     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2329     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2330     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2331     sizetab[FDEFN_WIDETAG] = size_boxed;
2332 }
2333
2334 \f
2335 /* Find the code object for the given pc, or return NULL on
2336    failure. */
2337 lispobj *
2338 component_ptr_from_pc(lispobj *pc)
2339 {
2340     lispobj *object = NULL;
2341
2342     if ( (object = search_read_only_space(pc)) )
2343         ;
2344     else if ( (object = search_static_space(pc)) )
2345         ;
2346     else
2347         object = search_dynamic_space(pc);
2348
2349     if (object) /* if we found something */
2350         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2351             return(object);
2352
2353     return (NULL);
2354 }
2355
2356 /* Scan an area looking for an object which encloses the given pointer.
2357  * Return the object start on success or NULL on failure. */
2358 lispobj *
2359 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2360 {
2361     while (words > 0) {
2362         size_t count = 1;
2363         lispobj thing = *start;
2364
2365         /* If thing is an immediate then this is a cons. */
2366         if (is_lisp_pointer(thing)
2367             || (fixnump(thing))
2368             || (widetag_of(thing) == CHARACTER_WIDETAG)
2369 #if N_WORD_BITS == 64
2370             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2371 #endif
2372             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2373             count = 2;
2374         else
2375             count = (sizetab[widetag_of(thing)])(start);
2376
2377         /* Check whether the pointer is within this object. */
2378         if ((pointer >= start) && (pointer < (start+count))) {
2379             /* found it! */
2380             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2381             return(start);
2382         }
2383
2384         /* Round up the count. */
2385         count = CEILING(count,2);
2386
2387         start += count;
2388         words -= count;
2389     }
2390     return (NULL);
2391 }
2392
2393 boolean
2394 maybe_gc(os_context_t *context)
2395 {
2396 #ifndef LISP_FEATURE_WIN32
2397     struct thread *thread = arch_os_get_current_thread();
2398 #endif
2399
2400     fake_foreign_function_call(context);
2401     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2402      * which case we will be running with no gc trigger barrier
2403      * thing for a while.  But it shouldn't be long until the end
2404      * of WITHOUT-GCING.
2405      *
2406      * FIXME: It would be good to protect the end of dynamic space for
2407      * CheneyGC and signal a storage condition from there.
2408      */
2409
2410     /* Restore the signal mask from the interrupted context before
2411      * calling into Lisp if interrupts are enabled. Why not always?
2412      *
2413      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2414      * interrupt hits while in SUB-GC, it is deferred and the
2415      * os_context_sigmask of that interrupt is set to block further
2416      * deferrable interrupts (until the first one is
2417      * handled). Unfortunately, that context refers to this place and
2418      * when we return from here the signals will not be blocked.
2419      *
2420      * A kludgy alternative is to propagate the sigmask change to the
2421      * outer context.
2422      */
2423 #ifndef LISP_FEATURE_WIN32
2424     if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) {
2425         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2426 #ifdef LISP_FEATURE_SB_THREAD
2427         /* What if the context we'd like to restore has GC signals
2428          * blocked? Just skip the GC: we can't set GC_PENDING, because
2429          * that would block the next attempt, and we don't know when
2430          * we'd next check for it -- and it's hard to be sure that
2431          * unblocking would be safe.
2432          *
2433          * FIXME: This is not actually much better: we may already have
2434          * GC_PENDING set, and presumably our caller assumes that we will
2435          * clear it. Perhaps we should, even though we don't actually GC? */
2436         if (sigismember(context_sigmask,SIG_STOP_FOR_GC)) {
2437             undo_fake_foreign_function_call(context);
2438             return 1;
2439         }
2440 #endif
2441         thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2442     }
2443     else
2444         unblock_gc_signals();
2445 #endif
2446     /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
2447      * otherwise two threads racing here may deadlock: the other will
2448      * wait on the GC lock, and the other cannot stop the first one... */
2449     funcall0(SymbolFunction(SUB_GC));
2450     undo_fake_foreign_function_call(context);
2451     return 1;
2452 }