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(object));
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(LOW_WORD(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;
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         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1935         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1936         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1937         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1938         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1939         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1940             scav_instance_pointer;
1941         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1942         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1943     }
1944
1945     /* Other-pointer types (those selected by all eight bits of the
1946      * tag) get one entry each in the scavenge table. */
1947     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1948     scavtab[RATIO_WIDETAG] = scav_boxed;
1949 #if N_WORD_BITS == 64
1950     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1951 #else
1952     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1953 #endif
1954     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1955 #ifdef LONG_FLOAT_WIDETAG
1956     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1957 #endif
1958     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1959 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1960     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1961 #endif
1962 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1963     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1964 #endif
1965 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1966     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1967 #endif
1968     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1969     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1970 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1971     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1972 #endif
1973     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1974     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1975     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1976         scav_vector_unsigned_byte_2;
1977     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1978         scav_vector_unsigned_byte_4;
1979     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1980         scav_vector_unsigned_byte_8;
1981     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1982         scav_vector_unsigned_byte_8;
1983     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1984         scav_vector_unsigned_byte_16;
1985     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1986         scav_vector_unsigned_byte_16;
1987 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1988     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1989         scav_vector_unsigned_byte_32;
1990 #endif
1991     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1992         scav_vector_unsigned_byte_32;
1993     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1994         scav_vector_unsigned_byte_32;
1995 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1996     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1997         scav_vector_unsigned_byte_64;
1998 #endif
1999 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2000     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2001         scav_vector_unsigned_byte_64;
2002 #endif
2003 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2004     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2005         scav_vector_unsigned_byte_64;
2006 #endif
2007 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2008     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
2009 #endif
2010 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2011     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2012         scav_vector_unsigned_byte_16;
2013 #endif
2014 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2015     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2016         scav_vector_unsigned_byte_32;
2017 #endif
2018 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2019     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2020         scav_vector_unsigned_byte_32;
2021 #endif
2022 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2023     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2024         scav_vector_unsigned_byte_64;
2025 #endif
2026 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2027     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2028         scav_vector_unsigned_byte_64;
2029 #endif
2030     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2031     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2032 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2033     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2034 #endif
2035 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2036     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2037         scav_vector_complex_single_float;
2038 #endif
2039 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2040     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2041         scav_vector_complex_double_float;
2042 #endif
2043 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2044     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2045         scav_vector_complex_long_float;
2046 #endif
2047     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2048 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2049     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2050 #endif
2051     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2052     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2053     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2054     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2055     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2056 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2057     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2058     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2059 #endif
2060     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2061 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2062     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2063 #else
2064     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2065 #endif
2066     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2067     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2068     scavtab[CHARACTER_WIDETAG] = scav_immediate;
2069     scavtab[SAP_WIDETAG] = scav_unboxed;
2070     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2071     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2072     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2073 #if defined(LISP_FEATURE_SPARC)
2074     scavtab[FDEFN_WIDETAG] = scav_boxed;
2075 #else
2076     scavtab[FDEFN_WIDETAG] = scav_fdefn;
2077 #endif
2078     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2079
2080     /* transport other table, initialized same way as scavtab */
2081     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2082         transother[i] = trans_lose;
2083     transother[BIGNUM_WIDETAG] = trans_unboxed;
2084     transother[RATIO_WIDETAG] = trans_boxed;
2085
2086 #if N_WORD_BITS == 64
2087     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2088 #else
2089     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2090 #endif
2091     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2092 #ifdef LONG_FLOAT_WIDETAG
2093     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2094 #endif
2095     transother[COMPLEX_WIDETAG] = trans_boxed;
2096 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2097     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2098 #endif
2099 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2100     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2101 #endif
2102 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2103     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2104 #endif
2105     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2106     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2107 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2108     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2109 #endif
2110     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2111     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2112     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2113     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2114         trans_vector_unsigned_byte_2;
2115     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2116         trans_vector_unsigned_byte_4;
2117     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2118         trans_vector_unsigned_byte_8;
2119     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2120         trans_vector_unsigned_byte_8;
2121     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2122         trans_vector_unsigned_byte_16;
2123     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2124         trans_vector_unsigned_byte_16;
2125 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2126     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2127         trans_vector_unsigned_byte_32;
2128 #endif
2129     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2130         trans_vector_unsigned_byte_32;
2131     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2132         trans_vector_unsigned_byte_32;
2133 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2134     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2135         trans_vector_unsigned_byte_64;
2136 #endif
2137 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2138     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2139         trans_vector_unsigned_byte_64;
2140 #endif
2141 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2142     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2143         trans_vector_unsigned_byte_64;
2144 #endif
2145 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2146     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2147         trans_vector_unsigned_byte_8;
2148 #endif
2149 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2150     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2151         trans_vector_unsigned_byte_16;
2152 #endif
2153 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2154     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2155         trans_vector_unsigned_byte_32;
2156 #endif
2157 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2158     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2159         trans_vector_unsigned_byte_32;
2160 #endif
2161 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2162     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2163         trans_vector_unsigned_byte_64;
2164 #endif
2165 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2166     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2167         trans_vector_unsigned_byte_64;
2168 #endif
2169     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2170         trans_vector_single_float;
2171     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2172         trans_vector_double_float;
2173 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2174     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2175         trans_vector_long_float;
2176 #endif
2177 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2178     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2179         trans_vector_complex_single_float;
2180 #endif
2181 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2182     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2183         trans_vector_complex_double_float;
2184 #endif
2185 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2186     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2187         trans_vector_complex_long_float;
2188 #endif
2189     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2190 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2191     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2192 #endif
2193     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2194     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2195     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2196     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2197     transother[CODE_HEADER_WIDETAG] = trans_code_header;
2198     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2199     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2200     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2201     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2202     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2203     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2204     transother[CHARACTER_WIDETAG] = trans_immediate;
2205     transother[SAP_WIDETAG] = trans_unboxed;
2206     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2207     transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2208     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2209     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2210     transother[FDEFN_WIDETAG] = trans_boxed;
2211
2212     /* size table, initialized the same way as scavtab */
2213     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2214         sizetab[i] = size_lose;
2215     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2216         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2217         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2218         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2219         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2220         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
2221         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2222         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2223         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2224     }
2225     sizetab[BIGNUM_WIDETAG] = size_unboxed;
2226     sizetab[RATIO_WIDETAG] = size_boxed;
2227 #if N_WORD_BITS == 64
2228     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2229 #else
2230     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2231 #endif
2232     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2233 #ifdef LONG_FLOAT_WIDETAG
2234     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2235 #endif
2236     sizetab[COMPLEX_WIDETAG] = size_boxed;
2237 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2238     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2239 #endif
2240 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2241     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2242 #endif
2243 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2244     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2245 #endif
2246     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2247     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2248 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2249     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2250 #endif
2251     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2252     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2253     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2254     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2255         size_vector_unsigned_byte_2;
2256     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2257         size_vector_unsigned_byte_4;
2258     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2259         size_vector_unsigned_byte_8;
2260     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2261         size_vector_unsigned_byte_8;
2262     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2263         size_vector_unsigned_byte_16;
2264     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2265         size_vector_unsigned_byte_16;
2266 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2267     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
2268         size_vector_unsigned_byte_32;
2269 #endif
2270     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2271         size_vector_unsigned_byte_32;
2272     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2273         size_vector_unsigned_byte_32;
2274 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2275     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
2276         size_vector_unsigned_byte_64;
2277 #endif
2278 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2279     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2280         size_vector_unsigned_byte_64;
2281 #endif
2282 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2283     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2284         size_vector_unsigned_byte_64;
2285 #endif
2286 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2287     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2288 #endif
2289 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2290     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2291         size_vector_unsigned_byte_16;
2292 #endif
2293 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2294     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2295         size_vector_unsigned_byte_32;
2296 #endif
2297 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2298     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2299         size_vector_unsigned_byte_32;
2300 #endif
2301 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2302     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
2303         size_vector_unsigned_byte_64;
2304 #endif
2305 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2306     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2307         size_vector_unsigned_byte_64;
2308 #endif
2309     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2310     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2311 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2312     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2313 #endif
2314 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2315     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2316         size_vector_complex_single_float;
2317 #endif
2318 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2319     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2320         size_vector_complex_double_float;
2321 #endif
2322 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2323     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2324         size_vector_complex_long_float;
2325 #endif
2326     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2327 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2328     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2329 #endif
2330     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2331     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2332     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2333     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2334     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2335 #if 0
2336     /* We shouldn't see these, so just lose if it happens. */
2337     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2338     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2339 #endif
2340     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2341     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2342     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2343     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2344     sizetab[CHARACTER_WIDETAG] = size_immediate;
2345     sizetab[SAP_WIDETAG] = size_unboxed;
2346     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2347     sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
2348     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2349     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2350     sizetab[FDEFN_WIDETAG] = size_boxed;
2351 }
2352
2353 \f
2354 /* Find the code object for the given pc, or return NULL on
2355    failure. */
2356 lispobj *
2357 component_ptr_from_pc(lispobj *pc)
2358 {
2359     lispobj *object = NULL;
2360
2361     if ( (object = search_read_only_space(pc)) )
2362         ;
2363     else if ( (object = search_static_space(pc)) )
2364         ;
2365     else
2366         object = search_dynamic_space(pc);
2367
2368     if (object) /* if we found something */
2369         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2370             return(object);
2371
2372     return (NULL);
2373 }
2374
2375 /* Scan an area looking for an object which encloses the given pointer.
2376  * Return the object start on success or NULL on failure. */
2377 lispobj *
2378 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2379 {
2380     while (words > 0) {
2381         size_t count = 1;
2382         lispobj thing = *start;
2383
2384         /* If thing is an immediate then this is a cons. */
2385         if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
2386             count = 2;
2387         else
2388             count = (sizetab[widetag_of(thing)])(start);
2389
2390         /* Check whether the pointer is within this object. */
2391         if ((pointer >= start) && (pointer < (start+count))) {
2392             /* found it! */
2393             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2394             return(start);
2395         }
2396
2397         /* Round up the count. */
2398         count = CEILING(count,2);
2399
2400         start += count;
2401         words -= count;
2402     }
2403     return (NULL);
2404 }
2405
2406 boolean
2407 maybe_gc(os_context_t *context)
2408 {
2409     lispobj gc_happened;
2410     struct thread *thread = arch_os_get_current_thread();
2411
2412     fake_foreign_function_call(context);
2413     /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2414      * which case we will be running with no gc trigger barrier
2415      * thing for a while.  But it shouldn't be long until the end
2416      * of WITHOUT-GCING.
2417      *
2418      * FIXME: It would be good to protect the end of dynamic space for
2419      * CheneyGC and signal a storage condition from there.
2420      */
2421
2422     /* Restore the signal mask from the interrupted context before
2423      * calling into Lisp if interrupts are enabled. Why not always?
2424      *
2425      * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2426      * interrupt hits while in SUB-GC, it is deferred and the
2427      * os_context_sigmask of that interrupt is set to block further
2428      * deferrable interrupts (until the first one is
2429      * handled). Unfortunately, that context refers to this place and
2430      * when we return from here the signals will not be blocked.
2431      *
2432      * A kludgy alternative is to propagate the sigmask change to the
2433      * outer context.
2434      */
2435 #ifndef LISP_FEATURE_WIN32
2436     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2437     unblock_gc_signals(0, 0);
2438 #endif
2439     FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2440     /* FIXME: Nothing must go wrong during GC else we end up running
2441      * the debugger, error handlers, and user code in general in a
2442      * potentially unsafe place. Running out of the control stack or
2443      * the heap in SUB-GC are ways to lose. Of course, deferrables
2444      * cannot be unblocked because there may be a pending handler, or
2445      * we may even be in a WITHOUT-INTERRUPTS. */
2446     gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2447     FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2448            (gc_happened == NIL) ? "NIL" : "T"));
2449     if ((gc_happened != NIL) &&
2450         /* See if interrupts are enabled or it's possible to enable
2451          * them. POST-GC has a similar check, but we don't want to
2452          * unlock deferrables in that case and get a pending interrupt
2453          * here. */
2454         ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2455          (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2456 #ifndef LISP_FEATURE_WIN32
2457         sigset_t *context_sigmask = os_context_sigmask_addr(context);
2458         if (!deferrables_blocked_p(context_sigmask)) {
2459             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2460             check_gc_signals_unblocked_or_lose(0);
2461 #endif
2462             FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2463             funcall0(StaticSymbolFunction(POST_GC));
2464 #ifndef LISP_FEATURE_WIN32
2465         } else {
2466             FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2467         }
2468 #endif
2469     }
2470     undo_fake_foreign_function_call(context);
2471     FSHOW((stderr, "/maybe_gc: returning\n"));
2472     return (gc_happened != NIL);
2473 }
2474
2475 #define BYTES_ZERO_BEFORE_END (1<<12)
2476
2477 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2478  * Lisp and another called zero_stack() in cheneygc.c, but since it's
2479  * shorter to express in, and more often called from C, I keep only
2480  * the C one after fixing it. -- MG 2009-03-25 */
2481
2482 /* Zero the unused portion of the control stack so that old objects
2483  * are not kept alive because of uninitialized stack variables.
2484  *
2485  * "To summarize the problem, since not all allocated stack frame
2486  * slots are guaranteed to be written by the time you call an another
2487  * function or GC, there may be garbage pointers retained in your dead
2488  * stack locations. The stack scrubbing only affects the part of the
2489  * stack from the SP to the end of the allocated stack." - ram, on
2490  * cmucl-imp, Tue, 25 Sep 2001
2491  *
2492  * So, as an (admittedly lame) workaround, from time to time we call
2493  * scrub-control-stack to zero out all the unused portion. This is
2494  * supposed to happen when the stack is mostly empty, so that we have
2495  * a chance of clearing more of it: callers are currently (2002.07.18)
2496  * REPL, SUB-GC and sig_stop_for_gc_handler. */
2497
2498 /* Take care not to tread on the guard page and the hard guard page as
2499  * it would be unkind to sig_stop_for_gc_handler. Touching the return
2500  * guard page is not dangerous. For this to work the guard page must
2501  * be zeroed when protected. */
2502
2503 /* FIXME: I think there is no guarantee that once
2504  * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2505  * may be what the "lame" adjective in the above comment is for. In
2506  * this case, exact gc may lose badly. */
2507 void
2508 scrub_control_stack(void)
2509 {
2510     struct thread *th = arch_os_get_current_thread();
2511     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2512     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2513     lispobj *sp;
2514 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2515     sp = (lispobj *)&sp - 1;
2516 #else
2517     sp = current_control_stack_pointer;
2518 #endif
2519  scrub:
2520     if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2521          ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2522         (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2523          ((os_vm_address_t)sp >= guard_page_address) &&
2524          (th->control_stack_guard_page_protected != NIL)))
2525         return;
2526 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2527     do {
2528         *sp = 0;
2529     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2530     if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2531         return;
2532     do {
2533         if (*sp)
2534             goto scrub;
2535     } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2536 #else
2537     do {
2538         *sp = 0;
2539     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2540     if ((os_vm_address_t)sp >= hard_guard_page_address)
2541         return;
2542     do {
2543         if (*sp)
2544             goto scrub;
2545     } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2546 #endif
2547 }
2548 \f
2549 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2550
2551 /* Scavenging Interrupt Contexts */
2552
2553 static int boxed_registers[] = BOXED_REGISTERS;
2554
2555 /* The GC has a notion of an "interior pointer" register, an unboxed
2556  * register that typically contains a pointer to inside an object
2557  * referenced by another pointer.  The most obvious of these is the
2558  * program counter, although many compiler backends define a "Lisp
2559  * Interior Pointer" register known to the runtime as reg_LIP, and
2560  * various CPU architectures have other registers that also partake of
2561  * the interior-pointer nature.  As the code for pairing an interior
2562  * pointer value up with its "base" register, and fixing it up after
2563  * scavenging is complete is horribly repetitive, a few macros paper
2564  * over the monotony.  --AB, 2010-Jul-14 */
2565
2566 /* These macros are only ever used over a lexical environment which
2567  * defines a pointer to an os_context_t called context, thus we don't
2568  * bother to pass that context in as a parameter. */
2569
2570 /* Define how to access a given interior pointer. */
2571 #define ACCESS_INTERIOR_POINTER_pc \
2572     *os_context_pc_addr(context)
2573 #define ACCESS_INTERIOR_POINTER_lip \
2574     *os_context_register_addr(context, reg_LIP)
2575 #define ACCESS_INTERIOR_POINTER_lr \
2576     *os_context_lr_addr(context)
2577 #define ACCESS_INTERIOR_POINTER_npc \
2578     *os_context_npc_addr(context)
2579 #define ACCESS_INTERIOR_POINTER_ctr \
2580     *os_context_ctr_addr(context)
2581
2582 #define INTERIOR_POINTER_VARS(name) \
2583     unsigned long name##_offset;    \
2584     int name##_register_pair
2585
2586 #define PAIR_INTERIOR_POINTER(name)                             \
2587     pair_interior_pointer(context,                              \
2588                           ACCESS_INTERIOR_POINTER_##name,       \
2589                           &name##_offset,                       \
2590                           &name##_register_pair)
2591
2592 /* One complexity here is that if a paired register is not found for
2593  * an interior pointer, then that pointer does not get updated.
2594  * Originally, there was some commentary about using an index of -1
2595  * when calling os_context_register_addr() on SPARC referring to the
2596  * program counter, but the real reason is to allow an interior
2597  * pointer register to point to the runtime, read-only space, or
2598  * static space without problems. */
2599 #define FIXUP_INTERIOR_POINTER(name)                                    \
2600     do {                                                                \
2601         if (name##_register_pair >= 0) {                                \
2602             ACCESS_INTERIOR_POINTER_##name =                            \
2603                 (*os_context_register_addr(context,                     \
2604                                            name##_register_pair)        \
2605                  & ~LOWTAG_MASK)                                        \
2606                 + name##_offset;                                        \
2607         }                                                               \
2608     } while (0)
2609
2610
2611 static void
2612 pair_interior_pointer(os_context_t *context, unsigned long pointer,
2613                       unsigned long *saved_offset, int *register_pair)
2614 {
2615     int i;
2616
2617     /*
2618      * I (RLT) think this is trying to find the boxed register that is
2619      * closest to the LIP address, without going past it.  Usually, it's
2620      * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2621      */
2622     /* 0x7FFFFFFF on 32-bit platforms;
2623        0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2624     *saved_offset = (((unsigned long)1) << (N_WORD_BITS - 1)) - 1;
2625     *register_pair = -1;
2626     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2627         unsigned long reg;
2628         long offset;
2629         int index;
2630
2631         index = boxed_registers[i];
2632         reg = *os_context_register_addr(context, index);
2633
2634         /* An interior pointer is never relative to a non-pointer
2635          * register (an oversight in the original implementation).
2636          * The simplest argument for why this is true is to consider
2637          * the fixnum that happens by coincide to be the word-index in
2638          * memory of the header for some object plus two.  This is
2639          * happenstance would cause the register containing the fixnum
2640          * to be selected as the register_pair if the interior pointer
2641          * is to anywhere after the first two words of the object.
2642          * The fixnum won't be changed during GC, but the object might
2643          * move, thus destroying the interior pointer.  --AB,
2644          * 2010-Jul-14 */
2645
2646         if (is_lisp_pointer(reg) &&
2647             ((reg & ~LOWTAG_MASK) <= pointer)) {
2648             offset = pointer - (reg & ~LOWTAG_MASK);
2649             if (offset < *saved_offset) {
2650                 *saved_offset = offset;
2651                 *register_pair = index;
2652             }
2653         }
2654     }
2655 }
2656
2657 static void
2658 scavenge_interrupt_context(os_context_t * context)
2659 {
2660     int i;
2661
2662     /* FIXME: The various #ifdef noise here is precisely that: noise.
2663      * Is it possible to fold it into the macrology so that we have
2664      * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2665      * compile out for the registers that don't exist on a given
2666      * platform? */
2667
2668     INTERIOR_POINTER_VARS(pc);
2669 #ifdef reg_LIP
2670     INTERIOR_POINTER_VARS(lip);
2671 #endif
2672 #ifdef ARCH_HAS_LINK_REGISTER
2673     INTERIOR_POINTER_VARS(lr);
2674 #endif
2675 #ifdef ARCH_HAS_NPC_REGISTER
2676     INTERIOR_POINTER_VARS(npc);
2677 #endif
2678 #ifdef LISP_FEATURE_PPC
2679     INTERIOR_POINTER_VARS(ctr);
2680 #endif
2681
2682     PAIR_INTERIOR_POINTER(pc);
2683 #ifdef reg_LIP
2684     PAIR_INTERIOR_POINTER(lip);
2685 #endif
2686 #ifdef ARCH_HAS_LINK_REGISTER
2687     PAIR_INTERIOR_POINTER(lr);
2688 #endif
2689 #ifdef ARCH_HAS_NPC_REGISTER
2690     PAIR_INTERIOR_POINTER(npc);
2691 #endif
2692 #ifdef LISP_FEATURE_PPC
2693     PAIR_INTERIOR_POINTER(ctr);
2694 #endif
2695
2696     /* Scavenge all boxed registers in the context. */
2697     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2698         int index;
2699         lispobj foo;
2700
2701         index = boxed_registers[i];
2702         foo = *os_context_register_addr(context, index);
2703         scavenge(&foo, 1);
2704         *os_context_register_addr(context, index) = foo;
2705
2706         /* this is unlikely to work as intended on bigendian
2707          * 64 bit platforms */
2708
2709         scavenge((lispobj *) os_context_register_addr(context, index), 1);
2710     }
2711
2712     /* Now that the scavenging is done, repair the various interior
2713      * pointers. */
2714     FIXUP_INTERIOR_POINTER(pc);
2715 #ifdef reg_LIP
2716     FIXUP_INTERIOR_POINTER(lip);
2717 #endif
2718 #ifdef ARCH_HAS_LINK_REGISTER
2719     FIXUP_INTERIOR_POINTER(lr);
2720 #endif
2721 #ifdef ARCH_HAS_NPC_REGISTER
2722     FIXUP_INTERIOR_POINTER(npc);
2723 #endif
2724 #ifdef LISP_FEATURE_PPC
2725     FIXUP_INTERIOR_POINTER(ctr);
2726 #endif
2727 }
2728
2729 void
2730 scavenge_interrupt_contexts(struct thread *th)
2731 {
2732     int i, index;
2733     os_context_t *context;
2734
2735     index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
2736
2737 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2738     printf("Number of active contexts: %d\n", index);
2739 #endif
2740
2741     for (i = 0; i < index; i++) {
2742         context = th->interrupt_contexts[i];
2743         scavenge_interrupt_context(context);
2744     }
2745 }
2746 #endif /* x86oid targets */