src/runtime/gc-common.c

   1 /*
   2  * Garbage Collection common functions for scavenging, moving and sizing
   3  * objects.  These are for use with both GC (stop & copy GC) and GENCGC
   4  */
   5
   6 /*
   7  * This software is part of the SBCL system. See the README file for
   8  * more information.
   9  *
  10  * This software is derived from the CMU CL system, which was
  11  * written at Carnegie Mellon University and released into the
  12  * public domain. The software is in the public domain and is
  13  * provided with absolutely no warranty. See the COPYING and CREDITS
  14  * files for more information.
  15  */
  16
  17 /*
  18  * For a review of garbage collection techniques (e.g. generational
  19  * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
  20  * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
  21  * had been accepted for _ACM Computing Surveys_ and was available
  22  * as a PostScript preprint through
  23  *   <http://www.cs.utexas.edu/users/oops/papers.html>
  24  * as
  25  *   <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
  26  */
  27
  28 #include <stdio.h>
  29 #include <signal.h>
  30 #include <string.h>
  31 #include "sbcl.h"
  32 #include "runtime.h"
  33 #include "os.h"
  34 #include "interr.h"
  35 #include "globals.h"
  36 #include "interrupt.h"
  37 #include "validate.h"
  38 #include "lispregs.h"
  39 #include "arch.h"
  40 #include "fixnump.h"
  41 #include "gc.h"
  42 #include "genesis/primitive-objects.h"
  43 #include "genesis/static-symbols.h"
  44 #include "gc-internal.h"
  45
  46 #ifdef LISP_FEATURE_SPARC
  47 #define LONG_FLOAT_SIZE 4
  48 #else
  49 #ifdef LISP_FEATURE_X86
  50 #define LONG_FLOAT_SIZE 3
  51 #endif
  52 #endif
  53
  54 inline static boolean
  55 forwarding_pointer_p(lispobj *pointer) {
  56     lispobj first_word=*pointer;
  57 #ifdef LISP_FEATURE_GENCGC
  58     return (first_word == 0x01);
  59 #else
  60     return (is_lisp_pointer(first_word)
  61             && new_space_p(first_word));
  62 #endif
  63 }
  64
  65 static inline lispobj *
  66 forwarding_pointer_value(lispobj *pointer) {
  67 #ifdef LISP_FEATURE_GENCGC
  68     return (lispobj *) ((pointer_sized_uint_t) pointer[1]);
  69 #else
  70     return (lispobj *) ((pointer_sized_uint_t) pointer[0]);
  71 #endif
  72 }
  73 static inline lispobj
  74 set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) {
  75 #ifdef LISP_FEATURE_GENCGC
  76     pointer[0]=0x01;
  77     pointer[1]=newspace_copy;
  78 #else
  79     pointer[0]=newspace_copy;
  80 #endif
  81     return newspace_copy;
  82 }
  83
  84 long (*scavtab[256])(lispobj *where, lispobj object);
  85 lispobj (*transother[256])(lispobj object);
  86 long (*sizetab[256])(lispobj *where);
  87 struct weak_pointer *weak_pointers;
  88
  89 unsigned long bytes_consed_between_gcs = 12*1024*1024;
  90
  91
  92 /*
  93  * copying objects
  94  */
  95
  96 /* to copy a boxed object */
  97 lispobj
  98 copy_object(lispobj object, long nwords)
  99 {
 100     int tag;
 101     lispobj *new;
 102
 103     gc_assert(is_lisp_pointer(object));
 104     gc_assert(from_space_p(object));
 105     gc_assert((nwords & 0x01) == 0);
 106
 107     /* Get tag of object. */
 108     tag = lowtag_of(object);
 109
 110     /* Allocate space. */
 111     new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK);
 112
 113     /* Copy the object. */
 114     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
 115     return make_lispobj(new,tag);
 116 }
 117
 118 static long scav_lose(lispobj *where, lispobj object); /* forward decl */
 119
 120 /* FIXME: Most calls end up going to some trouble to compute an
 121  * 'n_words' value for this function. The system might be a little
 122  * simpler if this function used an 'end' parameter instead. */
 123 void
 124 scavenge(lispobj *start, long n_words)
 125 {
 126     lispobj *end = start + n_words;
 127     lispobj *object_ptr;
 128     long n_words_scavenged;
 129     for (object_ptr = start;
 130
 131          object_ptr < end;
 132          object_ptr += n_words_scavenged) {
 133
 134         lispobj object = *object_ptr;
 135 #ifdef LISP_FEATURE_GENCGC
 136         gc_assert(!forwarding_pointer_p(object_ptr));
 137 #endif
 138         if (is_lisp_pointer(object)) {
 139             if (from_space_p(object)) {
 140                 /* It currently points to old space. Check for a
 141                  * forwarding pointer. */
 142                 lispobj *ptr = native_pointer(object);
 143                 if (forwarding_pointer_p(ptr)) {
 144                     /* Yes, there's a forwarding pointer. */
 145                     *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
 146                     n_words_scavenged = 1;
 147                 } else {
 148                     /* Scavenge that pointer. */
 149                     n_words_scavenged =
 150                         (scavtab[widetag_of(object)])(object_ptr, object);
 151                 }
 152             } else {
 153                 /* It points somewhere other than oldspace. Leave it
 154                  * alone. */
 155                 n_words_scavenged = 1;
 156             }
 157         }
 158 #ifndef LISP_FEATURE_GENCGC
 159         /* this workaround is probably not necessary for gencgc; at least, the
 160          * behaviour it describes has never been reported */
 161         else if (n_words==1) {
 162             /* there are some situations where an
 163                other-immediate may end up in a descriptor
 164                register.  I'm not sure whether this is
 165                supposed to happen, but if it does then we
 166                don't want to (a) barf or (b) scavenge over the
 167                data-block, because there isn't one.  So, if
 168                we're checking a single word and it's anything
 169                other than a pointer, just hush it up */
 170             int type=widetag_of(object);
 171             n_words_scavenged=1;
 172
 173             if ((scavtab[type]==scav_lose) ||
 174                 (((scavtab[type])(start,object))>1)) {
 175                 fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p.  If you can\nreproduce this warning, send a bug report (see manual page for details)\n",
 176                         object,start);
 177             }
 178         }
 179 #endif
 180         else if (fixnump(object)) {
 181             /* It's a fixnum: really easy.. */
 182             n_words_scavenged = 1;
 183         } else {
 184             /* It's some sort of header object or another. */
 185             n_words_scavenged =
 186                 (scavtab[widetag_of(object)])(object_ptr, object);
 187         }
 188     }
 189     gc_assert(object_ptr == end);
 190 }
 191
 192 static lispobj trans_fun_header(lispobj object); /* forward decls */
 193 static lispobj trans_boxed(lispobj object);
 194
 195 static long
 196 scav_fun_pointer(lispobj *where, lispobj object)
 197 {
 198     lispobj *first_pointer;
 199     lispobj copy;
 200
 201     gc_assert(is_lisp_pointer(object));
 202
 203     /* Object is a pointer into from_space - not a FP. */
 204     first_pointer = (lispobj *) native_pointer(object);
 205
 206     /* must transport object -- object may point to either a function
 207      * header, a closure function header, or to a closure header. */
 208
 209     switch (widetag_of(*first_pointer)) {
 210     case SIMPLE_FUN_HEADER_WIDETAG:
 211         copy = trans_fun_header(object);
 212         break;
 213     default:
 214         copy = trans_boxed(object);
 215         break;
 216     }
 217
 218     if (copy != object) {
 219         /* Set forwarding pointer */
 220         set_forwarding_pointer(first_pointer,copy);
 221     }
 222
 223     gc_assert(is_lisp_pointer(copy));
 224     gc_assert(!from_space_p(copy));
 225
 226     *where = copy;
 227
 228     return 1;
 229 }
 230
 231
 232 static struct code *
 233 trans_code(struct code *code)
 234 {
 235     struct code *new_code;
 236     lispobj first, l_code, l_new_code;
 237     long nheader_words, ncode_words, nwords;
 238     unsigned long displacement;
 239     lispobj fheaderl, *prev_pointer;
 240
 241     /* if object has already been transported, just return pointer */
 242     first = code->header;
 243     if (forwarding_pointer_p((lispobj *)code)) {
 244 #ifdef DEBUG_CODE_GC
 245         printf("Was already transported\n");
 246 #endif
 247         return (struct code *) forwarding_pointer_value
 248             ((lispobj *)((pointer_sized_uint_t) code));
 249     }
 250
 251     gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
 252
 253     /* prepare to transport the code vector */
 254     l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
 255
 256     ncode_words = fixnum_value(code->code_size);
 257     nheader_words = HeaderValue(code->header);
 258     nwords = ncode_words + nheader_words;
 259     nwords = CEILING(nwords, 2);
 260
 261     l_new_code = copy_object(l_code, nwords);
 262     new_code = (struct code *) native_pointer(l_new_code);
 263
 264 #if defined(DEBUG_CODE_GC)
 265     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 266            (unsigned long) code, (unsigned long) new_code);
 267     printf("Code object is %d words long.\n", nwords);
 268 #endif
 269
 270 #ifdef LISP_FEATURE_GENCGC
 271     if (new_code == code)
 272         return new_code;
 273 #endif
 274
 275     displacement = l_new_code - l_code;
 276
 277     set_forwarding_pointer((lispobj *)code, l_new_code);
 278
 279     /* set forwarding pointers for all the function headers in the */
 280     /* code object.  also fix all self pointers */
 281
 282     fheaderl = code->entry_points;
 283     prev_pointer = &new_code->entry_points;
 284
 285     while (fheaderl != NIL) {
 286         struct simple_fun *fheaderp, *nfheaderp;
 287         lispobj nfheaderl;
 288
 289         fheaderp = (struct simple_fun *) native_pointer(fheaderl);
 290         gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
 291
 292         /* Calculate the new function pointer and the new */
 293         /* function header. */
 294         nfheaderl = fheaderl + displacement;
 295         nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
 296
 297 #ifdef DEBUG_CODE_GC
 298         printf("fheaderp->header (at %x) <- %x\n",
 299                &(fheaderp->header) , nfheaderl);
 300 #endif
 301         set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
 302
 303         /* fix self pointer. */
 304         nfheaderp->self =
 305 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 306             FUN_RAW_ADDR_OFFSET +
 307 #endif
 308             nfheaderl;
 309
 310         *prev_pointer = nfheaderl;
 311
 312         fheaderl = fheaderp->next;
 313         prev_pointer = &nfheaderp->next;
 314     }
 315     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
 316                     ncode_words * sizeof(long));
 317 #ifdef LISP_FEATURE_GENCGC
 318     gencgc_apply_code_fixups(code, new_code);
 319 #endif
 320     return new_code;
 321 }
 322
 323 static long
 324 scav_code_header(lispobj *where, lispobj object)
 325 {
 326     struct code *code;
 327     long n_header_words, n_code_words, n_words;
 328     lispobj entry_point;        /* tagged pointer to entry point */
 329     struct simple_fun *function_ptr; /* untagged pointer to entry point */
 330
 331     code = (struct code *) where;
 332     n_code_words = fixnum_value(code->code_size);
 333     n_header_words = HeaderValue(object);
 334     n_words = n_code_words + n_header_words;
 335     n_words = CEILING(n_words, 2);
 336
 337     /* Scavenge the boxed section of the code data block. */
 338     scavenge(where + 1, n_header_words - 1);
 339
 340     /* Scavenge the boxed section of each function object in the
 341      * code data block. */
 342     for (entry_point = code->entry_points;
 343          entry_point != NIL;
 344          entry_point = function_ptr->next) {
 345
 346         gc_assert(is_lisp_pointer(entry_point));
 347
 348         function_ptr = (struct simple_fun *) native_pointer(entry_point);
 349         gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
 350
 351         scavenge(&function_ptr->name, 1);
 352         scavenge(&function_ptr->arglist, 1);
 353         scavenge(&function_ptr->type, 1);
 354     }
 355
 356     return n_words;
 357 }
 358
 359 static lispobj
 360 trans_code_header(lispobj object)
 361 {
 362     struct code *ncode;
 363
 364     ncode = trans_code((struct code *) native_pointer(object));
 365     return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
 366 }
 367
 368
 369 static long
 370 size_code_header(lispobj *where)
 371 {
 372     struct code *code;
 373     long nheader_words, ncode_words, nwords;
 374
 375     code = (struct code *) where;
 376
 377     ncode_words = fixnum_value(code->code_size);
 378     nheader_words = HeaderValue(code->header);
 379     nwords = ncode_words + nheader_words;
 380     nwords = CEILING(nwords, 2);
 381
 382     return nwords;
 383 }
 384
 385 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
 386 static long
 387 scav_return_pc_header(lispobj *where, lispobj object)
 388 {
 389     lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x",
 390          (unsigned long) where,
 391          (unsigned long) object);
 392     return 0; /* bogus return value to satisfy static type checking */
 393 }
 394 #endif /* LISP_FEATURE_X86 */
 395
 396 static lispobj
 397 trans_return_pc_header(lispobj object)
 398 {
 399     struct simple_fun *return_pc;
 400     unsigned long offset;
 401     struct code *code, *ncode;
 402
 403     return_pc = (struct simple_fun *) native_pointer(object);
 404     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 405     offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
 406
 407     /* Transport the whole code object */
 408     code = (struct code *) ((unsigned long) return_pc - offset);
 409     ncode = trans_code(code);
 410
 411     return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
 412 }
 413
 414 /* On the 386, closures hold a pointer to the raw address instead of the
 415  * function object, so we can use CALL [$FDEFN+const] to invoke
 416  * the function without loading it into a register. Given that code
 417  * objects don't move, we don't need to update anything, but we do
 418  * have to figure out that the function is still live. */
 419
 420 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 421 static long
 422 scav_closure_header(lispobj *where, lispobj object)
 423 {
 424     struct closure *closure;
 425     lispobj fun;
 426
 427     closure = (struct closure *)where;
 428     fun = closure->fun - FUN_RAW_ADDR_OFFSET;
 429     scavenge(&fun, 1);
 430 #ifdef LISP_FEATURE_GENCGC
 431     /* The function may have moved so update the raw address. But
 432      * don't write unnecessarily. */
 433     if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
 434         closure->fun = fun + FUN_RAW_ADDR_OFFSET;
 435 #endif
 436     return 2;
 437 }
 438 #endif
 439
 440 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 441 static long
 442 scav_fun_header(lispobj *where, lispobj object)
 443 {
 444     lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
 445          (unsigned long) where,
 446          (unsigned long) object);
 447     return 0; /* bogus return value to satisfy static type checking */
 448 }
 449 #endif /* LISP_FEATURE_X86 */
 450
 451 static lispobj
 452 trans_fun_header(lispobj object)
 453 {
 454     struct simple_fun *fheader;
 455     unsigned long offset;
 456     struct code *code, *ncode;
 457
 458     fheader = (struct simple_fun *) native_pointer(object);
 459     /* FIXME: was times 4, should it really be N_WORD_BYTES? */
 460     offset = HeaderValue(fheader->header) * N_WORD_BYTES;
 461
 462     /* Transport the whole code object */
 463     code = (struct code *) ((unsigned long) fheader - offset);
 464     ncode = trans_code(code);
 465
 466     return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
 467 }
 468
 469 \f
 470 /*
 471  * instances
 472  */
 473
 474 static long
 475 scav_instance_pointer(lispobj *where, lispobj object)
 476 {
 477     lispobj copy, *first_pointer;
 478
 479     /* Object is a pointer into from space - not a FP. */
 480     copy = trans_boxed(object);
 481
 482 #ifdef LISP_FEATURE_GENCGC
 483     gc_assert(copy != object);
 484 #endif
 485
 486     first_pointer = (lispobj *) native_pointer(object);
 487     set_forwarding_pointer(first_pointer,copy);
 488     *where = copy;
 489
 490     return 1;
 491 }
 492
 493 \f
 494 /*
 495  * lists and conses
 496  */
 497
 498 static lispobj trans_list(lispobj object);
 499
 500 static long
 501 scav_list_pointer(lispobj *where, lispobj object)
 502 {
 503     lispobj first, *first_pointer;
 504
 505     gc_assert(is_lisp_pointer(object));
 506
 507     /* Object is a pointer into from space - not FP. */
 508     first_pointer = (lispobj *) native_pointer(object);
 509
 510     first = trans_list(object);
 511     gc_assert(first != object);
 512
 513     /* Set forwarding pointer */
 514     set_forwarding_pointer(first_pointer, first);
 515
 516     gc_assert(is_lisp_pointer(first));
 517     gc_assert(!from_space_p(first));
 518
 519     *where = first;
 520     return 1;
 521 }
 522
 523
 524 static lispobj
 525 trans_list(lispobj object)
 526 {
 527     lispobj new_list_pointer;
 528     struct cons *cons, *new_cons;
 529     lispobj cdr;
 530
 531     cons = (struct cons *) native_pointer(object);
 532
 533     /* Copy 'object'. */
 534     new_cons = (struct cons *)
 535         gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 536     new_cons->car = cons->car;
 537     new_cons->cdr = cons->cdr; /* updated later */
 538     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
 539
 540     /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC  */
 541     cdr = cons->cdr;
 542
 543     set_forwarding_pointer((lispobj *)cons, new_list_pointer);
 544
 545     /* Try to linearize the list in the cdr direction to help reduce
 546      * paging. */
 547     while (1) {
 548         lispobj  new_cdr;
 549         struct cons *cdr_cons, *new_cdr_cons;
 550
 551         if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
 552            !from_space_p(cdr) ||
 553            forwarding_pointer_p((lispobj *)native_pointer(cdr)))
 554             break;
 555
 556         cdr_cons = (struct cons *) native_pointer(cdr);
 557
 558         /* Copy 'cdr'. */
 559         new_cdr_cons = (struct cons*)
 560             gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
 561         new_cdr_cons->car = cdr_cons->car;
 562         new_cdr_cons->cdr = cdr_cons->cdr;
 563         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
 564
 565         /* Grab the cdr before it is clobbered. */
 566         cdr = cdr_cons->cdr;
 567         set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
 568
 569         /* Update the cdr of the last cons copied into new space to
 570          * keep the newspace scavenge from having to do it. */
 571         new_cons->cdr = new_cdr;
 572
 573         new_cons = new_cdr_cons;
 574     }
 575
 576     return new_list_pointer;
 577 }
 578
 579 \f
 580 /*
 581  * scavenging and transporting other pointers
 582  */
 583
 584 static long
 585 scav_other_pointer(lispobj *where, lispobj object)
 586 {
 587     lispobj first, *first_pointer;
 588
 589     gc_assert(is_lisp_pointer(object));
 590
 591     /* Object is a pointer into from space - not FP. */
 592     first_pointer = (lispobj *) native_pointer(object);
 593     first = (transother[widetag_of(*first_pointer)])(object);
 594
 595     if (first != object) {
 596         set_forwarding_pointer(first_pointer, first);
 597 #ifdef LISP_FEATURE_GENCGC
 598         *where = first;
 599 #endif
 600     }
 601 #ifndef LISP_FEATURE_GENCGC
 602     *where = first;
 603 #endif
 604     gc_assert(is_lisp_pointer(first));
 605     gc_assert(!from_space_p(first));
 606
 607     return 1;
 608 }
 609 \f
 610 /*
 611  * immediate, boxed, and unboxed objects
 612  */
 613
 614 static long
 615 size_pointer(lispobj *where)
 616 {
 617     return 1;
 618 }
 619
 620 static long
 621 scav_immediate(lispobj *where, lispobj object)
 622 {
 623     return 1;
 624 }
 625
 626 static lispobj
 627 trans_immediate(lispobj object)
 628 {
 629     lose("trying to transport an immediate");
 630     return NIL; /* bogus return value to satisfy static type checking */
 631 }
 632
 633 static long
 634 size_immediate(lispobj *where)
 635 {
 636     return 1;
 637 }
 638
 639
 640 static long
 641 scav_boxed(lispobj *where, lispobj object)
 642 {
 643     return 1;
 644 }
 645
 646 static lispobj
 647 trans_boxed(lispobj object)
 648 {
 649     lispobj header;
 650     unsigned long length;
 651
 652     gc_assert(is_lisp_pointer(object));
 653
 654     header = *((lispobj *) native_pointer(object));
 655     length = HeaderValue(header) + 1;
 656     length = CEILING(length, 2);
 657
 658     return copy_object(object, length);
 659 }
 660
 661
 662 static long
 663 size_boxed(lispobj *where)
 664 {
 665     lispobj header;
 666     unsigned long length;
 667
 668     header = *where;
 669     length = HeaderValue(header) + 1;
 670     length = CEILING(length, 2);
 671
 672     return length;
 673 }
 674
 675 /* Note: on the sparc we don't have to do anything special for fdefns, */
 676 /* 'cause the raw-addr has a function lowtag. */
 677 #ifndef LISP_FEATURE_SPARC
 678 static long
 679 scav_fdefn(lispobj *where, lispobj object)
 680 {
 681     struct fdefn *fdefn;
 682
 683     fdefn = (struct fdefn *)where;
 684
 685     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
 686        fdefn->fun, fdefn->raw_addr)); */
 687
 688     if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
 689         == (char *)((unsigned long)(fdefn->raw_addr))) {
 690         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 691
 692         /* Don't write unnecessarily. */
 693         if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
 694             fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
 695         /* gc.c has more casts here, which may be relevant or alternatively
 696            may be compiler warning defeaters.  try
 697         fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
 698         */
 699         return sizeof(struct fdefn) / sizeof(lispobj);
 700     } else {
 701         return 1;
 702     }
 703 }
 704 #endif
 705
 706 static long
 707 scav_unboxed(lispobj *where, lispobj object)
 708 {
 709     unsigned long length;
 710
 711     length = HeaderValue(object) + 1;
 712     length = CEILING(length, 2);
 713
 714     return length;
 715 }
 716
 717 static lispobj
 718 trans_unboxed(lispobj object)
 719 {
 720     lispobj header;
 721     unsigned long length;
 722
 723
 724     gc_assert(is_lisp_pointer(object));
 725
 726     header = *((lispobj *) native_pointer(object));
 727     length = HeaderValue(header) + 1;
 728     length = CEILING(length, 2);
 729
 730     return copy_unboxed_object(object, length);
 731 }
 732
 733 static long
 734 size_unboxed(lispobj *where)
 735 {
 736     lispobj header;
 737     unsigned long length;
 738
 739     header = *where;
 740     length = HeaderValue(header) + 1;
 741     length = CEILING(length, 2);
 742
 743     return length;
 744 }
 745
 746 \f
 747 /* vector-like objects */
 748 static long
 749 scav_base_string(lispobj *where, lispobj object)
 750 {
 751     struct vector *vector;
 752     long length, nwords;
 753
 754     /* NOTE: Strings contain one more byte of data than the length */
 755     /* slot indicates. */
 756
 757     vector = (struct vector *) where;
 758     length = fixnum_value(vector->length) + 1;
 759     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 760
 761     return nwords;
 762 }
 763 static lispobj
 764 trans_base_string(lispobj object)
 765 {
 766     struct vector *vector;
 767     long length, nwords;
 768
 769     gc_assert(is_lisp_pointer(object));
 770
 771     /* NOTE: A string contains one more byte of data (a terminating
 772      * '\0' to help when interfacing with C functions) than indicated
 773      * by the length slot. */
 774
 775     vector = (struct vector *) native_pointer(object);
 776     length = fixnum_value(vector->length) + 1;
 777     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 778
 779     return copy_large_unboxed_object(object, nwords);
 780 }
 781
 782 static long
 783 size_base_string(lispobj *where)
 784 {
 785     struct vector *vector;
 786     long length, nwords;
 787
 788     /* NOTE: A string contains one more byte of data (a terminating
 789      * '\0' to help when interfacing with C functions) than indicated
 790      * by the length slot. */
 791
 792     vector = (struct vector *) where;
 793     length = fixnum_value(vector->length) + 1;
 794     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 795
 796     return nwords;
 797 }
 798
 799 static long
 800 scav_character_string(lispobj *where, lispobj object)
 801 {
 802     struct vector *vector;
 803     int length, nwords;
 804
 805     /* NOTE: Strings contain one more byte of data than the length */
 806     /* slot indicates. */
 807
 808     vector = (struct vector *) where;
 809     length = fixnum_value(vector->length) + 1;
 810     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 811
 812     return nwords;
 813 }
 814 static lispobj
 815 trans_character_string(lispobj object)
 816 {
 817     struct vector *vector;
 818     int length, nwords;
 819
 820     gc_assert(is_lisp_pointer(object));
 821
 822     /* NOTE: A string contains one more byte of data (a terminating
 823      * '\0' to help when interfacing with C functions) than indicated
 824      * by the length slot. */
 825
 826     vector = (struct vector *) native_pointer(object);
 827     length = fixnum_value(vector->length) + 1;
 828     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 829
 830     return copy_large_unboxed_object(object, nwords);
 831 }
 832
 833 static long
 834 size_character_string(lispobj *where)
 835 {
 836     struct vector *vector;
 837     int length, nwords;
 838
 839     /* NOTE: A string contains one more byte of data (a terminating
 840      * '\0' to help when interfacing with C functions) than indicated
 841      * by the length slot. */
 842
 843     vector = (struct vector *) where;
 844     length = fixnum_value(vector->length) + 1;
 845     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 846
 847     return nwords;
 848 }
 849
 850 static lispobj
 851 trans_vector(lispobj object)
 852 {
 853     struct vector *vector;
 854     long length, nwords;
 855
 856     gc_assert(is_lisp_pointer(object));
 857
 858     vector = (struct vector *) native_pointer(object);
 859
 860     length = fixnum_value(vector->length);
 861     nwords = CEILING(length + 2, 2);
 862
 863     return copy_large_object(object, nwords);
 864 }
 865
 866 static long
 867 size_vector(lispobj *where)
 868 {
 869     struct vector *vector;
 870     long length, nwords;
 871
 872     vector = (struct vector *) where;
 873     length = fixnum_value(vector->length);
 874     nwords = CEILING(length + 2, 2);
 875
 876     return nwords;
 877 }
 878
 879 static long
 880 scav_vector_nil(lispobj *where, lispobj object)
 881 {
 882     return 2;
 883 }
 884
 885 static lispobj
 886 trans_vector_nil(lispobj object)
 887 {
 888     gc_assert(is_lisp_pointer(object));
 889     return copy_unboxed_object(object, 2);
 890 }
 891
 892 static long
 893 size_vector_nil(lispobj *where)
 894 {
 895     /* Just the header word and the length word */
 896     return 2;
 897 }
 898
 899 static long
 900 scav_vector_bit(lispobj *where, lispobj object)
 901 {
 902     struct vector *vector;
 903     long length, nwords;
 904
 905     vector = (struct vector *) where;
 906     length = fixnum_value(vector->length);
 907     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 908
 909     return nwords;
 910 }
 911
 912 static lispobj
 913 trans_vector_bit(lispobj object)
 914 {
 915     struct vector *vector;
 916     long length, nwords;
 917
 918     gc_assert(is_lisp_pointer(object));
 919
 920     vector = (struct vector *) native_pointer(object);
 921     length = fixnum_value(vector->length);
 922     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 923
 924     return copy_large_unboxed_object(object, nwords);
 925 }
 926
 927 static long
 928 size_vector_bit(lispobj *where)
 929 {
 930     struct vector *vector;
 931     long length, nwords;
 932
 933     vector = (struct vector *) where;
 934     length = fixnum_value(vector->length);
 935     nwords = CEILING(NWORDS(length, 1) + 2, 2);
 936
 937     return nwords;
 938 }
 939
 940 static long
 941 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 942 {
 943     struct vector *vector;
 944     long length, nwords;
 945
 946     vector = (struct vector *) where;
 947     length = fixnum_value(vector->length);
 948     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 949
 950     return nwords;
 951 }
 952
 953 static lispobj
 954 trans_vector_unsigned_byte_2(lispobj object)
 955 {
 956     struct vector *vector;
 957     long length, nwords;
 958
 959     gc_assert(is_lisp_pointer(object));
 960
 961     vector = (struct vector *) native_pointer(object);
 962     length = fixnum_value(vector->length);
 963     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 964
 965     return copy_large_unboxed_object(object, nwords);
 966 }
 967
 968 static long
 969 size_vector_unsigned_byte_2(lispobj *where)
 970 {
 971     struct vector *vector;
 972     long length, nwords;
 973
 974     vector = (struct vector *) where;
 975     length = fixnum_value(vector->length);
 976     nwords = CEILING(NWORDS(length, 2) + 2, 2);
 977
 978     return nwords;
 979 }
 980
 981 static long
 982 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
 983 {
 984     struct vector *vector;
 985     long length, nwords;
 986
 987     vector = (struct vector *) where;
 988     length = fixnum_value(vector->length);
 989     nwords = CEILING(NWORDS(length, 4) + 2, 2);
 990
 991     return nwords;
 992 }
 993
 994 static lispobj
 995 trans_vector_unsigned_byte_4(lispobj object)
 996 {
 997     struct vector *vector;
 998     long length, nwords;
 999
1000     gc_assert(is_lisp_pointer(object));
1001
1002     vector = (struct vector *) native_pointer(object);
1003     length = fixnum_value(vector->length);
1004     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1005
1006     return copy_large_unboxed_object(object, nwords);
1007 }
1008 static long
1009 size_vector_unsigned_byte_4(lispobj *where)
1010 {
1011     struct vector *vector;
1012     long length, nwords;
1013
1014     vector = (struct vector *) where;
1015     length = fixnum_value(vector->length);
1016     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1017
1018     return nwords;
1019 }
1020
1021
1022 static long
1023 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1024 {
1025     struct vector *vector;
1026     long length, nwords;
1027
1028     vector = (struct vector *) where;
1029     length = fixnum_value(vector->length);
1030     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1031
1032     return nwords;
1033 }
1034
1035 /*********************/
1036
1037
1038
1039 static lispobj
1040 trans_vector_unsigned_byte_8(lispobj object)
1041 {
1042     struct vector *vector;
1043     long length, nwords;
1044
1045     gc_assert(is_lisp_pointer(object));
1046
1047     vector = (struct vector *) native_pointer(object);
1048     length = fixnum_value(vector->length);
1049     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1050
1051     return copy_large_unboxed_object(object, nwords);
1052 }
1053
1054 static long
1055 size_vector_unsigned_byte_8(lispobj *where)
1056 {
1057     struct vector *vector;
1058     long length, nwords;
1059
1060     vector = (struct vector *) where;
1061     length = fixnum_value(vector->length);
1062     nwords = CEILING(NWORDS(length, 8) + 2, 2);
1063
1064     return nwords;
1065 }
1066
1067
1068 static long
1069 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1070 {
1071     struct vector *vector;
1072     long length, nwords;
1073
1074     vector = (struct vector *) where;
1075     length = fixnum_value(vector->length);
1076     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1077
1078     return nwords;
1079 }
1080
1081 static lispobj
1082 trans_vector_unsigned_byte_16(lispobj object)
1083 {
1084     struct vector *vector;
1085     long length, nwords;
1086
1087     gc_assert(is_lisp_pointer(object));
1088
1089     vector = (struct vector *) native_pointer(object);
1090     length = fixnum_value(vector->length);
1091     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1092
1093     return copy_large_unboxed_object(object, nwords);
1094 }
1095
1096 static long
1097 size_vector_unsigned_byte_16(lispobj *where)
1098 {
1099     struct vector *vector;
1100     long length, nwords;
1101
1102     vector = (struct vector *) where;
1103     length = fixnum_value(vector->length);
1104     nwords = CEILING(NWORDS(length, 16) + 2, 2);
1105
1106     return nwords;
1107 }
1108
1109 static long
1110 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1111 {
1112     struct vector *vector;
1113     long length, nwords;
1114
1115     vector = (struct vector *) where;
1116     length = fixnum_value(vector->length);
1117     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1118
1119     return nwords;
1120 }
1121
1122 static lispobj
1123 trans_vector_unsigned_byte_32(lispobj object)
1124 {
1125     struct vector *vector;
1126     long length, nwords;
1127
1128     gc_assert(is_lisp_pointer(object));
1129
1130     vector = (struct vector *) native_pointer(object);
1131     length = fixnum_value(vector->length);
1132     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1133
1134     return copy_large_unboxed_object(object, nwords);
1135 }
1136
1137 static long
1138 size_vector_unsigned_byte_32(lispobj *where)
1139 {
1140     struct vector *vector;
1141     long length, nwords;
1142
1143     vector = (struct vector *) where;
1144     length = fixnum_value(vector->length);
1145     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1146
1147     return nwords;
1148 }
1149
1150 #if N_WORD_BITS == 64
1151 static long
1152 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1153 {
1154     struct vector *vector;
1155     long length, nwords;
1156
1157     vector = (struct vector *) where;
1158     length = fixnum_value(vector->length);
1159     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1160
1161     return nwords;
1162 }
1163
1164 static lispobj
1165 trans_vector_unsigned_byte_64(lispobj object)
1166 {
1167     struct vector *vector;
1168     long length, nwords;
1169
1170     gc_assert(is_lisp_pointer(object));
1171
1172     vector = (struct vector *) native_pointer(object);
1173     length = fixnum_value(vector->length);
1174     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1175
1176     return copy_large_unboxed_object(object, nwords);
1177 }
1178
1179 static long
1180 size_vector_unsigned_byte_64(lispobj *where)
1181 {
1182     struct vector *vector;
1183     long length, nwords;
1184
1185     vector = (struct vector *) where;
1186     length = fixnum_value(vector->length);
1187     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1188
1189     return nwords;
1190 }
1191 #endif
1192
1193 static long
1194 scav_vector_single_float(lispobj *where, lispobj object)
1195 {
1196     struct vector *vector;
1197     long length, nwords;
1198
1199     vector = (struct vector *) where;
1200     length = fixnum_value(vector->length);
1201     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1202
1203     return nwords;
1204 }
1205
1206 static lispobj
1207 trans_vector_single_float(lispobj object)
1208 {
1209     struct vector *vector;
1210     long length, nwords;
1211
1212     gc_assert(is_lisp_pointer(object));
1213
1214     vector = (struct vector *) native_pointer(object);
1215     length = fixnum_value(vector->length);
1216     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1217
1218     return copy_large_unboxed_object(object, nwords);
1219 }
1220
1221 static long
1222 size_vector_single_float(lispobj *where)
1223 {
1224     struct vector *vector;
1225     long length, nwords;
1226
1227     vector = (struct vector *) where;
1228     length = fixnum_value(vector->length);
1229     nwords = CEILING(NWORDS(length, 32) + 2, 2);
1230
1231     return nwords;
1232 }
1233
1234 static long
1235 scav_vector_double_float(lispobj *where, lispobj object)
1236 {
1237     struct vector *vector;
1238     long length, nwords;
1239
1240     vector = (struct vector *) where;
1241     length = fixnum_value(vector->length);
1242     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1243
1244     return nwords;
1245 }
1246
1247 static lispobj
1248 trans_vector_double_float(lispobj object)
1249 {
1250     struct vector *vector;
1251     long length, nwords;
1252
1253     gc_assert(is_lisp_pointer(object));
1254
1255     vector = (struct vector *) native_pointer(object);
1256     length = fixnum_value(vector->length);
1257     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1258
1259     return copy_large_unboxed_object(object, nwords);
1260 }
1261
1262 static long
1263 size_vector_double_float(lispobj *where)
1264 {
1265     struct vector *vector;
1266     long length, nwords;
1267
1268     vector = (struct vector *) where;
1269     length = fixnum_value(vector->length);
1270     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1271
1272     return nwords;
1273 }
1274
1275 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1276 static long
1277 scav_vector_long_float(lispobj *where, lispobj object)
1278 {
1279     struct vector *vector;
1280     long length, nwords;
1281
1282     vector = (struct vector *) where;
1283     length = fixnum_value(vector->length);
1284     nwords = CEILING(length *
1285                      LONG_FLOAT_SIZE
1286                      + 2, 2);
1287     return nwords;
1288 }
1289
1290 static lispobj
1291 trans_vector_long_float(lispobj object)
1292 {
1293     struct vector *vector;
1294     long length, nwords;
1295
1296     gc_assert(is_lisp_pointer(object));
1297
1298     vector = (struct vector *) native_pointer(object);
1299     length = fixnum_value(vector->length);
1300     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1301
1302     return copy_large_unboxed_object(object, nwords);
1303 }
1304
1305 static long
1306 size_vector_long_float(lispobj *where)
1307 {
1308     struct vector *vector;
1309     long length, nwords;
1310
1311     vector = (struct vector *) where;
1312     length = fixnum_value(vector->length);
1313     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1314
1315     return nwords;
1316 }
1317 #endif
1318
1319
1320 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1321 static long
1322 scav_vector_complex_single_float(lispobj *where, lispobj object)
1323 {
1324     struct vector *vector;
1325     long length, nwords;
1326
1327     vector = (struct vector *) where;
1328     length = fixnum_value(vector->length);
1329     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1330
1331     return nwords;
1332 }
1333
1334 static lispobj
1335 trans_vector_complex_single_float(lispobj object)
1336 {
1337     struct vector *vector;
1338     long length, nwords;
1339
1340     gc_assert(is_lisp_pointer(object));
1341
1342     vector = (struct vector *) native_pointer(object);
1343     length = fixnum_value(vector->length);
1344     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1345
1346     return copy_large_unboxed_object(object, nwords);
1347 }
1348
1349 static long
1350 size_vector_complex_single_float(lispobj *where)
1351 {
1352     struct vector *vector;
1353     long length, nwords;
1354
1355     vector = (struct vector *) where;
1356     length = fixnum_value(vector->length);
1357     nwords = CEILING(NWORDS(length, 64) + 2, 2);
1358
1359     return nwords;
1360 }
1361 #endif
1362
1363 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1364 static long
1365 scav_vector_complex_double_float(lispobj *where, lispobj object)
1366 {
1367     struct vector *vector;
1368     long length, nwords;
1369
1370     vector = (struct vector *) where;
1371     length = fixnum_value(vector->length);
1372     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1373
1374     return nwords;
1375 }
1376
1377 static lispobj
1378 trans_vector_complex_double_float(lispobj object)
1379 {
1380     struct vector *vector;
1381     long length, nwords;
1382
1383     gc_assert(is_lisp_pointer(object));
1384
1385     vector = (struct vector *) native_pointer(object);
1386     length = fixnum_value(vector->length);
1387     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1388
1389     return copy_large_unboxed_object(object, nwords);
1390 }
1391
1392 static long
1393 size_vector_complex_double_float(lispobj *where)
1394 {
1395     struct vector *vector;
1396     long length, nwords;
1397
1398     vector = (struct vector *) where;
1399     length = fixnum_value(vector->length);
1400     nwords = CEILING(NWORDS(length, 128) + 2, 2);
1401
1402     return nwords;
1403 }
1404 #endif
1405
1406
1407 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1408 static long
1409 scav_vector_complex_long_float(lispobj *where, lispobj object)
1410 {
1411     struct vector *vector;
1412     long length, nwords;
1413
1414     vector = (struct vector *) where;
1415     length = fixnum_value(vector->length);
1416     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1417
1418     return nwords;
1419 }
1420
1421 static lispobj
1422 trans_vector_complex_long_float(lispobj object)
1423 {
1424     struct vector *vector;
1425     long length, nwords;
1426
1427     gc_assert(is_lisp_pointer(object));
1428
1429     vector = (struct vector *) native_pointer(object);
1430     length = fixnum_value(vector->length);
1431     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1432
1433     return copy_large_unboxed_object(object, nwords);
1434 }
1435
1436 static long
1437 size_vector_complex_long_float(lispobj *where)
1438 {
1439     struct vector *vector;
1440     long length, nwords;
1441
1442     vector = (struct vector *) where;
1443     length = fixnum_value(vector->length);
1444     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1445
1446     return nwords;
1447 }
1448 #endif
1449
1450 #define WEAK_POINTER_NWORDS \
1451         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1452
1453 static lispobj
1454 trans_weak_pointer(lispobj object)
1455 {
1456     lispobj copy;
1457 #ifndef LISP_FEATURE_GENCGC
1458     struct weak_pointer *wp;
1459 #endif
1460     gc_assert(is_lisp_pointer(object));
1461
1462 #if defined(DEBUG_WEAK)
1463     printf("Transporting weak pointer from 0x%08x\n", object);
1464 #endif
1465
1466     /* Need to remember where all the weak pointers are that have */
1467     /* been transported so they can be fixed up in a post-GC pass. */
1468
1469     copy = copy_object(object, WEAK_POINTER_NWORDS);
1470 #ifndef LISP_FEATURE_GENCGC
1471     wp = (struct weak_pointer *) native_pointer(copy);
1472
1473     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1474     /* Push the weak pointer onto the list of weak pointers. */
1475     wp->next = LOW_WORD(weak_pointers);
1476     weak_pointers = wp;
1477 #endif
1478     return copy;
1479 }
1480
1481 static long
1482 size_weak_pointer(lispobj *where)
1483 {
1484     return WEAK_POINTER_NWORDS;
1485 }
1486
1487
1488 void scan_weak_pointers(void)
1489 {
1490     struct weak_pointer *wp;
1491     for (wp = weak_pointers; wp != NULL;
1492          wp=(struct weak_pointer *)native_pointer(wp->next)) {
1493         lispobj value = wp->value;
1494         lispobj *first_pointer;
1495         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1496         if (!(is_lisp_pointer(value) && from_space_p(value)))
1497             continue;
1498
1499         /* Now, we need to check whether the object has been forwarded. If
1500          * it has been, the weak pointer is still good and needs to be
1501          * updated. Otherwise, the weak pointer needs to be nil'ed
1502          * out. */
1503
1504         first_pointer = (lispobj *)native_pointer(value);
1505
1506         if (forwarding_pointer_p(first_pointer)) {
1507             wp->value=
1508                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1509         } else {
1510             /* Break it. */
1511             wp->value = NIL;
1512             wp->broken = T;
1513         }
1514     }
1515 }
1516
1517
1518 \f
1519 /*
1520  * initialization
1521  */
1522
1523 static long
1524 scav_lose(lispobj *where, lispobj object)
1525 {
1526     lose("no scavenge function for object 0x%08x (widetag 0x%x)",
1527          (unsigned long)object,
1528          widetag_of(*(lispobj*)native_pointer(object)));
1529
1530     return 0; /* bogus return value to satisfy static type checking */
1531 }
1532
1533 static lispobj
1534 trans_lose(lispobj object)
1535 {
1536     lose("no transport function for object 0x%08x (widetag 0x%x)",
1537          (unsigned long)object,
1538          widetag_of(*(lispobj*)native_pointer(object)));
1539     return NIL; /* bogus return value to satisfy static type checking */
1540 }
1541
1542 static long
1543 size_lose(lispobj *where)
1544 {
1545     lose("no size function for object at 0x%08x (widetag 0x%x)",
1546          (unsigned long)where,
1547          widetag_of(LOW_WORD(where)));
1548     return 1; /* bogus return value to satisfy static type checking */
1549 }
1550
1551 \f
1552 /*
1553  * initialization
1554  */
1555
1556 void
1557 gc_init_tables(void)
1558 {
1559     long i;
1560
1561     /* Set default value in all slots of scavenge table.  FIXME
1562      * replace this gnarly sizeof with something based on
1563      * N_WIDETAG_BITS */
1564     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1565         scavtab[i] = scav_lose;
1566     }
1567
1568     /* For each type which can be selected by the lowtag alone, set
1569      * multiple entries in our widetag scavenge table (one for each
1570      * possible value of the high bits).
1571      */
1572
1573     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1574         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1575         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1576         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1577         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1578         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1579         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1580         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1581         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1582     }
1583
1584     /* Other-pointer types (those selected by all eight bits of the
1585      * tag) get one entry each in the scavenge table. */
1586     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1587     scavtab[RATIO_WIDETAG] = scav_boxed;
1588 #if N_WORD_BITS == 64
1589     scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1590 #else
1591     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1592 #endif
1593     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1594 #ifdef LONG_FLOAT_WIDETAG
1595     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1596 #endif
1597     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1598 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1599     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1600 #endif
1601 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1602     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1603 #endif
1604 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1605     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1606 #endif
1607     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1608     scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1609 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1610     scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1611 #endif
1612     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1613     scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1614     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1615         scav_vector_unsigned_byte_2;
1616     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1617         scav_vector_unsigned_byte_4;
1618     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1619         scav_vector_unsigned_byte_8;
1620     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1621         scav_vector_unsigned_byte_8;
1622     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1623         scav_vector_unsigned_byte_16;
1624     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1625         scav_vector_unsigned_byte_16;
1626 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1627     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1628         scav_vector_unsigned_byte_32;
1629 #endif
1630     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1631         scav_vector_unsigned_byte_32;
1632     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1633         scav_vector_unsigned_byte_32;
1634 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1635     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1636         scav_vector_unsigned_byte_64;
1637 #endif
1638 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1639     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1640         scav_vector_unsigned_byte_64;
1641 #endif
1642 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1643     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1644         scav_vector_unsigned_byte_64;
1645 #endif
1646 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1647     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1648 #endif
1649 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1650     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1651         scav_vector_unsigned_byte_16;
1652 #endif
1653 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1654     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1655         scav_vector_unsigned_byte_32;
1656 #endif
1657 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1658     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1659         scav_vector_unsigned_byte_32;
1660 #endif
1661 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1662     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1663         scav_vector_unsigned_byte_64;
1664 #endif
1665 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1666     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1667         scav_vector_unsigned_byte_64;
1668 #endif
1669     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
1670     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
1671 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1672     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
1673 #endif
1674 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1675     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1676         scav_vector_complex_single_float;
1677 #endif
1678 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1679     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1680         scav_vector_complex_double_float;
1681 #endif
1682 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1683     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1684         scav_vector_complex_long_float;
1685 #endif
1686     scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
1687 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1688     scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
1689 #endif
1690     scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
1691     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
1692     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
1693     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
1694     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
1695 #ifndef LISP_FEATURE_GENCGC     /* FIXME ..._X86 ? */
1696     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
1697     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
1698 #endif
1699 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1700     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
1701     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
1702 #else
1703     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
1704     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
1705 #endif
1706     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
1707     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
1708     scavtab[CHARACTER_WIDETAG] = scav_immediate;
1709     scavtab[SAP_WIDETAG] = scav_unboxed;
1710     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
1711     scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
1712 #ifdef LISP_FEATURE_SPARC
1713     scavtab[FDEFN_WIDETAG] = scav_boxed;
1714 #else
1715     scavtab[FDEFN_WIDETAG] = scav_fdefn;
1716 #endif
1717
1718     /* transport other table, initialized same way as scavtab */
1719     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
1720         transother[i] = trans_lose;
1721     transother[BIGNUM_WIDETAG] = trans_unboxed;
1722     transother[RATIO_WIDETAG] = trans_boxed;
1723
1724 #if N_WORD_BITS == 64
1725     transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
1726 #else
1727     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1728 #endif
1729     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1730 #ifdef LONG_FLOAT_WIDETAG
1731     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
1732 #endif
1733     transother[COMPLEX_WIDETAG] = trans_boxed;
1734 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1735     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1736 #endif
1737 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1738     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1739 #endif
1740 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1741     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
1742 #endif
1743     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
1744     transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
1745 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1746     transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
1747 #endif
1748     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
1749     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
1750     transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
1751     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1752         trans_vector_unsigned_byte_2;
1753     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1754         trans_vector_unsigned_byte_4;
1755     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1756         trans_vector_unsigned_byte_8;
1757     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1758         trans_vector_unsigned_byte_8;
1759     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1760         trans_vector_unsigned_byte_16;
1761     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1762         trans_vector_unsigned_byte_16;
1763 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1764     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1765         trans_vector_unsigned_byte_32;
1766 #endif
1767     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1768         trans_vector_unsigned_byte_32;
1769     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1770         trans_vector_unsigned_byte_32;
1771 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1772     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1773         trans_vector_unsigned_byte_64;
1774 #endif
1775 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1776     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1777         trans_vector_unsigned_byte_64;
1778 #endif
1779 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1780     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1781         trans_vector_unsigned_byte_64;
1782 #endif
1783 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1784     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1785         trans_vector_unsigned_byte_8;
1786 #endif
1787 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1788     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1789         trans_vector_unsigned_byte_16;
1790 #endif
1791 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1792     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1793         trans_vector_unsigned_byte_32;
1794 #endif
1795 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1796     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1797         trans_vector_unsigned_byte_32;
1798 #endif
1799 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1800     transother[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1801         trans_vector_unsigned_byte_64;
1802 #endif
1803 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1804     transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1805         trans_vector_unsigned_byte_64;
1806 #endif
1807     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
1808         trans_vector_single_float;
1809     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
1810         trans_vector_double_float;
1811 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1812     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
1813         trans_vector_long_float;
1814 #endif
1815 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1816     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1817         trans_vector_complex_single_float;
1818 #endif
1819 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1820     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1821         trans_vector_complex_double_float;
1822 #endif
1823 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1824     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1825         trans_vector_complex_long_float;
1826 #endif
1827     transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
1828 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1829     transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
1830 #endif
1831     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
1832     transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
1833     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
1834     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
1835     transother[CODE_HEADER_WIDETAG] = trans_code_header;
1836     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
1837     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
1838     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
1839     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
1840     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
1841     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
1842     transother[CHARACTER_WIDETAG] = trans_immediate;
1843     transother[SAP_WIDETAG] = trans_unboxed;
1844     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
1845     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
1846     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
1847     transother[FDEFN_WIDETAG] = trans_boxed;
1848
1849     /* size table, initialized the same way as scavtab */
1850     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
1851         sizetab[i] = size_lose;
1852     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1853         sizetab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
1854         sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1855         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1856         sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1857         sizetab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = size_immediate;
1858         sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1859         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1860         sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
1861     }
1862     sizetab[BIGNUM_WIDETAG] = size_unboxed;
1863     sizetab[RATIO_WIDETAG] = size_boxed;
1864 #if N_WORD_BITS == 64
1865     sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
1866 #else
1867     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
1868 #endif
1869     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1870 #ifdef LONG_FLOAT_WIDETAG
1871     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
1872 #endif
1873     sizetab[COMPLEX_WIDETAG] = size_boxed;
1874 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1875     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
1876 #endif
1877 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1878     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1879 #endif
1880 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1881     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
1882 #endif
1883     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
1884     sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
1885 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1886     sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
1887 #endif
1888     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
1889     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
1890     sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
1891     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1892         size_vector_unsigned_byte_2;
1893     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1894         size_vector_unsigned_byte_4;
1895     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1896         size_vector_unsigned_byte_8;
1897     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1898         size_vector_unsigned_byte_8;
1899     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1900         size_vector_unsigned_byte_16;
1901     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1902         size_vector_unsigned_byte_16;
1903 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1904     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] =
1905         size_vector_unsigned_byte_32;
1906 #endif
1907     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1908         size_vector_unsigned_byte_32;
1909     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1910         size_vector_unsigned_byte_32;
1911 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1912     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] =
1913         size_vector_unsigned_byte_64;
1914 #endif
1915 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1916     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1917         size_vector_unsigned_byte_64;
1918 #endif
1919 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1920     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1921         size_vector_unsigned_byte_64;
1922 #endif
1923 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1924     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
1925 #endif
1926 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1927     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1928         size_vector_unsigned_byte_16;
1929 #endif
1930 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1931     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1932         size_vector_unsigned_byte_32;
1933 #endif
1934 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1935     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1936         size_vector_unsigned_byte_32;
1937 #endif
1938 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
1939     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] =
1940         size_vector_unsigned_byte_64;
1941 #endif
1942 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1943     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
1944         size_vector_unsigned_byte_64;
1945 #endif
1946     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
1947     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
1948 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1949     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
1950 #endif
1951 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1952     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1953         size_vector_complex_single_float;
1954 #endif
1955 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1956     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1957         size_vector_complex_double_float;
1958 #endif
1959 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1960     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1961         size_vector_complex_long_float;
1962 #endif
1963     sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
1964 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1965     sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
1966 #endif
1967     sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
1968     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
1969     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
1970     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
1971     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
1972 #if 0
1973     /* We shouldn't see these, so just lose if it happens. */
1974     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
1975     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
1976 #endif
1977     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
1978     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
1979     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
1980     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
1981     sizetab[CHARACTER_WIDETAG] = size_immediate;
1982     sizetab[SAP_WIDETAG] = size_unboxed;
1983     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
1984     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
1985     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
1986     sizetab[FDEFN_WIDETAG] = size_boxed;
1987 }
1988
1989 \f
1990 /* Find the code object for the given pc, or return NULL on
1991    failure. */
1992 lispobj *
1993 component_ptr_from_pc(lispobj *pc)
1994 {
1995     lispobj *object = NULL;
1996
1997     if ( (object = search_read_only_space(pc)) )
1998         ;
1999     else if ( (object = search_static_space(pc)) )
2000         ;
2001     else
2002         object = search_dynamic_space(pc);
2003
2004     if (object) /* if we found something */
2005         if (widetag_of(*object) == CODE_HEADER_WIDETAG)
2006             return(object);
2007
2008     return (NULL);
2009 }
2010
2011 /* Scan an area looking for an object which encloses the given pointer.
2012  * Return the object start on success or NULL on failure. */
2013 lispobj *
2014 gc_search_space(lispobj *start, size_t words, lispobj *pointer)
2015 {
2016     while (words > 0) {
2017         size_t count = 1;
2018         lispobj thing = *start;
2019
2020         /* If thing is an immediate then this is a cons. */
2021         if (is_lisp_pointer(thing)
2022             || (fixnump(thing))
2023             || (widetag_of(thing) == CHARACTER_WIDETAG)
2024 #if N_WORD_BITS == 64
2025             || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
2026 #endif
2027             || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
2028             count = 2;
2029         else
2030             count = (sizetab[widetag_of(thing)])(start);
2031
2032         /* Check whether the pointer is within this object. */
2033         if ((pointer >= start) && (pointer < (start+count))) {
2034             /* found it! */
2035             /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2036             return(start);
2037         }
2038
2039         /* Round up the count. */
2040         count = CEILING(count,2);
2041
2042         start += count;
2043         words -= count;
2044     }
2045     return (NULL);
2046 }