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;
1527     for (wp = weak_pointers; wp != NULL; wp=wp->next) {
1528         lispobj value = wp->value;
1529         lispobj *first_pointer;
1530         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1531         if (!(is_lisp_pointer(value) && from_space_p(value)))
1532             continue;
1533
1534         /* Now, we need to check whether the object has been forwarded. If
1535          * it has been, the weak pointer is still good and needs to be
1536          * updated. Otherwise, the weak pointer needs to be nil'ed
1537          * out. */
1538
1539         first_pointer = (lispobj *)native_pointer(value);
1540
1541         if (forwarding_pointer_p(first_pointer)) {
1542             wp->value=
1543                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1544         } else {
1545             /* Break it. */
1546             wp->value = NIL;
1547             wp->broken = T;
1548         }
1549     }
1550 }
1551
1552 \f
1553 /* Hash tables */
1554
1555 #if N_WORD_BITS == 32
1556 #define EQ_HASH_MASK 0x1fffffff
1557 #elif N_WORD_BITS == 64
1558 #define EQ_HASH_MASK 0x1fffffffffffffff
1559 #endif
1560
1561 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1562  * target-hash-table.lisp.  */
1563 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1564
1565 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1566  * slot. Set to NULL at the end of a collection.
1567  *
1568  * This is not optimal because, when a table is tenured, it won't be
1569  * processed automatically; only the yougest generation is GC'd by
1570  * default. On the other hand, all applications will need an
1571  * occasional full GC anyway, so it's not that bad either.  */
1572 struct hash_table *weak_hash_tables = NULL;
1573
1574 /* Return true if OBJ has already survived the current GC. */
1575 static inline int
1576 survived_gc_yet (lispobj obj)
1577 {
1578     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1579             forwarding_pointer_p(native_pointer(obj)));
1580 }
1581
1582 static inline int
1583 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1584 {
1585     switch (weakness) {
1586     case KEY:
1587         return survived_gc_yet(key);
1588     case VALUE:
1589         return survived_gc_yet(value);
1590     case KEY_OR_VALUE:
1591         return (survived_gc_yet(key) || survived_gc_yet(value));
1592     case KEY_AND_VALUE:
1593         return (survived_gc_yet(key) && survived_gc_yet(value));
1594     default:
1595         gc_assert(0);
1596         /* Shut compiler up. */
1597         return 0;
1598     }
1599 }
1600
1601 /* Return the beginning of data in ARRAY (skipping the header and the
1602  * length) or NULL if it isn't an array of the specified widetag after
1603  * all. */
1604 static inline lispobj *
1605 get_array_data (lispobj array, int widetag, unsigned long *length)
1606 {
1607     if (is_lisp_pointer(array) &&
1608         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1609         if (length != NULL)
1610             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1611         return ((lispobj *)native_pointer(array)) + 2;
1612     } else {
1613         return NULL;
1614     }
1615 }
1616
1617 /* Only need to worry about scavenging the _real_ entries in the
1618  * table. Phantom entries such as the hash table itself at index 0 and
1619  * the empty marker at index 1 were scavenged by scav_vector that
1620  * either called this function directly or arranged for it to be
1621  * called later by pushing the hash table onto weak_hash_tables. */
1622 static void
1623 scav_hash_table_entries (struct hash_table *hash_table)
1624 {
1625     lispobj *kv_vector;
1626     unsigned long kv_length;
1627     lispobj *index_vector;
1628     unsigned long length;
1629     lispobj *next_vector;
1630     unsigned long next_vector_length;
1631     lispobj *hash_vector;
1632     unsigned long hash_vector_length;
1633     lispobj empty_symbol;
1634     lispobj weakness = hash_table->weakness;
1635     long i;
1636
1637     kv_vector = get_array_data(hash_table->table,
1638                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1639     if (kv_vector == NULL)
1640         lose("invalid kv_vector %x\n", hash_table->table);
1641
1642     index_vector = get_array_data(hash_table->index_vector,
1643                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1644     if (index_vector == NULL)
1645         lose("invalid index_vector %x\n", hash_table->index_vector);
1646
1647     next_vector = get_array_data(hash_table->next_vector,
1648                                  SIMPLE_ARRAY_WORD_WIDETAG,
1649                                  &next_vector_length);
1650     if (next_vector == NULL)
1651         lose("invalid next_vector %x\n", hash_table->next_vector);
1652
1653     hash_vector = get_array_data(hash_table->hash_vector,
1654                                  SIMPLE_ARRAY_WORD_WIDETAG,
1655                                  &hash_vector_length);
1656     if (hash_vector != NULL)
1657         gc_assert(hash_vector_length == next_vector_length);
1658
1659      /* These lengths could be different as the index_vector can be a
1660       * different length from the others, a larger index_vector could
1661       * help reduce collisions. */
1662      gc_assert(next_vector_length*2 == kv_length);
1663
1664     empty_symbol = kv_vector[1];
1665     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1666     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1667         SYMBOL_HEADER_WIDETAG) {
1668         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1669              *(lispobj *)native_pointer(empty_symbol));
1670     }
1671
1672     /* Work through the KV vector. */
1673     for (i = 1; i < next_vector_length; i++) {
1674         lispobj old_key = kv_vector[2*i];
1675         lispobj value = kv_vector[2*i+1];
1676         if ((weakness == NIL) ||
1677             weak_hash_entry_alivep(weakness, old_key, value)) {
1678
1679             /* Scavenge the key and value. */
1680             scavenge(&kv_vector[2*i],2);
1681
1682             /* Rehashing of EQ based keys. */
1683             if ((!hash_vector) ||
1684                 (hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) {
1685 #ifndef LISP_FEATURE_GENCGC
1686                 /* For GENCGC scav_hash_table_entries only rehashes
1687                  * the entries whose keys were moved. Cheneygc always
1688                  * moves the objects so here we let the lisp side know
1689                  * that rehashing is needed for the whole table. */
1690                 *(kv_vector - 2) = (subtype_VectorMustRehash<<N_WIDETAG_BITS) |
1691                     SIMPLE_VECTOR_WIDETAG;
1692 #else
1693                 unsigned long old_index = EQ_HASH(old_key)%length;
1694                 lispobj new_key = kv_vector[2*i];
1695                 unsigned long new_index = EQ_HASH(new_key)%length;
1696                 /* Check whether the key has moved. */
1697                 if ((old_index != new_index) &&
1698                     (new_key != empty_symbol)) {
1699                     gc_assert(kv_vector[2*i+1] != empty_symbol);
1700
1701                     /*FSHOW((stderr,
1702                       "* EQ key %d moved from %x to %x; index %d to %d\n",
1703                       i, old_key, new_key, old_index, new_index));*/
1704
1705                     /* Unlink the key from the old_index chain. */
1706                     if (!index_vector[old_index]) {
1707                         /* It's not here, must be on the
1708                          * needing_rehash chain. */
1709                     } else if (index_vector[old_index] == i) {
1710                         /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
1711                         index_vector[old_index] = next_vector[i];
1712                         /* Link it into the needing rehash chain. */
1713                         next_vector[i] =
1714                             fixnum_value(hash_table->needing_rehash);
1715                         hash_table->needing_rehash = make_fixnum(i);
1716                         /*SHOW("P2");*/
1717                     } else {
1718                         unsigned long prior = index_vector[old_index];
1719                         unsigned long next = next_vector[prior];
1720
1721                         /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
1722
1723                         while (next != 0) {
1724                             /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
1725                             if (next == i) {
1726                                 /* Unlink it. */
1727                                 next_vector[prior] = next_vector[next];
1728                                 /* Link it into the needing rehash
1729                                  * chain. */
1730                                 next_vector[next] =
1731                                     fixnum_value(hash_table->needing_rehash);
1732                                 hash_table->needing_rehash = make_fixnum(next);
1733                                 /*SHOW("/P3");*/
1734                                 break;
1735                             }
1736                             prior = next;
1737                             next = next_vector[next];
1738                         }
1739                     }
1740                 }
1741 #endif
1742             }
1743         }
1744     }
1745 }
1746
1747 long
1748 scav_vector (lispobj *where, lispobj object)
1749 {
1750     unsigned long kv_length;
1751     lispobj *kv_vector;
1752     struct hash_table *hash_table;
1753
1754     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1755      * hash tables in the Lisp HASH-TABLE code to indicate need for
1756      * special GC support. */
1757     if (HeaderValue(object) == subtype_VectorNormal)
1758         return 1;
1759
1760     kv_length = fixnum_value(where[1]);
1761     kv_vector = where + 2;  /* Skip the header and length. */
1762     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1763
1764     /* Scavenge element 0, which may be a hash-table structure. */
1765     scavenge(where+2, 1);
1766     if (!is_lisp_pointer(where[2])) {
1767         lose("no pointer at %x in hash table\n", where[2]);
1768     }
1769     hash_table = (struct hash_table *)native_pointer(where[2]);
1770     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1771     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1772         lose("hash table not instance (%x at %x)\n",
1773              hash_table->header,
1774              hash_table);
1775     }
1776
1777     /* Scavenge element 1, which should be some internal symbol that
1778      * the hash table code reserves for marking empty slots. */
1779     scavenge(where+3, 1);
1780     if (!is_lisp_pointer(where[3])) {
1781         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1782     }
1783
1784     /* Scavenge hash table, which will fix the positions of the other
1785      * needed objects. */
1786     scavenge((lispobj *)hash_table,
1787              sizeof(struct hash_table) / sizeof(lispobj));
1788
1789     /* Cross-check the kv_vector. */
1790     if (where != (lispobj *)native_pointer(hash_table->table)) {
1791         lose("hash_table table!=this table %x\n", hash_table->table);
1792     }
1793
1794     if (hash_table->weakness == NIL) {
1795         scav_hash_table_entries(hash_table);
1796     } else {
1797         /* Delay scavenging of this table by pushing it onto
1798          * weak_hash_tables (if it's not there already) for the weak
1799          * object phase. */
1800         if (hash_table->next_weak_hash_table == NIL) {
1801             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1802             weak_hash_tables = hash_table;
1803         }
1804     }
1805
1806     return (CEILING(kv_length + 2, 2));
1807 }
1808
1809 void
1810 scav_weak_hash_tables (void)
1811 {
1812     struct hash_table *table;
1813
1814     /* Scavenge entries whose triggers are known to survive. */
1815     for (table = weak_hash_tables; table != NULL;
1816          table = (struct hash_table *)table->next_weak_hash_table) {
1817         scav_hash_table_entries(table);
1818     }
1819 }
1820
1821 /* Walk through the chain whose first element is *FIRST and remove
1822  * dead weak entries. */
1823 static inline void
1824 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1825                             lispobj *kv_vector, lispobj *index_vector,
1826                             lispobj *next_vector, lispobj *hash_vector,
1827                             lispobj empty_symbol, lispobj weakness)
1828 {
1829     unsigned index = *prev;
1830     while (index) {
1831         unsigned next = next_vector[index];
1832         lispobj key = kv_vector[2 * index];
1833         lispobj value = kv_vector[2 * index + 1];
1834         gc_assert(key != empty_symbol);
1835         gc_assert(value != empty_symbol);
1836         if (!weak_hash_entry_alivep(weakness, key, value)) {
1837             unsigned count = fixnum_value(hash_table->number_entries);
1838             gc_assert(count > 0);
1839             *prev = next;
1840             hash_table->number_entries = make_fixnum(count - 1);
1841             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1842             hash_table->next_free_kv = make_fixnum(index);
1843             kv_vector[2 * index] = empty_symbol;
1844             kv_vector[2 * index + 1] = empty_symbol;
1845             if (hash_vector)
1846                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1847         } else {
1848             prev = &next_vector[index];
1849         }
1850         index = next;
1851     }
1852 }
1853
1854 static void
1855 scan_weak_hash_table (struct hash_table *hash_table)
1856 {
1857     lispobj *kv_vector;
1858     lispobj *index_vector;
1859     unsigned long length = 0; /* prevent warning */
1860     lispobj *next_vector;
1861     unsigned long next_vector_length = 0; /* prevent warning */
1862     lispobj *hash_vector;
1863     lispobj empty_symbol;
1864     lispobj weakness = hash_table->weakness;
1865     long i;
1866
1867     kv_vector = get_array_data(hash_table->table,
1868                                SIMPLE_VECTOR_WIDETAG, NULL);
1869     index_vector = get_array_data(hash_table->index_vector,
1870                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1871     next_vector = get_array_data(hash_table->next_vector,
1872                                  SIMPLE_ARRAY_WORD_WIDETAG,
1873                                  &next_vector_length);
1874     hash_vector = get_array_data(hash_table->hash_vector,
1875                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1876     empty_symbol = kv_vector[1];
1877
1878     for (i = 0; i < length; i++) {
1879         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1880                                    kv_vector, index_vector, next_vector,
1881                                    hash_vector, empty_symbol, weakness);
1882     }
1883     {
1884         lispobj first = fixnum_value(hash_table->needing_rehash);
1885         scan_weak_hash_table_chain(hash_table, &first,
1886                                    kv_vector, index_vector, next_vector,
1887                                    hash_vector, empty_symbol, weakness);
1888         hash_table->needing_rehash = make_fixnum(first);
1889     }
1890 }
1891
1892 /* Remove dead entries from weak hash tables. */
1893 void
1894 scan_weak_hash_tables (void)
1895 {
1896     struct hash_table *table, *next;
1897
1898     for (table = weak_hash_tables; table != NULL; table = next) {
1899         next = (struct hash_table *)table->next_weak_hash_table;
1900         table->next_weak_hash_table = NIL;
1901         scan_weak_hash_table(table);
1902     }
1903
1904     weak_hash_tables = NULL;
1905 }
1906
1907 \f
1908 /*
1909  * initialization
1910  */
1911
1912 static long
1913 scav_lose(lispobj *where, lispobj object)
1914 {
1915     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1916          (unsigned long)object,
1917          widetag_of(*(lispobj*)native_pointer(object)));
1918
1919     return 0; /* bogus return value to satisfy static type checking */
1920 }
1921
1922 static lispobj
1923 trans_lose(lispobj object)
1924 {
1925     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1926          (unsigned long)object,
1927          widetag_of(*(lispobj*)native_pointer(object)));
1928     return NIL; /* bogus return value to satisfy static type checking */
1929 }
1930
1931 static long
1932 size_lose(lispobj *where)
1933 {
1934     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1935          (unsigned long)where,
1936          widetag_of(LOW_WORD(where)));
1937     return 1; /* bogus return value to satisfy static type checking */
1938 }
1939
1940 \f
1941 /*
1942  * initialization
1943  */
1944
1945 void
1946 gc_init_tables(void)
1947 {
1948     long i;
1949
1950     /* Set default value in all slots of scavenge table.  FIXME
1951      * replace this gnarly sizeof with something based on
1952      * N_WIDETAG_BITS */
1953     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1954         scavtab[i] = scav_lose;
1955     }
1956
1957     /* For each type which can be selected by the lowtag alone, set
1958      * multiple entries in our widetag scavenge table (one for each
1959      * possible value of the high bits).
1960      */
1961
1962     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1963         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1964         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1965         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1966         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1967         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1968         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1969         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1970         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1971     }
1972
1973     /* Other-pointer types (those selected by all eight bits of the
1974      * tag) get one entry each in the scavenge table. */
1975     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1976     scavtab[RATIO_WIDETAG] = scav_boxed;
1977 #if N_WORD_BITS == 64
1978     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1979 #else
1980     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1981 #endif
1982     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1983 #ifdef LONG_FLOAT_WIDETAG
1984     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1985 #endif
1986     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1987 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1988     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1989 #endif
1990 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1991     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1992 #endif
1993 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1994     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1995 #endif
1996     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1997     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1998 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1999     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
2000 #endif
2001     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
2002     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
2003     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2004         scav_vector_unsigned_byte_2;
2005     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2006         scav_vector_unsigned_byte_4;
2007     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2008         scav_vector_unsigned_byte_8;
2009     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2010         scav_vector_unsigned_byte_8;
2011     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2012         scav_vector_unsigned_byte_16;
2013     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2014         scav_vector_unsigned_byte_16;
2015 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2016     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2017         scav_vector_unsigned_byte_32;
2018 #endif
2019     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2020         scav_vector_unsigned_byte_32;
2021     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2022         scav_vector_unsigned_byte_32;
2023 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2024     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2025         scav_vector_unsigned_byte_64;
2026 #endif
2027 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2028     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2029         scav_vector_unsigned_byte_64;
2030 #endif
2031 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2032     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2033         scav_vector_unsigned_byte_64;
2034 #endif
2035 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2036     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
2037 #endif
2038 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2039     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2040         scav_vector_unsigned_byte_16;
2041 #endif
2042 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2043     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2044         scav_vector_unsigned_byte_32;
2045 #endif
2046 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2047     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2048         scav_vector_unsigned_byte_32;
2049 #endif
2050 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2051     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2052         scav_vector_unsigned_byte_64;
2053 #endif
2054 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2055     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2056         scav_vector_unsigned_byte_64;
2057 #endif
2058     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2059     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2060 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2061     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2062 #endif
2063 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2064     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2065         scav_vector_complex_single_float;
2066 #endif
2067 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2068     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2069         scav_vector_complex_double_float;
2070 #endif
2071 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2072     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2073         scav_vector_complex_long_float;
2074 #endif
2075     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2076 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2077     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2078 #endif
2079     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2080     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2081     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2082     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2083     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2084 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2085     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2086     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2087 #endif
2088     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2089 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2090     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2091 #else
2092     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2093 #endif
2094     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2095     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2096     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2097     scavtab[SAP_WIDETAG] = scav_unboxed;
2098     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2099     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2100     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2101 #if defined(LISP_FEATURE_SPARC)
2102     scavtab[FDEFN_WIDETAG] = scav_boxed;
2103 #else
2104     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2105 #endif
2106     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2107
2108     /* transport other table, initialized same way as scavtab */
2109     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2110         transother[i] = trans_lose;
2111     transother[BIGNUM_WIDETAG] = trans_unboxed;
2112     transother[RATIO_WIDETAG] = trans_boxed;
2113
2114 #if N_WORD_BITS == 64
2115     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2116 #else
2117     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2118 #endif
2119     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2120 #ifdef LONG_FLOAT_WIDETAG
2121     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2122 #endif
2123     transother[COMPLEX_WIDETAG] = trans_boxed;
2124 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2125     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2126 #endif
2127 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2128     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2129 #endif
2130 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2131     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2132 #endif
2133     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2134     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2135 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2136     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2137 #endif
2138     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2139     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2140     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2141     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2142         trans_vector_unsigned_byte_2;
2143     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2144         trans_vector_unsigned_byte_4;
2145     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2146         trans_vector_unsigned_byte_8;
2147     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2148         trans_vector_unsigned_byte_8;
2149     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2150         trans_vector_unsigned_byte_16;
2151     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2152         trans_vector_unsigned_byte_16;
2153 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2154     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2155         trans_vector_unsigned_byte_32;
2156 #endif
2157     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2158         trans_vector_unsigned_byte_32;
2159     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2160         trans_vector_unsigned_byte_32;
2161 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2162     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2163         trans_vector_unsigned_byte_64;
2164 #endif
2165 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2166     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2167         trans_vector_unsigned_byte_64;
2168 #endif
2169 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2170     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2171         trans_vector_unsigned_byte_64;
2172 #endif
2173 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2174     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2175         trans_vector_unsigned_byte_8;
2176 #endif
2177 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2178     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2179         trans_vector_unsigned_byte_16;
2180 #endif
2181 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2182     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2183         trans_vector_unsigned_byte_32;
2184 #endif
2185 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2186     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2187         trans_vector_unsigned_byte_32;
2188 #endif
2189 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2190     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2191         trans_vector_unsigned_byte_64;
2192 #endif
2193 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2194     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2195         trans_vector_unsigned_byte_64;
2196 #endif
2197     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2198         trans_vector_single_float;
2199     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2200         trans_vector_double_float;
2201 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2202     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2203         trans_vector_long_float;
2204 #endif
2205 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2206     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2207         trans_vector_complex_single_float;
2208 #endif
2209 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2210     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2211         trans_vector_complex_double_float;
2212 #endif
2213 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2214     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2215         trans_vector_complex_long_float;
2216 #endif
2217     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2218 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2219     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2220 #endif
2221     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2222     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2223     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2224     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2225     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2226     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2227     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2228     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2229     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2230     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2231     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2232     transother[CHARACTER_WIDETAG] = trans_immediate;
2233     transother[SAP_WIDETAG] = trans_unboxed;
2234     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2235     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2236     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2237     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2238     transother[FDEFN_WIDETAG] = trans_boxed;
2239
2240     /* size table, initialized the same way as scavtab */
2241     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2242         sizetab[i] = size_lose;
2243     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2244         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2245         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2246         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2247         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2248         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2249         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2250         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2251         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2252     }
2253     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2254     sizetab[RATIO_WIDETAG] = size_boxed;
2255 #if N_WORD_BITS == 64
2256     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2257 #else
2258     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2259 #endif
2260     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2261 #ifdef LONG_FLOAT_WIDETAG
2262     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2263 #endif
2264     sizetab[COMPLEX_WIDETAG] = size_boxed;
2265 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2266     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2267 #endif
2268 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2269     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2270 #endif
2271 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2272     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2273 #endif
2274     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2275     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2276 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2277     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2278 #endif
2279     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2280     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2281     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2282     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2283         size_vector_unsigned_byte_2;
2284     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2285         size_vector_unsigned_byte_4;
2286     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2287         size_vector_unsigned_byte_8;
2288     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2289         size_vector_unsigned_byte_8;
2290     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2291         size_vector_unsigned_byte_16;
2292     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2293         size_vector_unsigned_byte_16;
2294 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2295     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2296         size_vector_unsigned_byte_32;
2297 #endif
2298     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2299         size_vector_unsigned_byte_32;
2300     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2301         size_vector_unsigned_byte_32;
2302 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2303     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2304         size_vector_unsigned_byte_64;
2305 #endif
2306 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2307     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2308         size_vector_unsigned_byte_64;
2309 #endif
2310 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2311     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2312         size_vector_unsigned_byte_64;
2313 #endif
2314 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2315     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2316 #endif
2317 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2318     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2319         size_vector_unsigned_byte_16;
2320 #endif
2321 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2322     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2323         size_vector_unsigned_byte_32;
2324 #endif
2325 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2326     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2327         size_vector_unsigned_byte_32;
2328 #endif
2329 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2330     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2331         size_vector_unsigned_byte_64;
2332 #endif
2333 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2334     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2335         size_vector_unsigned_byte_64;
2336 #endif
2337     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2338     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2339 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2340     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2341 #endif
2342 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2343     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2344         size_vector_complex_single_float;
2345 #endif
2346 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2347     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2348         size_vector_complex_double_float;
2349 #endif
2350 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2351     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2352         size_vector_complex_long_float;
2353 #endif
2354     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2355 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2356     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2357 #endif
2358     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2359     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2360     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2361     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2362     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2363 #if 0
2364     /* We shouldn't see these, so just lose if it happens. */
2365     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2366     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2367 #endif
2368     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2369     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2370     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2371     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2372     sizetab[CHARACTER_WIDETAG] = size_immediate;
2373     sizetab[SAP_WIDETAG] = size_unboxed;
2374     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2375     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2376     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2377     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2378     sizetab[FDEFN_WIDETAG] = size_boxed;
2379 }
2380
2381 \f
2382 /* Find the code object for the given pc, or return NULL on
2383    failure. */
2384 lispobj *
2385 component_ptr_from_pc(lispobj *pc)
2386 {
2387     lispobj *object = NULL;
2388
2389     if ( (object = search_read_only_space(pc)) )
2390         ;
2391     else if ( (object = search_static_space(pc)) )
2392         ;
2393     else
2394         object = search_dynamic_space(pc);
2395
2396     if (object) /* if we found something */
2397         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2398             return(object);
2399
2400     return (NULL);
2401 }
2402
2403 /* Scan an area looking for an object which encloses the given pointer.
2404  * Return the object start on success or NULL on failure. */
2405 lispobj *
2406 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2407 {
2408     while (words > 0) {
2409         size_t count = 1;
2410         lispobj thing = *start;
2411
2412         /* If thing is an immediate then this is a cons. */
2413         if (is_lisp_pointer(thing)
2414             || (fixnump(thing))
2415             || (widetag_of(thing) == CHARACTER_WIDETAG)
2416 #if N_WORD_BITS == 64
2417             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2418 #endif
2419             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2420             count = 2;
2421         else
2422             count = (sizetab[widetag_of(thing)])(start);
2423
2424         /* Check whether the pointer is within this object. */
2425         if ((pointer >= start) && (pointer < (start+count))) {
2426             /* found it! */
2427             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2428             return(start);
2429         }
2430
2431         /* Round up the count. */
2432         count = CEILING(count,2);
2433
2434         start += count;
2435         words -= count;
2436     }
2437     return (NULL);
2438 }
2439
2440 boolean
2441 maybe_gc(os_context_t *context)
2442 {
2443 #ifndef LISP_FEATURE_WIN32
2444     struct thread *thread = arch_os_get_current_thread();
2445 #endif
2446
2447     fake_foreign_function_call(context);
2448     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2449      * which case we will be running with no gc trigger barrier
2450      * thing for a while.  But it shouldn't be long until the end
2451      * of WITHOUT-GCING.
2452      *
2453      * FIXME: It would be good to protect the end of dynamic space for
2454      * CheneyGC and signal a storage condition from there.
2455      */
2456
2457     /* Restore the signal mask from the interrupted context before
2458      * calling into Lisp if interrupts are enabled. Why not always?
2459      *
2460      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2461      * interrupt hits while in SUB-GC, it is deferred and the
2462      * os_context_sigmask of that interrupt is set to block further
2463      * deferrable interrupts (until the first one is
2464      * handled). Unfortunately, that context refers to this place and
2465      * when we return from here the signals will not be blocked.
2466      *
2467      * A kludgy alternative is to propagate the sigmask change to the
2468      * outer context.
2469      */
2470 #ifndef LISP_FEATURE_WIN32
2471     if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) {
2472         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2473 #ifdef LISP_FEATURE_SB_THREAD
2474         /* What if the context we'd like to restore has GC signals
2475          * blocked? Just skip the GC: we can't set GC_PENDING, because
2476          * that would block the next attempt, and we don't know when
2477          * we'd next check for it -- and it's hard to be sure that
2478          * unblocking would be safe.
2479          *
2480          * FIXME: This is not actually much better: we may already have
2481          * GC_PENDING set, and presumably our caller assumes that we will
2482          * clear it. Perhaps we should, even though we don't actually GC? */
2483         if (sigismember(context_sigmask,SIG_STOP_FOR_GC)) {
2484             undo_fake_foreign_function_call(context);
2485             return 1;
2486         }
2487 #endif
2488         thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2489     }
2490     else
2491         unblock_gc_signals();
2492 #endif
2493     /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
2494      * otherwise two threads racing here may deadlock: the other will
2495      * wait on the GC lock, and the other cannot stop the first one... */
2496     funcall0(SymbolFunction(SUB_GC));
2497     undo_fake_foreign_function_call(context);
2498     return 1;
2499 }