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