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 "gc.h"
  41 #include "genesis/primitive-objects.h"
  42 #include "genesis/static-symbols.h"
  43 #include "genesis/layout.h"
  44 #include "genesis/hash-table.h"
  45 #include "gc-internal.h"
  46
  47 #ifdef LISP_FEATURE_SPARC
  48 #define LONG_FLOAT_SIZE 4
  49 #else
  50 #ifdef LISP_FEATURE_X86
  51 #define LONG_FLOAT_SIZE 3
  52 #endif
  53 #endif
  54
  55 size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE;
  56 size_t thread_control_stack_size = DEFAULT_CONTROL_STACK_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 os_vm_size_t bytes_consed_between_gcs = 12*1024*1024;
  94
  95 /*
  96  * copying objects
  97  */
  98 static
  99 lispobj
 100 gc_general_copy_object(lispobj object, long nwords, int page_type_flag)
 101 {
 102     int tag;
 103     lispobj *new;
 104
 105     gc_assert(is_lisp_pointer(object));
 106     gc_assert(from_space_p(object));
 107     gc_assert((nwords & 0x01) == 0);
 108
 109     /* Get tag of object. */
 110     tag = lowtag_of(object);
 111
 112     /* Allocate space. */
 113     new = gc_general_alloc(nwords*N_WORD_BYTES, page_type_flag, ALLOC_QUICK);
 114
 115     /* Copy the object. */
 116     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
 117     return make_lispobj(new,tag);
 118 }
 119
 120 /* to copy a boxed object */
 121 lispobj
 122 copy_object(lispobj object, long nwords)
 123 {
 124     return gc_general_copy_object(object, nwords, BOXED_PAGE_FLAG);
 125 }
 126
 127 lispobj
 128 copy_code_object(lispobj object, long nwords)
 129 {
 130     return gc_general_copy_object(object, nwords, CODE_PAGE_FLAG);
 131 }
 132
 133 static long scav_lose(lispobj *where, lispobj object); /* forward decl */
 134
 135 /* FIXME: Most calls end up going to some trouble to compute an
 136  * 'n_words' value for this function. The system might be a little
 137  * simpler if this function used an 'end' parameter instead. */
 138 void
 139 scavenge(lispobj *start, long n_words)
 140 {
 141     lispobj *end = start + n_words;
 142     lispobj *object_ptr;
 143     long n_words_scavenged;
 144
 145     for (object_ptr = start;
 146          object_ptr < end;
 147          object_ptr += n_words_scavenged) {
 148
 149         lispobj object = *object_ptr;
 150 #ifdef LISP_FEATURE_GENCGC
 151         if (forwarding_pointer_p(object_ptr))
 152             lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
 153                  object_ptr, start, n_words);
 154 #endif
 155         if (is_lisp_pointer(object)) {
 156             if (from_space_p(object)) {
 157                 /* It currently points to old space. Check for a
 158                  * forwarding pointer. */
 159                 lispobj *ptr = native_pointer(object);
 160                 if (forwarding_pointer_p(ptr)) {
 161                     /* Yes, there's a forwarding pointer. */
 162                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 163                     n_words_scavenged = 1;
 164                 } else {
 165                     /* Scavenge that pointer. */
 166                     n_words_scavenged =
 167                         (scavtab[widetag_of(object)])(object_ptr, object);
 168                 }
 169             } else {
 170                 /* It points somewhere other than oldspace. Leave it
 171                  * alone. */
 172                 n_words_scavenged = 1;
 173             }
 174         }
 175 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
 176         /* This workaround is probably not needed for those ports
 177            which don't have a partitioned register set (and therefore
 178            scan the stack conservatively for roots). */
 179         else if (n_words == 1) {
 180             /* there are some situations where an other-immediate may
 181                end up in a descriptor register.  I'm not sure whether
 182                this is supposed to happen, but if it does then we
 183                don't want to (a) barf or (b) scavenge over the
 184                data-block, because there isn't one.  So, if we're
 185                checking a single word and it's anything other than a
 186                pointer, just hush it up */
 187             int widetag = widetag_of(object);
 188             n_words_scavenged = 1;
 189
 190             if ((scavtab[widetag] == scav_lose) ||
 191                 (((sizetab[widetag])(object_ptr)) > 1)) {
 192                 fprintf(stderr,"warning: \
 193 attempted to scavenge non-descriptor value %x at %p.\n\n\
 194 If you can reproduce this warning, please send a bug report\n\
 195 (see manual page for details).\n",
 196                         object, object_ptr);
 197             }
 198         }
 199 #endif
 200         else if (fixnump(object)) {
 201             /* It's a fixnum: really easy.. */
 202             n_words_scavenged = 1;
 203         } else {
 204             /* It's some sort of header object or another. */
 205             n_words_scavenged =
 206                 (scavtab[widetag_of(object)])(object_ptr, object);
 207         }
 208     }
 209     gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n",
 210                       object_ptr, start, end);
 211 }
 212
 213 static lispobj trans_fun_header(lispobj object); /* forward decls */
 214 static lispobj trans_boxed(lispobj object);
 215
 216 static long
 217 scav_fun_pointer(lispobj *where, lispobj object)
 218 {
 219     lispobj *first_pointer;
 220     lispobj copy;
 221
 222     gc_assert(is_lisp_pointer(object));
 223
 224     /* Object is a pointer into from_space - not a FP. */
 225     first_pointer = (lispobj *) native_pointer(object);
 226
 227     /* must transport object -- object may point to either a function
 228      * header, a closure function header, or to a closure header. */
 229
 230     switch (widetag_of(*first_pointer)) {
 231     case SIMPLE_FUN_HEADER_WIDETAG:
 232         copy = trans_fun_header(object);
 233         break;
 234     default:
 235         copy = trans_boxed(object);
 236         break;
 237     }
 238
 239     if (copy != object) {
 240         /* Set forwarding pointer */
 241         set_forwarding_pointer(first_pointer,copy);
 242     }
 243
 244     gc_assert(is_lisp_pointer(copy));
 245     gc_assert(!from_space_p(copy));
 246
 247     *where = copy;
 248
 249     return 1;
 250 }
 251
 252
 253 static struct code *
 254 trans_code(struct code *code)
 255 {
 256     struct code *new_code;
 257     lispobj first, l_code, l_new_code;
 258     long nheader_words, ncode_words, nwords;
 259     unsigned long displacement;
 260     lispobj fheaderl, *prev_pointer;
 261
 262     /* if object has already been transported, just return pointer */
 263     first = code->header;
 264     if (forwarding_pointer_p((lispobj *)code)) {
 265 #ifdef DEBUG_CODE_GC
 266         printf("Was already transported\n");
 267 #endif
 268         return (struct code *) forwarding_pointer_value
 269             ((lispobj *)((pointer_sized_uint_t) code));
 270     }
 271
 272     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 273
 274     /* prepare to transport the code vector */
 275     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 276
 277     ncode_words = fixnum_value(code->code_size);
 278     nheader_words = HeaderValue(code->header);
 279     nwords = ncode_words + nheader_words;
 280     nwords = CEILING(nwords, 2);
 281
 282     l_new_code = copy_code_object(l_code, nwords);
 283     new_code = (struct code *) native_pointer(l_new_code);
 284
 285 #if defined(DEBUG_CODE_GC)
 286     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 287            (unsigned long) code, (unsigned long) new_code);
 288     printf("Code object is %d words long.\n", nwords);
 289 #endif
 290
 291 #ifdef LISP_FEATURE_GENCGC
 292     if (new_code == code)
 293         return new_code;
 294 #endif
 295
 296     displacement = l_new_code - l_code;
 297
 298     set_forwarding_pointer((lispobj *)code, l_new_code);
 299
 300     /* set forwarding pointers for all the function headers in the */
 301     /* code object.  also fix all self pointers */
 302
 303     fheaderl = code->entry_points;
 304     prev_pointer = &new_code->entry_points;
 305
 306     while (fheaderl != NIL) {
 307         struct simple_fun *fheaderp, *nfheaderp;
 308         lispobj nfheaderl;
 309
 310         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 311         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 312
 313         /* Calculate the new function pointer and the new */
 314         /* function header. */
 315         nfheaderl = fheaderl + displacement;
 316         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 317
 318 #ifdef DEBUG_CODE_GC
 319         printf("fheaderp->header (at %x) <- %x\n",
 320                &(fheaderp->header) , nfheaderl);
 321 #endif
 322         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 323
 324         /* fix self pointer. */
 325         nfheaderp->self =
 326 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 327             FUN_RAW_ADDR_OFFSET +
 328 #endif
 329             nfheaderl;
 330
 331         *prev_pointer = nfheaderl;
 332
 333         fheaderl = fheaderp->next;
 334         prev_pointer = &nfheaderp->next;
 335     }
 336 #ifdef LISP_FEATURE_GENCGC
 337     /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
 338        spaces once when all copying is done. */
 339     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
 340                     ncode_words * sizeof(long));
 341
 342 #endif
 343
 344 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 345     gencgc_apply_code_fixups(code, new_code);
 346 #endif
 347
 348     return new_code;
 349 }
 350
 351 static long
 352 scav_code_header(lispobj *where, lispobj object)
 353 {
 354     struct code *code;
 355     long n_header_words, n_code_words, n_words;
 356     lispobj entry_point;        /* tagged pointer to entry point */
 357     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 358
 359     code = (struct code *) where;
 360     n_code_words = fixnum_value(code->code_size);
 361     n_header_words = HeaderValue(object);
 362     n_words = n_code_words + n_header_words;
 363     n_words = CEILING(n_words, 2);
 364
 365     /* Scavenge the boxed section of the code data block. */
 366     scavenge(where + 1, n_header_words - 1);
 367
 368     /* Scavenge the boxed section of each function object in the
 369      * code data block. */
 370     for (entry_point = code->entry_points;
 371          entry_point != NIL;
 372          entry_point = function_ptr->next) {
 373
 374         gc_assert_verbose(is_lisp_pointer(entry_point),
 375                           "Entry point %lx\n is not a lisp pointer.",
 376                           (long)entry_point);
 377
 378         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 379         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 380
 381         scavenge(&function_ptr->name, 1);
 382         scavenge(&function_ptr->arglist, 1);
 383         scavenge(&function_ptr->type, 1);
 384         scavenge(&function_ptr->info, 1);
 385     }
 386
 387     return n_words;
 388 }
 389
 390 static lispobj
 391 trans_code_header(lispobj object)
 392 {
 393     struct code *ncode;
 394
 395     ncode = trans_code((struct code *) native_pointer(object));
 396     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 397 }
 398
 399
 400 static long
 401 size_code_header(lispobj *where)
 402 {
 403     struct code *code;
 404     long nheader_words, ncode_words, nwords;
 405
 406     code = (struct code *) where;
 407
 408     ncode_words = fixnum_value(code->code_size);
 409     nheader_words = HeaderValue(code->header);
 410     nwords = ncode_words + nheader_words;
 411     nwords = CEILING(nwords, 2);
 412
 413     return nwords;
 414 }
 415
 416 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 417 static long
 418 scav_return_pc_header(lispobj *where, lispobj object)
 419 {
 420     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
 421          (unsigned long) where,
 422          (unsigned long) object);
 423     return 0; /* bogus return value to satisfy static type checking */
 424 }
 425 #endif /* LISP_FEATURE_X86 */
 426
 427 static lispobj
 428 trans_return_pc_header(lispobj object)
 429 {
 430     struct simple_fun *return_pc;
 431     unsigned long offset;
 432     struct code *code, *ncode;
 433
 434     return_pc = (struct simple_fun *) native_pointer(object);
 435     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 436     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 437
 438     /* Transport the whole code object */
 439     code = (struct code *) ((unsigned long) return_pc - offset);
 440     ncode = trans_code(code);
 441
 442     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 443 }
 444
 445 /* On the 386, closures hold a pointer to the raw address instead of the
 446  * function object, so we can use CALL [$FDEFN+const] to invoke
 447  * the function without loading it into a register. Given that code
 448  * objects don't move, we don't need to update anything, but we do
 449  * have to figure out that the function is still live. */
 450
 451 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 452 static long
 453 scav_closure_header(lispobj *where, lispobj object)
 454 {
 455     struct closure *closure;
 456     lispobj fun;
 457
 458     closure = (struct closure *)where;
 459     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 460     scavenge(&fun, 1);
 461 #ifdef LISP_FEATURE_GENCGC
 462     /* The function may have moved so update the raw address. But
 463      * don't write unnecessarily. */
 464     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 465         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 466 #endif
 467     return 2;
 468 }
 469 #endif
 470
 471 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 472 static long
 473 scav_fun_header(lispobj *where, lispobj object)
 474 {
 475     lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
 476          (unsigned long) where,
 477          (unsigned long) object);
 478     return 0; /* bogus return value to satisfy static type checking */
 479 }
 480 #endif /* LISP_FEATURE_X86 */
 481
 482 static lispobj
 483 trans_fun_header(lispobj object)
 484 {
 485     struct simple_fun *fheader;
 486     unsigned long offset;
 487     struct code *code, *ncode;
 488
 489     fheader = (struct simple_fun *) native_pointer(object);
 490     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 491     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 492
 493     /* Transport the whole code object */
 494     code = (struct code *) ((unsigned long) fheader - offset);
 495     ncode = trans_code(code);
 496
 497     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 498 }
 499
 500 \f
 501 /*
 502  * instances
 503  */
 504
 505 static long
 506 scav_instance_pointer(lispobj *where, lispobj object)
 507 {
 508     lispobj copy, *first_pointer;
 509
 510     /* Object is a pointer into from space - not a FP. */
 511     copy = trans_boxed(object);
 512
 513 #ifdef LISP_FEATURE_GENCGC
 514     gc_assert(copy != object);
 515 #endif
 516
 517     first_pointer = (lispobj *) native_pointer(object);
 518     set_forwarding_pointer(first_pointer,copy);
 519     *where = copy;
 520
 521     return 1;
 522 }
 523
 524 \f
 525 /*
 526  * lists and conses
 527  */
 528
 529 static lispobj trans_list(lispobj object);
 530
 531 static long
 532 scav_list_pointer(lispobj *where, lispobj object)
 533 {
 534     lispobj first, *first_pointer;
 535
 536     gc_assert(is_lisp_pointer(object));
 537
 538     /* Object is a pointer into from space - not FP. */
 539     first_pointer = (lispobj *) native_pointer(object);
 540
 541     first = trans_list(object);
 542     gc_assert(first != object);
 543
 544     /* Set forwarding pointer */
 545     set_forwarding_pointer(first_pointer, first);
 546
 547     gc_assert(is_lisp_pointer(first));
 548     gc_assert(!from_space_p(first));
 549
 550     *where = first;
 551     return 1;
 552 }
 553
 554
 555 static lispobj
 556 trans_list(lispobj object)
 557 {
 558     lispobj new_list_pointer;
 559     struct cons *cons, *new_cons;
 560     lispobj cdr;
 561
 562     cons = (struct cons *) native_pointer(object);
 563
 564     /* Copy 'object'. */
 565     new_cons = (struct cons *)
 566         gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
 567     new_cons->car = cons->car;
 568     new_cons->cdr = cons->cdr; /* updated later */
 569     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 570
 571     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 572     cdr = cons->cdr;
 573
 574     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 575
 576     /* Try to linearize the list in the cdr direction to help reduce
 577      * paging. */
 578     while (1) {
 579         lispobj  new_cdr;
 580         struct cons *cdr_cons, *new_cdr_cons;
 581
 582         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 583            !from_space_p(cdr) ||
 584            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 585             break;
 586
 587         cdr_cons = (struct cons *) native_pointer(cdr);
 588
 589         /* Copy 'cdr'. */
 590         new_cdr_cons = (struct cons*)
 591             gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
 592         new_cdr_cons->car = cdr_cons->car;
 593         new_cdr_cons->cdr = cdr_cons->cdr;
 594         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 595
 596         /* Grab the cdr before it is clobbered. */
 597         cdr = cdr_cons->cdr;
 598         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 599
 600         /* Update the cdr of the last cons copied into new space to
 601          * keep the newspace scavenge from having to do it. */
 602         new_cons->cdr = new_cdr;
 603
 604         new_cons = new_cdr_cons;
 605     }
 606
 607     return new_list_pointer;
 608 }
 609
 610 \f
 611 /*
 612  * scavenging and transporting other pointers
 613  */
 614
 615 static long
 616 scav_other_pointer(lispobj *where, lispobj object)
 617 {
 618     lispobj first, *first_pointer;
 619
 620     gc_assert(is_lisp_pointer(object));
 621
 622     /* Object is a pointer into from space - not FP. */
 623     first_pointer = (lispobj *) native_pointer(object);
 624     first = (transother[widetag_of(*first_pointer)])(object);
 625
 626     if (first != object) {
 627         set_forwarding_pointer(first_pointer, first);
 628 #ifdef LISP_FEATURE_GENCGC
 629         *where = first;
 630 #endif
 631     }
 632 #ifndef LISP_FEATURE_GENCGC
 633     *where = first;
 634 #endif
 635     gc_assert(is_lisp_pointer(first));
 636     gc_assert(!from_space_p(first));
 637
 638     return 1;
 639 }
 640 \f
 641 /*
 642  * immediate, boxed, and unboxed objects
 643  */
 644
 645 static long
 646 size_pointer(lispobj *where)
 647 {
 648     return 1;
 649 }
 650
 651 static long
 652 scav_immediate(lispobj *where, lispobj object)
 653 {
 654     return 1;
 655 }
 656
 657 static lispobj
 658 trans_immediate(lispobj object)
 659 {
 660     lose("trying to transport an immediate\n");
 661     return NIL; /* bogus return value to satisfy static type checking */
 662 }
 663
 664 static long
 665 size_immediate(lispobj *where)
 666 {
 667     return 1;
 668 }
 669
 670
 671 static long
 672 scav_boxed(lispobj *where, lispobj object)
 673 {
 674     return 1;
 675 }
 676
 677 static long
 678 scav_instance(lispobj *where, lispobj object)
 679 {
 680     lispobj nuntagged;
 681     long ntotal = HeaderValue(object);
 682     lispobj layout = ((struct instance *)where)->slots[0];
 683
 684     if (!layout)
 685         return 1;
 686     if (forwarding_pointer_p(native_pointer(layout)))
 687         layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
 688
 689     nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
 690     scavenge(where + 1, ntotal - fixnum_value(nuntagged));
 691
 692     return ntotal + 1;
 693 }
 694
 695 static lispobj
 696 trans_boxed(lispobj object)
 697 {
 698     lispobj header;
 699     unsigned long length;
 700
 701     gc_assert(is_lisp_pointer(object));
 702
 703     header = *((lispobj *) native_pointer(object));
 704     length = HeaderValue(header) + 1;
 705     length = CEILING(length, 2);
 706
 707     return copy_object(object, length);
 708 }
 709
 710
 711 static long
 712 size_boxed(lispobj *where)
 713 {
 714     lispobj header;
 715     unsigned long length;
 716
 717     header = *where;
 718     length = HeaderValue(header) + 1;
 719     length = CEILING(length, 2);
 720
 721     return length;
 722 }
 723
 724 /* Note: on the sparc we don't have to do anything special for fdefns, */
 725 /* 'cause the raw-addr has a function lowtag. */
 726 #if !defined(LISP_FEATURE_SPARC)
 727 static long
 728 scav_fdefn(lispobj *where, lispobj object)
 729 {
 730     struct fdefn *fdefn;
 731
 732     fdefn = (struct fdefn *)where;
 733
 734     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 735        fdefn->fun, fdefn->raw_addr)); */
 736
 737     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
 738         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 739
 740         /* Don't write unnecessarily. */
 741         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 742             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 743         /* gc.c has more casts here, which may be relevant or alternatively
 744            may be compiler warning defeaters.  try
 745         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 746         */
 747         return sizeof(struct fdefn) / sizeof(lispobj);
 748     } else {
 749         return 1;
 750     }
 751 }
 752 #endif
 753
 754 static long
 755 scav_unboxed(lispobj *where, lispobj object)
 756 {
 757     unsigned long length;
 758
 759     length = HeaderValue(object) + 1;
 760     length = CEILING(length, 2);
 761
 762     return length;
 763 }
 764
 765 static lispobj
 766 trans_unboxed(lispobj object)
 767 {
 768     lispobj header;
 769     unsigned long length;
 770
 771
 772     gc_assert(is_lisp_pointer(object));
 773
 774     header = *((lispobj *) native_pointer(object));
 775     length = HeaderValue(header) + 1;
 776     length = CEILING(length, 2);
 777
 778     return copy_unboxed_object(object, length);
 779 }
 780
 781 static long
 782 size_unboxed(lispobj *where)
 783 {
 784     lispobj header;
 785     unsigned long length;
 786
 787     header = *where;
 788     length = HeaderValue(header) + 1;
 789     length = CEILING(length, 2);
 790
 791     return length;
 792 }
 793
 794 \f
 795 /* vector-like objects */
 796 static long
 797 scav_base_string(lispobj *where, lispobj object)
 798 {
 799     struct vector *vector;
 800     long length, nwords;
 801
 802     /* NOTE: Strings contain one more byte of data than the length */
 803     /* slot indicates. */
 804
 805     vector = (struct vector *) where;
 806     length = fixnum_value(vector->length) + 1;
 807     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 808
 809     return nwords;
 810 }
 811 static lispobj
 812 trans_base_string(lispobj object)
 813 {
 814     struct vector *vector;
 815     long length, nwords;
 816
 817     gc_assert(is_lisp_pointer(object));
 818
 819     /* NOTE: A string contains one more byte of data (a terminating
 820      * '\0' to help when interfacing with C functions) than indicated
 821      * by the length slot. */
 822
 823     vector = (struct vector *) native_pointer(object);
 824     length = fixnum_value(vector->length) + 1;
 825     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 826
 827     return copy_large_unboxed_object(object, nwords);
 828 }
 829
 830 static long
 831 size_base_string(lispobj *where)
 832 {
 833     struct vector *vector;
 834     long length, nwords;
 835
 836     /* NOTE: A string contains one more byte of data (a terminating
 837      * '\0' to help when interfacing with C functions) than indicated
 838      * by the length slot. */
 839
 840     vector = (struct vector *) where;
 841     length = fixnum_value(vector->length) + 1;
 842     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 843
 844     return nwords;
 845 }
 846
 847 static long
 848 scav_character_string(lispobj *where, lispobj object)
 849 {
 850     struct vector *vector;
 851     int length, nwords;
 852
 853     /* NOTE: Strings contain one more byte of data than the length */
 854     /* slot indicates. */
 855
 856     vector = (struct vector *) where;
 857     length = fixnum_value(vector->length) + 1;
 858     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 859
 860     return nwords;
 861 }
 862 static lispobj
 863 trans_character_string(lispobj object)
 864 {
 865     struct vector *vector;
 866     int length, nwords;
 867
 868     gc_assert(is_lisp_pointer(object));
 869
 870     /* NOTE: A string contains one more byte of data (a terminating
 871      * '\0' to help when interfacing with C functions) than indicated
 872      * by the length slot. */
 873
 874     vector = (struct vector *) native_pointer(object);
 875     length = fixnum_value(vector->length) + 1;
 876     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 877
 878     return copy_large_unboxed_object(object, nwords);
 879 }
 880
 881 static long
 882 size_character_string(lispobj *where)
 883 {
 884     struct vector *vector;
 885     int length, nwords;
 886
 887     /* NOTE: A string contains one more byte of data (a terminating
 888      * '\0' to help when interfacing with C functions) than indicated
 889      * by the length slot. */
 890
 891     vector = (struct vector *) where;
 892     length = fixnum_value(vector->length) + 1;
 893     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 894
 895     return nwords;
 896 }
 897
 898 static lispobj
 899 trans_vector(lispobj object)
 900 {
 901     struct vector *vector;
 902     long length, nwords;
 903
 904     gc_assert(is_lisp_pointer(object));
 905
 906     vector = (struct vector *) native_pointer(object);
 907
 908     length = fixnum_value(vector->length);
 909     nwords = CEILING(length + 2, 2);
 910
 911     return copy_large_object(object, nwords);
 912 }
 913
 914 static long
 915 size_vector(lispobj *where)
 916 {
 917     struct vector *vector;
 918     long length, nwords;
 919
 920     vector = (struct vector *) where;
 921     length = fixnum_value(vector->length);
 922     nwords = CEILING(length + 2, 2);
 923
 924     return nwords;
 925 }
 926
 927 static long
 928 scav_vector_nil(lispobj *where, lispobj object)
 929 {
 930     return 2;
 931 }
 932
 933 static lispobj
 934 trans_vector_nil(lispobj object)
 935 {
 936     gc_assert(is_lisp_pointer(object));
 937     return copy_unboxed_object(object, 2);
 938 }
 939
 940 static long
 941 size_vector_nil(lispobj *where)
 942 {
 943     /* Just the header word and the length word */
 944     return 2;
 945 }
 946
 947 static long
 948 scav_vector_bit(lispobj *where, lispobj object)
 949 {
 950     struct vector *vector;
 951     long length, nwords;
 952
 953     vector = (struct vector *) where;
 954     length = fixnum_value(vector->length);
 955     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 956
 957     return nwords;
 958 }
 959
 960 static lispobj
 961 trans_vector_bit(lispobj object)
 962 {
 963     struct vector *vector;
 964     long length, nwords;
 965
 966     gc_assert(is_lisp_pointer(object));
 967
 968     vector = (struct vector *) native_pointer(object);
 969     length = fixnum_value(vector->length);
 970     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 971
 972     return copy_large_unboxed_object(object, nwords);
 973 }
 974
 975 static long
 976 size_vector_bit(lispobj *where)
 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, 1) + 2, 2);
 984
 985     return nwords;
 986 }
 987
 988 static long
 989 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 990 {
 991     struct vector *vector;
 992     long length, nwords;
 993
 994     vector = (struct vector *) where;
 995     length = fixnum_value(vector->length);
 996     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 997
 998     return nwords;
 999 }
1000
1001 static lispobj
1002 trans_vector_unsigned_byte_2(lispobj object)
1003 {
1004     struct vector *vector;
1005     long length, nwords;
1006
1007     gc_assert(is_lisp_pointer(object));
1008
1009     vector = (struct vector *) native_pointer(object);
1010     length = fixnum_value(vector->length);
1011     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1012
1013     return copy_large_unboxed_object(object, nwords);
1014 }
1015
1016 static long
1017 size_vector_unsigned_byte_2(lispobj *where)
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, 2) + 2, 2);
1025
1026     return nwords;
1027 }
1028
1029 static long
1030 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1031 {
1032     struct vector *vector;
1033     long length, nwords;
1034
1035     vector = (struct vector *) where;
1036     length = fixnum_value(vector->length);
1037     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1038
1039     return nwords;
1040 }
1041
1042 static lispobj
1043 trans_vector_unsigned_byte_4(lispobj object)
1044 {
1045     struct vector *vector;
1046     long length, nwords;
1047
1048     gc_assert(is_lisp_pointer(object));
1049
1050     vector = (struct vector *) native_pointer(object);
1051     length = fixnum_value(vector->length);
1052     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1053
1054     return copy_large_unboxed_object(object, nwords);
1055 }
1056 static long
1057 size_vector_unsigned_byte_4(lispobj *where)
1058 {
1059     struct vector *vector;
1060     long length, nwords;
1061
1062     vector = (struct vector *) where;
1063     length = fixnum_value(vector->length);
1064     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1065
1066     return nwords;
1067 }
1068
1069
1070 static long
1071 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1072 {
1073     struct vector *vector;
1074     long length, nwords;
1075
1076     vector = (struct vector *) where;
1077     length = fixnum_value(vector->length);
1078     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1079
1080     return nwords;
1081 }
1082
1083 /*********************/
1084
1085
1086
1087 static lispobj
1088 trans_vector_unsigned_byte_8(lispobj object)
1089 {
1090     struct vector *vector;
1091     long length, nwords;
1092
1093     gc_assert(is_lisp_pointer(object));
1094
1095     vector = (struct vector *) native_pointer(object);
1096     length = fixnum_value(vector->length);
1097     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1098
1099     return copy_large_unboxed_object(object, nwords);
1100 }
1101
1102 static long
1103 size_vector_unsigned_byte_8(lispobj *where)
1104 {
1105     struct vector *vector;
1106     long length, nwords;
1107
1108     vector = (struct vector *) where;
1109     length = fixnum_value(vector->length);
1110     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1111
1112     return nwords;
1113 }
1114
1115
1116 static long
1117 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1118 {
1119     struct vector *vector;
1120     long length, nwords;
1121
1122     vector = (struct vector *) where;
1123     length = fixnum_value(vector->length);
1124     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1125
1126     return nwords;
1127 }
1128
1129 static lispobj
1130 trans_vector_unsigned_byte_16(lispobj object)
1131 {
1132     struct vector *vector;
1133     long length, nwords;
1134
1135     gc_assert(is_lisp_pointer(object));
1136
1137     vector = (struct vector *) native_pointer(object);
1138     length = fixnum_value(vector->length);
1139     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1140
1141     return copy_large_unboxed_object(object, nwords);
1142 }
1143
1144 static long
1145 size_vector_unsigned_byte_16(lispobj *where)
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, 16) + 2, 2);
1153
1154     return nwords;
1155 }
1156
1157 static long
1158 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1159 {
1160     struct vector *vector;
1161     long length, nwords;
1162
1163     vector = (struct vector *) where;
1164     length = fixnum_value(vector->length);
1165     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1166
1167     return nwords;
1168 }
1169
1170 static lispobj
1171 trans_vector_unsigned_byte_32(lispobj object)
1172 {
1173     struct vector *vector;
1174     long length, nwords;
1175
1176     gc_assert(is_lisp_pointer(object));
1177
1178     vector = (struct vector *) native_pointer(object);
1179     length = fixnum_value(vector->length);
1180     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1181
1182     return copy_large_unboxed_object(object, nwords);
1183 }
1184
1185 static long
1186 size_vector_unsigned_byte_32(lispobj *where)
1187 {
1188     struct vector *vector;
1189     long length, nwords;
1190
1191     vector = (struct vector *) where;
1192     length = fixnum_value(vector->length);
1193     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1194
1195     return nwords;
1196 }
1197
1198 #if N_WORD_BITS == 64
1199 static long
1200 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1201 {
1202     struct vector *vector;
1203     long length, nwords;
1204
1205     vector = (struct vector *) where;
1206     length = fixnum_value(vector->length);
1207     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1208
1209     return nwords;
1210 }
1211
1212 static lispobj
1213 trans_vector_unsigned_byte_64(lispobj object)
1214 {
1215     struct vector *vector;
1216     long length, nwords;
1217
1218     gc_assert(is_lisp_pointer(object));
1219
1220     vector = (struct vector *) native_pointer(object);
1221     length = fixnum_value(vector->length);
1222     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1223
1224     return copy_large_unboxed_object(object, nwords);
1225 }
1226
1227 static long
1228 size_vector_unsigned_byte_64(lispobj *where)
1229 {
1230     struct vector *vector;
1231     long length, nwords;
1232
1233     vector = (struct vector *) where;
1234     length = fixnum_value(vector->length);
1235     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1236
1237     return nwords;
1238 }
1239 #endif
1240
1241 static long
1242 scav_vector_single_float(lispobj *where, lispobj object)
1243 {
1244     struct vector *vector;
1245     long length, nwords;
1246
1247     vector = (struct vector *) where;
1248     length = fixnum_value(vector->length);
1249     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1250
1251     return nwords;
1252 }
1253
1254 static lispobj
1255 trans_vector_single_float(lispobj object)
1256 {
1257     struct vector *vector;
1258     long length, nwords;
1259
1260     gc_assert(is_lisp_pointer(object));
1261
1262     vector = (struct vector *) native_pointer(object);
1263     length = fixnum_value(vector->length);
1264     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1265
1266     return copy_large_unboxed_object(object, nwords);
1267 }
1268
1269 static long
1270 size_vector_single_float(lispobj *where)
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, 32) + 2, 2);
1278
1279     return nwords;
1280 }
1281
1282 static long
1283 scav_vector_double_float(lispobj *where, lispobj object)
1284 {
1285     struct vector *vector;
1286     long length, nwords;
1287
1288     vector = (struct vector *) where;
1289     length = fixnum_value(vector->length);
1290     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1291
1292     return nwords;
1293 }
1294
1295 static lispobj
1296 trans_vector_double_float(lispobj object)
1297 {
1298     struct vector *vector;
1299     long length, nwords;
1300
1301     gc_assert(is_lisp_pointer(object));
1302
1303     vector = (struct vector *) native_pointer(object);
1304     length = fixnum_value(vector->length);
1305     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1306
1307     return copy_large_unboxed_object(object, nwords);
1308 }
1309
1310 static long
1311 size_vector_double_float(lispobj *where)
1312 {
1313     struct vector *vector;
1314     long length, nwords;
1315
1316     vector = (struct vector *) where;
1317     length = fixnum_value(vector->length);
1318     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1319
1320     return nwords;
1321 }
1322
1323 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1324 static long
1325 scav_vector_long_float(lispobj *where, lispobj object)
1326 {
1327     struct vector *vector;
1328     long length, nwords;
1329
1330     vector = (struct vector *) where;
1331     length = fixnum_value(vector->length);
1332     nwords = CEILING(length *
1333                      LONG_FLOAT_SIZE
1334                      + 2, 2);
1335     return nwords;
1336 }
1337
1338 static lispobj
1339 trans_vector_long_float(lispobj object)
1340 {
1341     struct vector *vector;
1342     long length, nwords;
1343
1344     gc_assert(is_lisp_pointer(object));
1345
1346     vector = (struct vector *) native_pointer(object);
1347     length = fixnum_value(vector->length);
1348     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1349
1350     return copy_large_unboxed_object(object, nwords);
1351 }
1352
1353 static long
1354 size_vector_long_float(lispobj *where)
1355 {
1356     struct vector *vector;
1357     long length, nwords;
1358
1359     vector = (struct vector *) where;
1360     length = fixnum_value(vector->length);
1361     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1362
1363     return nwords;
1364 }
1365 #endif
1366
1367
1368 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1369 static long
1370 scav_vector_complex_single_float(lispobj *where, lispobj object)
1371 {
1372     struct vector *vector;
1373     long length, nwords;
1374
1375     vector = (struct vector *) where;
1376     length = fixnum_value(vector->length);
1377     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1378
1379     return nwords;
1380 }
1381
1382 static lispobj
1383 trans_vector_complex_single_float(lispobj object)
1384 {
1385     struct vector *vector;
1386     long length, nwords;
1387
1388     gc_assert(is_lisp_pointer(object));
1389
1390     vector = (struct vector *) native_pointer(object);
1391     length = fixnum_value(vector->length);
1392     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1393
1394     return copy_large_unboxed_object(object, nwords);
1395 }
1396
1397 static long
1398 size_vector_complex_single_float(lispobj *where)
1399 {
1400     struct vector *vector;
1401     long length, nwords;
1402
1403     vector = (struct vector *) where;
1404     length = fixnum_value(vector->length);
1405     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1406
1407     return nwords;
1408 }
1409 #endif
1410
1411 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1412 static long
1413 scav_vector_complex_double_float(lispobj *where, lispobj object)
1414 {
1415     struct vector *vector;
1416     long length, nwords;
1417
1418     vector = (struct vector *) where;
1419     length = fixnum_value(vector->length);
1420     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1421
1422     return nwords;
1423 }
1424
1425 static lispobj
1426 trans_vector_complex_double_float(lispobj object)
1427 {
1428     struct vector *vector;
1429     long length, nwords;
1430
1431     gc_assert(is_lisp_pointer(object));
1432
1433     vector = (struct vector *) native_pointer(object);
1434     length = fixnum_value(vector->length);
1435     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1436
1437     return copy_large_unboxed_object(object, nwords);
1438 }
1439
1440 static long
1441 size_vector_complex_double_float(lispobj *where)
1442 {
1443     struct vector *vector;
1444     long length, nwords;
1445
1446     vector = (struct vector *) where;
1447     length = fixnum_value(vector->length);
1448     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1449
1450     return nwords;
1451 }
1452 #endif
1453
1454
1455 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1456 static long
1457 scav_vector_complex_long_float(lispobj *where, lispobj object)
1458 {
1459     struct vector *vector;
1460     long length, nwords;
1461
1462     vector = (struct vector *) where;
1463     length = fixnum_value(vector->length);
1464     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1465
1466     return nwords;
1467 }
1468
1469 static lispobj
1470 trans_vector_complex_long_float(lispobj object)
1471 {
1472     struct vector *vector;
1473     long length, nwords;
1474
1475     gc_assert(is_lisp_pointer(object));
1476
1477     vector = (struct vector *) native_pointer(object);
1478     length = fixnum_value(vector->length);
1479     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1480
1481     return copy_large_unboxed_object(object, nwords);
1482 }
1483
1484 static long
1485 size_vector_complex_long_float(lispobj *where)
1486 {
1487     struct vector *vector;
1488     long length, nwords;
1489
1490     vector = (struct vector *) where;
1491     length = fixnum_value(vector->length);
1492     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1493
1494     return nwords;
1495 }
1496 #endif
1497
1498 #define WEAK_POINTER_NWORDS \
1499         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1500
1501 static lispobj
1502 trans_weak_pointer(lispobj object)
1503 {
1504     lispobj copy;
1505 #ifndef LISP_FEATURE_GENCGC
1506     struct weak_pointer *wp;
1507 #endif
1508     gc_assert(is_lisp_pointer(object));
1509
1510 #if defined(DEBUG_WEAK)
1511     printf("Transporting weak pointer from 0x%08x\n", object);
1512 #endif
1513
1514     /* Need to remember where all the weak pointers are that have */
1515     /* been transported so they can be fixed up in a post-GC pass. */
1516
1517     copy = copy_object(object, WEAK_POINTER_NWORDS);
1518 #ifndef LISP_FEATURE_GENCGC
1519     wp = (struct weak_pointer *) native_pointer(copy);
1520
1521     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1522     /* Push the weak pointer onto the list of weak pointers. */
1523     wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1524     weak_pointers = wp;
1525 #endif
1526     return copy;
1527 }
1528
1529 static long
1530 size_weak_pointer(lispobj *where)
1531 {
1532     return WEAK_POINTER_NWORDS;
1533 }
1534
1535
1536 void scan_weak_pointers(void)
1537 {
1538     struct weak_pointer *wp, *next_wp;
1539     for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
1540         lispobj value = wp->value;
1541         lispobj *first_pointer;
1542         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1543
1544         next_wp = wp->next;
1545         wp->next = NULL;
1546         if (next_wp == wp) /* gencgc uses a ref to self for end of list */
1547             next_wp = NULL;
1548
1549         if (!(is_lisp_pointer(value) && from_space_p(value)))
1550             continue;
1551
1552         /* Now, we need to check whether the object has been forwarded. If
1553          * it has been, the weak pointer is still good and needs to be
1554          * updated. Otherwise, the weak pointer needs to be nil'ed
1555          * out. */
1556
1557         first_pointer = (lispobj *)native_pointer(value);
1558
1559         if (forwarding_pointer_p(first_pointer)) {
1560             wp->value=
1561                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1562         } else {
1563             /* Break it. */
1564             wp->value = NIL;
1565             wp->broken = T;
1566         }
1567     }
1568 }
1569
1570 \f
1571 /* Hash tables */
1572
1573 #if N_WORD_BITS == 32
1574 #define EQ_HASH_MASK 0x1fffffff
1575 #elif N_WORD_BITS == 64
1576 #define EQ_HASH_MASK 0x1fffffffffffffff
1577 #endif
1578
1579 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1580  * target-hash-table.lisp.  */
1581 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1582
1583 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1584  * slot. Set to NULL at the end of a collection.
1585  *
1586  * This is not optimal because, when a table is tenured, it won't be
1587  * processed automatically; only the yougest generation is GC'd by
1588  * default. On the other hand, all applications will need an
1589  * occasional full GC anyway, so it's not that bad either.  */
1590 struct hash_table *weak_hash_tables = NULL;
1591
1592 /* Return true if OBJ has already survived the current GC. */
1593 static inline int
1594 survived_gc_yet (lispobj obj)
1595 {
1596     return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1597             forwarding_pointer_p(native_pointer(obj)));
1598 }
1599
1600 static inline int
1601 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1602 {
1603     switch (weakness) {
1604     case KEY:
1605         return survived_gc_yet(key);
1606     case VALUE:
1607         return survived_gc_yet(value);
1608     case KEY_OR_VALUE:
1609         return (survived_gc_yet(key) || survived_gc_yet(value));
1610     case KEY_AND_VALUE:
1611         return (survived_gc_yet(key) && survived_gc_yet(value));
1612     default:
1613         gc_assert(0);
1614         /* Shut compiler up. */
1615         return 0;
1616     }
1617 }
1618
1619 /* Return the beginning of data in ARRAY (skipping the header and the
1620  * length) or NULL if it isn't an array of the specified widetag after
1621  * all. */
1622 static inline lispobj *
1623 get_array_data (lispobj array, int widetag, unsigned long *length)
1624 {
1625     if (is_lisp_pointer(array) &&
1626         (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1627         if (length != NULL)
1628             *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1629         return ((lispobj *)native_pointer(array)) + 2;
1630     } else {
1631         return NULL;
1632     }
1633 }
1634
1635 /* Only need to worry about scavenging the _real_ entries in the
1636  * table. Phantom entries such as the hash table itself at index 0 and
1637  * the empty marker at index 1 were scavenged by scav_vector that
1638  * either called this function directly or arranged for it to be
1639  * called later by pushing the hash table onto weak_hash_tables. */
1640 static void
1641 scav_hash_table_entries (struct hash_table *hash_table)
1642 {
1643     lispobj *kv_vector;
1644     unsigned long kv_length;
1645     lispobj *index_vector;
1646     unsigned long length;
1647     lispobj *next_vector;
1648     unsigned long next_vector_length;
1649     lispobj *hash_vector;
1650     unsigned long hash_vector_length;
1651     lispobj empty_symbol;
1652     lispobj weakness = hash_table->weakness;
1653     unsigned long i;
1654
1655     kv_vector = get_array_data(hash_table->table,
1656                                SIMPLE_VECTOR_WIDETAG, &kv_length);
1657     if (kv_vector == NULL)
1658         lose("invalid kv_vector %x\n", hash_table->table);
1659
1660     index_vector = get_array_data(hash_table->index_vector,
1661                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1662     if (index_vector == NULL)
1663         lose("invalid index_vector %x\n", hash_table->index_vector);
1664
1665     next_vector = get_array_data(hash_table->next_vector,
1666                                  SIMPLE_ARRAY_WORD_WIDETAG,
1667                                  &next_vector_length);
1668     if (next_vector == NULL)
1669         lose("invalid next_vector %x\n", hash_table->next_vector);
1670
1671     hash_vector = get_array_data(hash_table->hash_vector,
1672                                  SIMPLE_ARRAY_WORD_WIDETAG,
1673                                  &hash_vector_length);
1674     if (hash_vector != NULL)
1675         gc_assert(hash_vector_length == next_vector_length);
1676
1677      /* These lengths could be different as the index_vector can be a
1678       * different length from the others, a larger index_vector could
1679       * help reduce collisions. */
1680      gc_assert(next_vector_length*2 == kv_length);
1681
1682     empty_symbol = kv_vector[1];
1683     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1684     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1685         SYMBOL_HEADER_WIDETAG) {
1686         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1687              *(lispobj *)native_pointer(empty_symbol));
1688     }
1689
1690     /* Work through the KV vector. */
1691     for (i = 1; i < next_vector_length; i++) {
1692         lispobj old_key = kv_vector[2*i];
1693         lispobj value = kv_vector[2*i+1];
1694         if ((weakness == NIL) ||
1695             weak_hash_entry_alivep(weakness, old_key, value)) {
1696
1697             /* Scavenge the key and value. */
1698             scavenge(&kv_vector[2*i],2);
1699
1700             /* If an EQ-based key has moved, mark the hash-table for
1701              * rehashing. */
1702             if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
1703                 lispobj new_key = kv_vector[2*i];
1704
1705                 if (old_key != new_key && new_key != empty_symbol) {
1706                     hash_table->needs_rehash_p = T;
1707                 }
1708             }
1709         }
1710     }
1711 }
1712
1713 long
1714 scav_vector (lispobj *where, lispobj object)
1715 {
1716     unsigned long kv_length;
1717     lispobj *kv_vector;
1718     struct hash_table *hash_table;
1719
1720     /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1721      * hash tables in the Lisp HASH-TABLE code to indicate need for
1722      * special GC support. */
1723     if (HeaderValue(object) == subtype_VectorNormal)
1724         return 1;
1725
1726     kv_length = fixnum_value(where[1]);
1727     kv_vector = where + 2;  /* Skip the header and length. */
1728     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1729
1730     /* Scavenge element 0, which may be a hash-table structure. */
1731     scavenge(where+2, 1);
1732     if (!is_lisp_pointer(where[2])) {
1733         /* This'll happen when REHASH clears the header of old-kv-vector
1734          * and fills it with zero, but some other thread simulatenously
1735          * sets the header in %%PUTHASH.
1736          */
1737         fprintf(stderr,
1738                 "Warning: no pointer at %lx in hash table: this indicates "
1739                 "non-fatal corruption caused by concurrent access to a "
1740                 "hash-table from multiple threads. Any accesses to "
1741                 "hash-tables shared between threads should be protected "
1742                 "by locks.\n", (unsigned long)&where[2]);
1743         // We've scavenged three words.
1744         return 3;
1745     }
1746     hash_table = (struct hash_table *)native_pointer(where[2]);
1747     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1748     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1749         lose("hash table not instance (%x at %x)\n",
1750              hash_table->header,
1751              hash_table);
1752     }
1753
1754     /* Scavenge element 1, which should be some internal symbol that
1755      * the hash table code reserves for marking empty slots. */
1756     scavenge(where+3, 1);
1757     if (!is_lisp_pointer(where[3])) {
1758         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1759     }
1760
1761     /* Scavenge hash table, which will fix the positions of the other
1762      * needed objects. */
1763     scavenge((lispobj *)hash_table,
1764              sizeof(struct hash_table) / sizeof(lispobj));
1765
1766     /* Cross-check the kv_vector. */
1767     if (where != (lispobj *)native_pointer(hash_table->table)) {
1768         lose("hash_table table!=this table %x\n", hash_table->table);
1769     }
1770
1771     if (hash_table->weakness == NIL) {
1772         scav_hash_table_entries(hash_table);
1773     } else {
1774         /* Delay scavenging of this table by pushing it onto
1775          * weak_hash_tables (if it's not there already) for the weak
1776          * object phase. */
1777         if (hash_table->next_weak_hash_table == NIL) {
1778             hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1779             weak_hash_tables = hash_table;
1780         }
1781     }
1782
1783     return (CEILING(kv_length + 2, 2));
1784 }
1785
1786 void
1787 scav_weak_hash_tables (void)
1788 {
1789     struct hash_table *table;
1790
1791     /* Scavenge entries whose triggers are known to survive. */
1792     for (table = weak_hash_tables; table != NULL;
1793          table = (struct hash_table *)table->next_weak_hash_table) {
1794         scav_hash_table_entries(table);
1795     }
1796 }
1797
1798 /* Walk through the chain whose first element is *FIRST and remove
1799  * dead weak entries. */
1800 static inline void
1801 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1802                             lispobj *kv_vector, lispobj *index_vector,
1803                             lispobj *next_vector, lispobj *hash_vector,
1804                             lispobj empty_symbol, lispobj weakness)
1805 {
1806     unsigned index = *prev;
1807     while (index) {
1808         unsigned next = next_vector[index];
1809         lispobj key = kv_vector[2 * index];
1810         lispobj value = kv_vector[2 * index + 1];
1811         gc_assert(key != empty_symbol);
1812         gc_assert(value != empty_symbol);
1813         if (!weak_hash_entry_alivep(weakness, key, value)) {
1814             unsigned count = fixnum_value(hash_table->number_entries);
1815             gc_assert(count > 0);
1816             *prev = next;
1817             hash_table->number_entries = make_fixnum(count - 1);
1818             next_vector[index] = fixnum_value(hash_table->next_free_kv);
1819             hash_table->next_free_kv = make_fixnum(index);
1820             kv_vector[2 * index] = empty_symbol;
1821             kv_vector[2 * index + 1] = empty_symbol;
1822             if (hash_vector)
1823                 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1824         } else {
1825             prev = &next_vector[index];
1826         }
1827         index = next;
1828     }
1829 }
1830
1831 static void
1832 scan_weak_hash_table (struct hash_table *hash_table)
1833 {
1834     lispobj *kv_vector;
1835     lispobj *index_vector;
1836     unsigned long length = 0; /* prevent warning */
1837     lispobj *next_vector;
1838     unsigned long next_vector_length = 0; /* prevent warning */
1839     lispobj *hash_vector;
1840     lispobj empty_symbol;
1841     lispobj weakness = hash_table->weakness;
1842     unsigned long i;
1843
1844     kv_vector = get_array_data(hash_table->table,
1845                                SIMPLE_VECTOR_WIDETAG, NULL);
1846     index_vector = get_array_data(hash_table->index_vector,
1847                                   SIMPLE_ARRAY_WORD_WIDETAG, &length);
1848     next_vector = get_array_data(hash_table->next_vector,
1849                                  SIMPLE_ARRAY_WORD_WIDETAG,
1850                                  &next_vector_length);
1851     hash_vector = get_array_data(hash_table->hash_vector,
1852                                  SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1853     empty_symbol = kv_vector[1];
1854
1855     for (i = 0; i < length; i++) {
1856         scan_weak_hash_table_chain(hash_table, &index_vector[i],
1857                                    kv_vector, index_vector, next_vector,
1858                                    hash_vector, empty_symbol, weakness);
1859     }
1860 }
1861
1862 /* Remove dead entries from weak hash tables. */
1863 void
1864 scan_weak_hash_tables (void)
1865 {
1866     struct hash_table *table, *next;
1867
1868     for (table = weak_hash_tables; table != NULL; table = next) {
1869         next = (struct hash_table *)table->next_weak_hash_table;
1870         table->next_weak_hash_table = NIL;
1871         scan_weak_hash_table(table);
1872     }
1873
1874     weak_hash_tables = NULL;
1875 }
1876
1877 \f
1878 /*
1879  * initialization
1880  */
1881
1882 static long
1883 scav_lose(lispobj *where, lispobj object)
1884 {
1885     lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1886          (unsigned long)object,
1887          widetag_of(*where));
1888
1889     return 0; /* bogus return value to satisfy static type checking */
1890 }
1891
1892 static lispobj
1893 trans_lose(lispobj object)
1894 {
1895     lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1896          (unsigned long)object,
1897          widetag_of(*(lispobj*)native_pointer(object)));
1898     return NIL; /* bogus return value to satisfy static type checking */
1899 }
1900
1901 static long
1902 size_lose(lispobj *where)
1903 {
1904     lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1905          (unsigned long)where,
1906          widetag_of(*where));
1907     return 1; /* bogus return value to satisfy static type checking */
1908 }
1909
1910 \f
1911 /*
1912  * initialization
1913  */
1914
1915 void
1916 gc_init_tables(void)
1917 {
1918     unsigned long i, j;
1919
1920     /* Set default value in all slots of scavenge table.  FIXME
1921      * replace this gnarly sizeof with something based on
1922      * N_WIDETAG_BITS */
1923     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1924         scavtab[i] = scav_lose;
1925     }
1926
1927     /* For each type which can be selected by the lowtag alone, set
1928      * multiple entries in our widetag scavenge table (one for each
1929      * possible value of the high bits).
1930      */
1931
1932     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1933         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
1934             if (fixnump(j)) {
1935                 scavtab[j|(i<<N_LOWTAG_BITS)] = scav_immediate;
1936             }
1937         }
1938         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1939         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1940         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1941         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1942             scav_instance_pointer;
1943         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1944         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1945     }
1946
1947     /* Other-pointer types (those selected by all eight bits of the
1948      * tag) get one entry each in the scavenge table. */
1949     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1950     scavtab[RATIO_WIDETAG] = scav_boxed;
1951 #if N_WORD_BITS == 64
1952     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1953 #else
1954     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1955 #endif
1956     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1957 #ifdef LONG_FLOAT_WIDETAG
1958     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1959 #endif
1960     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1961 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1962     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1963 #endif
1964 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1965     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1966 #endif
1967 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1968     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1969 #endif
1970     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1971     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1972 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1973     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1974 #endif
1975     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1976     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1978         scav_vector_unsigned_byte_2;
1979     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1980         scav_vector_unsigned_byte_4;
1981     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1982         scav_vector_unsigned_byte_8;
1983     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1984         scav_vector_unsigned_byte_8;
1985     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1986         scav_vector_unsigned_byte_16;
1987     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1988         scav_vector_unsigned_byte_16;
1989 #if (N_WORD_BITS == 32)
1990     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1991         scav_vector_unsigned_byte_32;
1992 #endif
1993     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1994         scav_vector_unsigned_byte_32;
1995     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1996         scav_vector_unsigned_byte_32;
1997 #if (N_WORD_BITS == 64)
1998     scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1999         scav_vector_unsigned_byte_64;
2000 #endif
2001 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2002     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2003         scav_vector_unsigned_byte_64;
2004 #endif
2005 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2006     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2007         scav_vector_unsigned_byte_64;
2008 #endif
2009 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2010     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
2011 #endif
2012 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2013     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2014         scav_vector_unsigned_byte_16;
2015 #endif
2016 #if (N_WORD_BITS == 32)
2017     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2018         scav_vector_unsigned_byte_32;
2019 #endif
2020 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2021     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2022         scav_vector_unsigned_byte_32;
2023 #endif
2024 #if (N_WORD_BITS == 64)
2025     scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2026         scav_vector_unsigned_byte_64;
2027 #endif
2028 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2029     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2030         scav_vector_unsigned_byte_64;
2031 #endif
2032     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2033     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2034 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2035     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2036 #endif
2037 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2038     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2039         scav_vector_complex_single_float;
2040 #endif
2041 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2042     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2043         scav_vector_complex_double_float;
2044 #endif
2045 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2046     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2047         scav_vector_complex_long_float;
2048 #endif
2049     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2050 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2051     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2052 #endif
2053     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2054     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2055     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2056     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2057     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2058 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2059     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2060     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2061 #endif
2062     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2063 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2064     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2065 #else
2066     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2067 #endif
2068     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2069     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2070     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2071     scavtab[SAP_WIDETAG] = scav_unboxed;
2072     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2073     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2074     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2075 #if defined(LISP_FEATURE_SPARC)
2076     scavtab[FDEFN_WIDETAG] = scav_boxed;
2077 #else
2078     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2079 #endif
2080     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2081
2082     /* transport other table, initialized same way as scavtab */
2083     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2084         transother[i] = trans_lose;
2085     transother[BIGNUM_WIDETAG] = trans_unboxed;
2086     transother[RATIO_WIDETAG] = trans_boxed;
2087
2088 #if N_WORD_BITS == 64
2089     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2090 #else
2091     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2092 #endif
2093     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2094 #ifdef LONG_FLOAT_WIDETAG
2095     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2096 #endif
2097     transother[COMPLEX_WIDETAG] = trans_boxed;
2098 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2099     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2100 #endif
2101 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2102     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2103 #endif
2104 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2105     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2106 #endif
2107     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2108     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2109 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2110     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2111 #endif
2112     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2113     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2114     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2116         trans_vector_unsigned_byte_2;
2117     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2118         trans_vector_unsigned_byte_4;
2119     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2120         trans_vector_unsigned_byte_8;
2121     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2122         trans_vector_unsigned_byte_8;
2123     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2124         trans_vector_unsigned_byte_16;
2125     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2126         trans_vector_unsigned_byte_16;
2127 #if (N_WORD_BITS == 32)
2128     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2129         trans_vector_unsigned_byte_32;
2130 #endif
2131     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2132         trans_vector_unsigned_byte_32;
2133     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2134         trans_vector_unsigned_byte_32;
2135 #if (N_WORD_BITS == 64)
2136     transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2137         trans_vector_unsigned_byte_64;
2138 #endif
2139 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2140     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2141         trans_vector_unsigned_byte_64;
2142 #endif
2143 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2144     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2145         trans_vector_unsigned_byte_64;
2146 #endif
2147 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2148     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2149         trans_vector_unsigned_byte_8;
2150 #endif
2151 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2152     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2153         trans_vector_unsigned_byte_16;
2154 #endif
2155 #if (N_WORD_BITS == 32)
2156     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2157         trans_vector_unsigned_byte_32;
2158 #endif
2159 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2160     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2161         trans_vector_unsigned_byte_32;
2162 #endif
2163 #if (N_WORD_BITS == 64)
2164     transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2165         trans_vector_unsigned_byte_64;
2166 #endif
2167 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2168     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2169         trans_vector_unsigned_byte_64;
2170 #endif
2171     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2172         trans_vector_single_float;
2173     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2174         trans_vector_double_float;
2175 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2176     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2177         trans_vector_long_float;
2178 #endif
2179 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2180     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2181         trans_vector_complex_single_float;
2182 #endif
2183 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2184     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2185         trans_vector_complex_double_float;
2186 #endif
2187 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2188     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2189         trans_vector_complex_long_float;
2190 #endif
2191     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2192 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2193     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2194 #endif
2195     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2196     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2197     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2198     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2199     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2200     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2201     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2202     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2203     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2204     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2205     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2206     transother[CHARACTER_WIDETAG] = trans_immediate;
2207     transother[SAP_WIDETAG] = trans_unboxed;
2208     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2209     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2210     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2211     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2212     transother[FDEFN_WIDETAG] = trans_boxed;
2213
2214     /* size table, initialized the same way as scavtab */
2215     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2216         sizetab[i] = size_lose;
2217     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2218         for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
2219             if (fixnump(j)) {
2220                 sizetab[j|(i<<N_LOWTAG_BITS)] = size_immediate;
2221             }
2222         }
2223         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2224         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2225         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2226         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2227         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2228         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2229     }
2230     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2231     sizetab[RATIO_WIDETAG] = size_boxed;
2232 #if N_WORD_BITS == 64
2233     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2234 #else
2235     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2236 #endif
2237     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2238 #ifdef LONG_FLOAT_WIDETAG
2239     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2240 #endif
2241     sizetab[COMPLEX_WIDETAG] = size_boxed;
2242 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2243     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2244 #endif
2245 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2246     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2247 #endif
2248 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2249     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2250 #endif
2251     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2252     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2253 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2254     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2255 #endif
2256     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2257     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2258     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2259     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2260         size_vector_unsigned_byte_2;
2261     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2262         size_vector_unsigned_byte_4;
2263     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2264         size_vector_unsigned_byte_8;
2265     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2266         size_vector_unsigned_byte_8;
2267     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2268         size_vector_unsigned_byte_16;
2269     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2270         size_vector_unsigned_byte_16;
2271 #if (N_WORD_BITS == 32)
2272     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2273         size_vector_unsigned_byte_32;
2274 #endif
2275     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2276         size_vector_unsigned_byte_32;
2277     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2278         size_vector_unsigned_byte_32;
2279 #if (N_WORD_BITS == 64)
2280     sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2281         size_vector_unsigned_byte_64;
2282 #endif
2283 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2284     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2285         size_vector_unsigned_byte_64;
2286 #endif
2287 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2288     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2289         size_vector_unsigned_byte_64;
2290 #endif
2291 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2292     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2293 #endif
2294 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2295     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2296         size_vector_unsigned_byte_16;
2297 #endif
2298 #if (N_WORD_BITS == 32)
2299     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2300         size_vector_unsigned_byte_32;
2301 #endif
2302 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2303     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2304         size_vector_unsigned_byte_32;
2305 #endif
2306 #if (N_WORD_BITS == 64)
2307     sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2308         size_vector_unsigned_byte_64;
2309 #endif
2310 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2311     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2312         size_vector_unsigned_byte_64;
2313 #endif
2314     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2315     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2316 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2317     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2318 #endif
2319 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2320     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2321         size_vector_complex_single_float;
2322 #endif
2323 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2324     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2325         size_vector_complex_double_float;
2326 #endif
2327 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2328     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2329         size_vector_complex_long_float;
2330 #endif
2331     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2332 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2333     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2334 #endif
2335     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2336     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2337     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2338     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2339     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2340 #if 0
2341     /* We shouldn't see these, so just lose if it happens. */
2342     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2343     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2344 #endif
2345     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2346     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2347     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2348     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2349     sizetab[CHARACTER_WIDETAG] = size_immediate;
2350     sizetab[SAP_WIDETAG] = size_unboxed;
2351     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2352     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2353     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2354     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2355     sizetab[FDEFN_WIDETAG] = size_boxed;
2356 }
2357
2358 \f
2359 /* Find the code object for the given pc, or return NULL on
2360    failure. */
2361 lispobj *
2362 component_ptr_from_pc(lispobj *pc)
2363 {
2364     lispobj *object = NULL;
2365
2366     if ( (object = search_read_only_space(pc)) )
2367         ;
2368     else if ( (object = search_static_space(pc)) )
2369         ;
2370     else
2371         object = search_dynamic_space(pc);
2372
2373     if (object) /* if we found something */
2374         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2375             return(object);
2376
2377     return (NULL);
2378 }
2379
2380 /* Scan an area looking for an object which encloses the given pointer.
2381  * Return the object start on success or NULL on failure. */
2382 lispobj *
2383 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2384 {
2385     while (words > 0) {
2386         size_t count = 1;
2387         lispobj thing = *start;
2388
2389         /* If thing is an immediate then this is a cons. */
2390         if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
2391             count = 2;
2392         else
2393             count = (sizetab[widetag_of(thing)])(start);
2394
2395         /* Check whether the pointer is within this object. */
2396         if ((pointer >= start) && (pointer < (start+count))) {
2397             /* found it! */
2398             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2399             return(start);
2400         }
2401
2402         /* Round up the count. */
2403         count = CEILING(count,2);
2404
2405         start += count;
2406         words -= count;
2407     }
2408     return (NULL);
2409 }
2410
2411 /* Helper for valid_lisp_pointer_p (below) and
2412  * possibly_valid_dynamic_space_pointer (gencgc).
2413  *
2414  * pointer is the pointer to validate, and start_addr is the address
2415  * of the enclosing object.
2416  */
2417 int
2418 looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
2419 {
2420     if (!is_lisp_pointer((lispobj)pointer)) {
2421         return 0;
2422     }
2423
2424     /* Check that the object pointed to is consistent with the pointer
2425      * low tag. */
2426     switch (lowtag_of((lispobj)pointer)) {
2427     case FUN_POINTER_LOWTAG:
2428         /* Start_addr should be the enclosing code object, or a closure
2429          * header. */
2430         switch (widetag_of(*start_addr)) {
2431         case CODE_HEADER_WIDETAG:
2432           /* Make sure we actually point to a function in the code object,
2433            * as opposed to a random point there. */
2434           if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(*((lispobj *)(((unsigned long)pointer)-FUN_POINTER_LOWTAG))))
2435             return 1;
2436           else
2437             return 0;
2438         case CLOSURE_HEADER_WIDETAG:
2439         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2440             if ((unsigned long)pointer !=
2441                 ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
2442                 return 0;
2443             }
2444             break;
2445         default:
2446             return 0;
2447         }
2448         break;
2449     case LIST_POINTER_LOWTAG:
2450         if ((unsigned long)pointer !=
2451             ((unsigned long)start_addr+LIST_POINTER_LOWTAG)) {
2452             return 0;
2453         }
2454         /* Is it plausible cons? */
2455         if ((is_lisp_pointer(start_addr[0]) ||
2456              is_lisp_immediate(start_addr[0])) &&
2457             (is_lisp_pointer(start_addr[1]) ||
2458              is_lisp_immediate(start_addr[1])))
2459             break;
2460         else {
2461             return 0;
2462         }
2463     case INSTANCE_POINTER_LOWTAG:
2464         if ((unsigned long)pointer !=
2465             ((unsigned long)start_addr+INSTANCE_POINTER_LOWTAG)) {
2466             return 0;
2467         }
2468         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2469             return 0;
2470         }
2471         break;
2472     case OTHER_POINTER_LOWTAG:
2473
2474 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2475         /* The all-architecture test below is good as far as it goes,
2476          * but an LRA object is similar to a FUN-POINTER: It is
2477          * embedded within a CODE-OBJECT pointed to by start_addr, and
2478          * cannot be found by simply walking the heap, therefore we
2479          * need to check for it. -- AB, 2010-Jun-04 */
2480         if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
2481             lispobj *potential_lra =
2482                 (lispobj *)(((unsigned long)pointer) - OTHER_POINTER_LOWTAG);
2483             if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
2484                 ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
2485                 return 1; /* It's as good as we can verify. */
2486             }
2487         }
2488 #endif
2489
2490         if ((unsigned long)pointer !=
2491             ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
2492             return 0;
2493         }
2494         /* Is it plausible?  Not a cons. XXX should check the headers. */
2495         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2496             return 0;
2497         }
2498         switch (widetag_of(start_addr[0])) {
2499         case UNBOUND_MARKER_WIDETAG:
2500         case NO_TLS_VALUE_MARKER_WIDETAG:
2501         case CHARACTER_WIDETAG:
2502 #if N_WORD_BITS == 64
2503         case SINGLE_FLOAT_WIDETAG:
2504 #endif
2505             return 0;
2506
2507             /* only pointed to by function pointers? */
2508         case CLOSURE_HEADER_WIDETAG:
2509         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2510             return 0;
2511
2512         case INSTANCE_HEADER_WIDETAG:
2513             return 0;
2514
2515             /* the valid other immediate pointer objects */
2516         case SIMPLE_VECTOR_WIDETAG:
2517         case RATIO_WIDETAG:
2518         case COMPLEX_WIDETAG:
2519 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2520         case COMPLEX_SINGLE_FLOAT_WIDETAG:
2521 #endif
2522 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2523         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2524 #endif
2525 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2526         case COMPLEX_LONG_FLOAT_WIDETAG:
2527 #endif
2528         case SIMPLE_ARRAY_WIDETAG:
2529         case COMPLEX_BASE_STRING_WIDETAG:
2530 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2531         case COMPLEX_CHARACTER_STRING_WIDETAG:
2532 #endif
2533         case COMPLEX_VECTOR_NIL_WIDETAG:
2534         case COMPLEX_BIT_VECTOR_WIDETAG:
2535         case COMPLEX_VECTOR_WIDETAG:
2536         case COMPLEX_ARRAY_WIDETAG:
2537         case VALUE_CELL_HEADER_WIDETAG:
2538         case SYMBOL_HEADER_WIDETAG:
2539         case FDEFN_WIDETAG:
2540         case CODE_HEADER_WIDETAG:
2541         case BIGNUM_WIDETAG:
2542 #if N_WORD_BITS != 64
2543         case SINGLE_FLOAT_WIDETAG:
2544 #endif
2545         case DOUBLE_FLOAT_WIDETAG:
2546 #ifdef LONG_FLOAT_WIDETAG
2547         case LONG_FLOAT_WIDETAG:
2548 #endif
2549         case SIMPLE_BASE_STRING_WIDETAG:
2550 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2551         case SIMPLE_CHARACTER_STRING_WIDETAG:
2552 #endif
2553         case SIMPLE_BIT_VECTOR_WIDETAG:
2554         case SIMPLE_ARRAY_NIL_WIDETAG:
2555         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2556         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2557         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2558         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2559         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2560         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2561
2562         case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
2563
2564         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2565         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2566 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2567         case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2568 #endif
2569 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2570         case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2571 #endif
2572 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2573         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2574 #endif
2575 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2576         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2577 #endif
2578
2579         case SIMPLE_ARRAY_FIXNUM_WIDETAG:
2580
2581 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2582         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2583 #endif
2584 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2585         case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2586 #endif
2587         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2588         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2589 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2590         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2591 #endif
2592 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2593         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2594 #endif
2595 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2596         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2597 #endif
2598 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2599         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2600 #endif
2601         case SAP_WIDETAG:
2602         case WEAK_POINTER_WIDETAG:
2603             break;
2604
2605         default:
2606             return 0;
2607         }
2608         break;
2609     default:
2610         return 0;
2611     }
2612
2613     /* looks good */
2614     return 1;
2615 }
2616
2617 /* Used by the debugger to validate possibly bogus pointers before
2618  * calling MAKE-LISP-OBJ on them.
2619  *
2620  * FIXME: We would like to make this perfect, because if the debugger
2621  * constructs a reference to a bugs lisp object, and it ends up in a
2622  * location scavenged by the GC all hell breaks loose.
2623  *
2624  * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2625  * and return true for all valid pointers, this could actually be eager
2626  * and lie about a few pointers without bad results... but that should
2627  * be reflected in the name.
2628  */
2629 int
2630 valid_lisp_pointer_p(lispobj *pointer)
2631 {
2632     lispobj *start;
2633     if (((start=search_dynamic_space(pointer))!=NULL) ||
2634         ((start=search_static_space(pointer))!=NULL) ||
2635         ((start=search_read_only_space(pointer))!=NULL))
2636         return looks_like_valid_lisp_pointer_p(pointer, start);
2637     else
2638         return 0;
2639 }
2640
2641 boolean
2642 maybe_gc(os_context_t *context)
2643 {
2644     lispobj gc_happened;
2645     struct thread *thread = arch_os_get_current_thread();
2646
2647     fake_foreign_function_call(context);
2648     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2649      * which case we will be running with no gc trigger barrier
2650      * thing for a while.  But it shouldn't be long until the end
2651      * of WITHOUT-GCING.
2652      *
2653      * FIXME: It would be good to protect the end of dynamic space for
2654      * CheneyGC and signal a storage condition from there.
2655      */
2656
2657     /* Restore the signal mask from the interrupted context before
2658      * calling into Lisp if interrupts are enabled. Why not always?
2659      *
2660      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2661      * interrupt hits while in SUB-GC, it is deferred and the
2662      * os_context_sigmask of that interrupt is set to block further
2663      * deferrable interrupts (until the first one is
2664      * handled). Unfortunately, that context refers to this place and
2665      * when we return from here the signals will not be blocked.
2666      *
2667      * A kludgy alternative is to propagate the sigmask change to the
2668      * outer context.
2669      */
2670 #ifndef LISP_FEATURE_WIN32
2671     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2672     unblock_gc_signals(0, 0);
2673 #endif
2674     FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2675     /* FIXME: Nothing must go wrong during GC else we end up running
2676      * the debugger, error handlers, and user code in general in a
2677      * potentially unsafe place. Running out of the control stack or
2678      * the heap in SUB-GC are ways to lose. Of course, deferrables
2679      * cannot be unblocked because there may be a pending handler, or
2680      * we may even be in a WITHOUT-INTERRUPTS. */
2681     gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2682     FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2683            (gc_happened == NIL) ? "NIL" : "T"));
2684     if ((gc_happened != NIL) &&
2685         /* See if interrupts are enabled or it's possible to enable
2686          * them. POST-GC has a similar check, but we don't want to
2687          * unlock deferrables in that case and get a pending interrupt
2688          * here. */
2689         ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2690          (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2691 #ifndef LISP_FEATURE_WIN32
2692         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2693         if (!deferrables_blocked_p(context_sigmask)) {
2694             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2695             check_gc_signals_unblocked_or_lose(0);
2696 #endif
2697             FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2698             funcall0(StaticSymbolFunction(POST_GC));
2699 #ifndef LISP_FEATURE_WIN32
2700         } else {
2701             FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2702         }
2703 #endif
2704     }
2705     undo_fake_foreign_function_call(context);
2706     FSHOW((stderr, "/maybe_gc: returning\n"));
2707     return (gc_happened != NIL);
2708 }
2709
2710 #define BYTES_ZERO_BEFORE_END (1<<12)
2711
2712 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2713  * Lisp and another called zero_stack() in cheneygc.c, but since it's
2714  * shorter to express in, and more often called from C, I keep only
2715  * the C one after fixing it. -- MG 2009-03-25 */
2716
2717 /* Zero the unused portion of the control stack so that old objects
2718  * are not kept alive because of uninitialized stack variables.
2719  *
2720  * "To summarize the problem, since not all allocated stack frame
2721  * slots are guaranteed to be written by the time you call an another
2722  * function or GC, there may be garbage pointers retained in your dead
2723  * stack locations. The stack scrubbing only affects the part of the
2724  * stack from the SP to the end of the allocated stack." - ram, on
2725  * cmucl-imp, Tue, 25 Sep 2001
2726  *
2727  * So, as an (admittedly lame) workaround, from time to time we call
2728  * scrub-control-stack to zero out all the unused portion. This is
2729  * supposed to happen when the stack is mostly empty, so that we have
2730  * a chance of clearing more of it: callers are currently (2002.07.18)
2731  * REPL, SUB-GC and sig_stop_for_gc_handler. */
2732
2733 /* Take care not to tread on the guard page and the hard guard page as
2734  * it would be unkind to sig_stop_for_gc_handler. Touching the return
2735  * guard page is not dangerous. For this to work the guard page must
2736  * be zeroed when protected. */
2737
2738 /* FIXME: I think there is no guarantee that once
2739  * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2740  * may be what the "lame" adjective in the above comment is for. In
2741  * this case, exact gc may lose badly. */
2742 void
2743 scrub_control_stack(void)
2744 {
2745     struct thread *th = arch_os_get_current_thread();
2746     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2747     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2748     lispobj *sp;
2749 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2750     sp = (lispobj *)&sp - 1;
2751 #else
2752     sp = access_control_stack_pointer(th);
2753 #endif
2754  scrub:
2755     if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2756          ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2757         (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2758          ((os_vm_address_t)sp >= guard_page_address) &&
2759          (th->control_stack_guard_page_protected != NIL)))
2760         return;
2761 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2762     do {
2763         *sp = 0;
2764     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2765     if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2766         return;
2767     do {
2768         if (*sp)
2769             goto scrub;
2770     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2771 #else
2772     do {
2773         *sp = 0;
2774     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2775     if ((os_vm_address_t)sp >= hard_guard_page_address)
2776         return;
2777     do {
2778         if (*sp)
2779             goto scrub;
2780     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2781 #endif
2782 }
2783 \f
2784 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2785
2786 /* Scavenging Interrupt Contexts */
2787
2788 static int boxed_registers[] = BOXED_REGISTERS;
2789
2790 /* The GC has a notion of an "interior pointer" register, an unboxed
2791  * register that typically contains a pointer to inside an object
2792  * referenced by another pointer.  The most obvious of these is the
2793  * program counter, although many compiler backends define a "Lisp
2794  * Interior Pointer" register known to the runtime as reg_LIP, and
2795  * various CPU architectures have other registers that also partake of
2796  * the interior-pointer nature.  As the code for pairing an interior
2797  * pointer value up with its "base" register, and fixing it up after
2798  * scavenging is complete is horribly repetitive, a few macros paper
2799  * over the monotony.  --AB, 2010-Jul-14 */
2800
2801 /* These macros are only ever used over a lexical environment which
2802  * defines a pointer to an os_context_t called context, thus we don't
2803  * bother to pass that context in as a parameter. */
2804
2805 /* Define how to access a given interior pointer. */
2806 #define ACCESS_INTERIOR_POINTER_pc \
2807     *os_context_pc_addr(context)
2808 #define ACCESS_INTERIOR_POINTER_lip \
2809     *os_context_register_addr(context, reg_LIP)
2810 #define ACCESS_INTERIOR_POINTER_lr \
2811     *os_context_lr_addr(context)
2812 #define ACCESS_INTERIOR_POINTER_npc \
2813     *os_context_npc_addr(context)
2814 #define ACCESS_INTERIOR_POINTER_ctr \
2815     *os_context_ctr_addr(context)
2816
2817 #define INTERIOR_POINTER_VARS(name) \
2818     unsigned long name##_offset;    \
2819     int name##_register_pair
2820
2821 #define PAIR_INTERIOR_POINTER(name)                             \
2822     pair_interior_pointer(context,                              \
2823                           ACCESS_INTERIOR_POINTER_##name,       \
2824                           &name##_offset,                       \
2825                           &name##_register_pair)
2826
2827 /* One complexity here is that if a paired register is not found for
2828  * an interior pointer, then that pointer does not get updated.
2829  * Originally, there was some commentary about using an index of -1
2830  * when calling os_context_register_addr() on SPARC referring to the
2831  * program counter, but the real reason is to allow an interior
2832  * pointer register to point to the runtime, read-only space, or
2833  * static space without problems. */
2834 #define FIXUP_INTERIOR_POINTER(name)                                    \
2835     do {                                                                \
2836         if (name##_register_pair >= 0) {                                \
2837             ACCESS_INTERIOR_POINTER_##name =                            \
2838                 (*os_context_register_addr(context,                     \
2839                                            name##_register_pair)        \
2840                  & ~LOWTAG_MASK)                                        \
2841                 + name##_offset;                                        \
2842         }                                                               \
2843     } while (0)
2844
2845
2846 static void
2847 pair_interior_pointer(os_context_t *context, unsigned long pointer,
2848                       unsigned long *saved_offset, int *register_pair)
2849 {
2850     int i;
2851
2852     /*
2853      * I (RLT) think this is trying to find the boxed register that is
2854      * closest to the LIP address, without going past it.  Usually, it's
2855      * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2856      */
2857     /* 0x7FFFFFFF on 32-bit platforms;
2858        0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2859     *saved_offset = (((unsigned long)1) << (N_WORD_BITS - 1)) - 1;
2860     *register_pair = -1;
2861     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2862         unsigned long reg;
2863         long offset;
2864         int index;
2865
2866         index = boxed_registers[i];
2867         reg = *os_context_register_addr(context, index);
2868
2869         /* An interior pointer is never relative to a non-pointer
2870          * register (an oversight in the original implementation).
2871          * The simplest argument for why this is true is to consider
2872          * the fixnum that happens by coincide to be the word-index in
2873          * memory of the header for some object plus two.  This is
2874          * happenstance would cause the register containing the fixnum
2875          * to be selected as the register_pair if the interior pointer
2876          * is to anywhere after the first two words of the object.
2877          * The fixnum won't be changed during GC, but the object might
2878          * move, thus destroying the interior pointer.  --AB,
2879          * 2010-Jul-14 */
2880
2881         if (is_lisp_pointer(reg) &&
2882             ((reg & ~LOWTAG_MASK) <= pointer)) {
2883             offset = pointer - (reg & ~LOWTAG_MASK);
2884             if (offset < *saved_offset) {
2885                 *saved_offset = offset;
2886                 *register_pair = index;
2887             }
2888         }
2889     }
2890 }
2891
2892 static void
2893 scavenge_interrupt_context(os_context_t * context)
2894 {
2895     int i;
2896
2897     /* FIXME: The various #ifdef noise here is precisely that: noise.
2898      * Is it possible to fold it into the macrology so that we have
2899      * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2900      * compile out for the registers that don't exist on a given
2901      * platform? */
2902
2903     INTERIOR_POINTER_VARS(pc);
2904 #ifdef reg_LIP
2905     INTERIOR_POINTER_VARS(lip);
2906 #endif
2907 #ifdef ARCH_HAS_LINK_REGISTER
2908     INTERIOR_POINTER_VARS(lr);
2909 #endif
2910 #ifdef ARCH_HAS_NPC_REGISTER
2911     INTERIOR_POINTER_VARS(npc);
2912 #endif
2913 #ifdef LISP_FEATURE_PPC
2914     INTERIOR_POINTER_VARS(ctr);
2915 #endif
2916
2917     PAIR_INTERIOR_POINTER(pc);
2918 #ifdef reg_LIP
2919     PAIR_INTERIOR_POINTER(lip);
2920 #endif
2921 #ifdef ARCH_HAS_LINK_REGISTER
2922     PAIR_INTERIOR_POINTER(lr);
2923 #endif
2924 #ifdef ARCH_HAS_NPC_REGISTER
2925     PAIR_INTERIOR_POINTER(npc);
2926 #endif
2927 #ifdef LISP_FEATURE_PPC
2928     PAIR_INTERIOR_POINTER(ctr);
2929 #endif
2930
2931     /* Scavenge all boxed registers in the context. */
2932     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2933         int index;
2934         lispobj foo;
2935
2936         index = boxed_registers[i];
2937         foo = *os_context_register_addr(context, index);
2938         scavenge(&foo, 1);
2939         *os_context_register_addr(context, index) = foo;
2940
2941         /* this is unlikely to work as intended on bigendian
2942          * 64 bit platforms */
2943
2944         scavenge((lispobj *) os_context_register_addr(context, index), 1);
2945     }
2946
2947     /* Now that the scavenging is done, repair the various interior
2948      * pointers. */
2949     FIXUP_INTERIOR_POINTER(pc);
2950 #ifdef reg_LIP
2951     FIXUP_INTERIOR_POINTER(lip);
2952 #endif
2953 #ifdef ARCH_HAS_LINK_REGISTER
2954     FIXUP_INTERIOR_POINTER(lr);
2955 #endif
2956 #ifdef ARCH_HAS_NPC_REGISTER
2957     FIXUP_INTERIOR_POINTER(npc);
2958 #endif
2959 #ifdef LISP_FEATURE_PPC
2960     FIXUP_INTERIOR_POINTER(ctr);
2961 #endif
2962 }
2963
2964 void
2965 scavenge_interrupt_contexts(struct thread *th)
2966 {
2967     int i, index;
2968     os_context_t *context;
2969
2970     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
2971
2972 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2973     printf("Number of active contexts: %d\n", index);
2974 #endif
2975
2976     for (i = 0; i < index; i++) {
2977         context = th->interrupt_contexts[i];
2978         scavenge_interrupt_context(context);
2979     }
2980 }
2981 #endif /* x86oid targets */