src/runtime/gc-common.c

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