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