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