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