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_bit(lispobj *where, lispobj object)
 850 {
 851     struct vector *vector;
 852     int length, nwords;
 853
 854     vector = (struct vector *) where;
 855     length = fixnum_value(vector->length);
 856     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 857
 858     return nwords;
 859 }
 860
 861 static lispobj
 862 trans_vector_bit(lispobj object)
 863 {
 864     struct vector *vector;
 865     int length, nwords;
 866
 867     gc_assert(is_lisp_pointer(object));
 868
 869     vector = (struct vector *) native_pointer(object);
 870     length = fixnum_value(vector->length);
 871     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 872
 873     return copy_large_unboxed_object(object, nwords);
 874 }
 875
 876 static int
 877 size_vector_bit(lispobj *where)
 878 {
 879     struct vector *vector;
 880     int length, nwords;
 881
 882     vector = (struct vector *) where;
 883     length = fixnum_value(vector->length);
 884     nwords = CEILING(NWORDS(length, 32) + 2, 2);
 885
 886     return nwords;
 887 }
 888
 889 static int
 890 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 891 {
 892     struct vector *vector;
 893     int length, nwords;
 894
 895     vector = (struct vector *) where;
 896     length = fixnum_value(vector->length);
 897     nwords = CEILING(NWORDS(length, 16) + 2, 2);
 898
 899     return nwords;
 900 }
 901
 902 static lispobj
 903 trans_vector_unsigned_byte_2(lispobj object)
 904 {
 905     struct vector *vector;
 906     int length, nwords;
 907
 908     gc_assert(is_lisp_pointer(object));
 909
 910     vector = (struct vector *) native_pointer(object);
 911     length = fixnum_value(vector->length);
 912     nwords = CEILING(NWORDS(length, 16) + 2, 2);
 913
 914     return copy_large_unboxed_object(object, nwords);
 915 }
 916
 917 static int
 918 size_vector_unsigned_byte_2(lispobj *where)
 919 {
 920     struct vector *vector;
 921     int length, nwords;
 922
 923     vector = (struct vector *) where;
 924     length = fixnum_value(vector->length);
 925     nwords = CEILING(NWORDS(length, 16) + 2, 2);
 926
 927     return nwords;
 928 }
 929
 930 static int
 931 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
 932 {
 933     struct vector *vector;
 934     int length, nwords;
 935
 936     vector = (struct vector *) where;
 937     length = fixnum_value(vector->length);
 938     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 939
 940     return nwords;
 941 }
 942
 943 static lispobj
 944 trans_vector_unsigned_byte_4(lispobj object)
 945 {
 946     struct vector *vector;
 947     int length, nwords;
 948
 949     gc_assert(is_lisp_pointer(object));
 950
 951     vector = (struct vector *) native_pointer(object);
 952     length = fixnum_value(vector->length);
 953     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 954
 955     return copy_large_unboxed_object(object, nwords);
 956 }
 957 static int
 958 size_vector_unsigned_byte_4(lispobj *where)
 959 {
 960     struct vector *vector;
 961     int length, nwords;
 962
 963     vector = (struct vector *) where;
 964     length = fixnum_value(vector->length);
 965     nwords = CEILING(NWORDS(length, 8) + 2, 2);
 966
 967     return nwords;
 968 }
 969
 970
 971 static int
 972 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
 973 {
 974     struct vector *vector;
 975     int length, nwords;
 976
 977     vector = (struct vector *) where;
 978     length = fixnum_value(vector->length);
 979     nwords = CEILING(NWORDS(length, 4) + 2, 2);
 980
 981     return nwords;
 982 }
 983
 984 /*********************/
 985
 986
 987
 988 static lispobj
 989 trans_vector_unsigned_byte_8(lispobj object)
 990 {
 991     struct vector *vector;
 992     int length, nwords;
 993
 994     gc_assert(is_lisp_pointer(object));
 995
 996     vector = (struct vector *) native_pointer(object);
 997     length = fixnum_value(vector->length);
 998     nwords = CEILING(NWORDS(length, 4) + 2, 2);
 999
1000     return copy_large_unboxed_object(object, nwords);
1001 }
1002
1003 static int
1004 size_vector_unsigned_byte_8(lispobj *where)
1005 {
1006     struct vector *vector;
1007     int length, nwords;
1008
1009     vector = (struct vector *) where;
1010     length = fixnum_value(vector->length);
1011     nwords = CEILING(NWORDS(length, 4) + 2, 2);
1012
1013     return nwords;
1014 }
1015
1016
1017 static int
1018 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1019 {
1020     struct vector *vector;
1021     int length, nwords;
1022
1023     vector = (struct vector *) where;
1024     length = fixnum_value(vector->length);
1025     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1026
1027     return nwords;
1028 }
1029
1030 static lispobj
1031 trans_vector_unsigned_byte_16(lispobj object)
1032 {
1033     struct vector *vector;
1034     int length, nwords;
1035
1036     gc_assert(is_lisp_pointer(object));
1037
1038     vector = (struct vector *) native_pointer(object);
1039     length = fixnum_value(vector->length);
1040     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1041
1042     return copy_large_unboxed_object(object, nwords);
1043 }
1044
1045 static int
1046 size_vector_unsigned_byte_16(lispobj *where)
1047 {
1048     struct vector *vector;
1049     int length, nwords;
1050
1051     vector = (struct vector *) where;
1052     length = fixnum_value(vector->length);
1053     nwords = CEILING(NWORDS(length, 2) + 2, 2);
1054
1055     return nwords;
1056 }
1057
1058 static int
1059 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1060 {
1061     struct vector *vector;
1062     int length, nwords;
1063
1064     vector = (struct vector *) where;
1065     length = fixnum_value(vector->length);
1066     nwords = CEILING(length + 2, 2);
1067
1068     return nwords;
1069 }
1070
1071 static lispobj
1072 trans_vector_unsigned_byte_32(lispobj object)
1073 {
1074     struct vector *vector;
1075     int length, nwords;
1076
1077     gc_assert(is_lisp_pointer(object));
1078
1079     vector = (struct vector *) native_pointer(object);
1080     length = fixnum_value(vector->length);
1081     nwords = CEILING(length + 2, 2);
1082
1083     return copy_large_unboxed_object(object, nwords);
1084 }
1085
1086 static int
1087 size_vector_unsigned_byte_32(lispobj *where)
1088 {
1089     struct vector *vector;
1090     int length, nwords;
1091
1092     vector = (struct vector *) where;
1093     length = fixnum_value(vector->length);
1094     nwords = CEILING(length + 2, 2);
1095
1096     return nwords;
1097 }
1098
1099 static int
1100 scav_vector_single_float(lispobj *where, lispobj object)
1101 {
1102     struct vector *vector;
1103     int length, nwords;
1104
1105     vector = (struct vector *) where;
1106     length = fixnum_value(vector->length);
1107     nwords = CEILING(length + 2, 2);
1108
1109     return nwords;
1110 }
1111
1112 static lispobj
1113 trans_vector_single_float(lispobj object)
1114 {
1115     struct vector *vector;
1116     int length, nwords;
1117
1118     gc_assert(is_lisp_pointer(object));
1119
1120     vector = (struct vector *) native_pointer(object);
1121     length = fixnum_value(vector->length);
1122     nwords = CEILING(length + 2, 2);
1123
1124     return copy_large_unboxed_object(object, nwords);
1125 }
1126
1127 static int
1128 size_vector_single_float(lispobj *where)
1129 {
1130     struct vector *vector;
1131     int length, nwords;
1132
1133     vector = (struct vector *) where;
1134     length = fixnum_value(vector->length);
1135     nwords = CEILING(length + 2, 2);
1136
1137     return nwords;
1138 }
1139
1140 static int
1141 scav_vector_double_float(lispobj *where, lispobj object)
1142 {
1143     struct vector *vector;
1144     int length, nwords;
1145
1146     vector = (struct vector *) where;
1147     length = fixnum_value(vector->length);
1148     nwords = CEILING(length * 2 + 2, 2);
1149
1150     return nwords;
1151 }
1152
1153 static lispobj
1154 trans_vector_double_float(lispobj object)
1155 {
1156     struct vector *vector;
1157     int length, nwords;
1158
1159     gc_assert(is_lisp_pointer(object));
1160
1161     vector = (struct vector *) native_pointer(object);
1162     length = fixnum_value(vector->length);
1163     nwords = CEILING(length * 2 + 2, 2);
1164
1165     return copy_large_unboxed_object(object, nwords);
1166 }
1167
1168 static int
1169 size_vector_double_float(lispobj *where)
1170 {
1171     struct vector *vector;
1172     int length, nwords;
1173
1174     vector = (struct vector *) where;
1175     length = fixnum_value(vector->length);
1176     nwords = CEILING(length * 2 + 2, 2);
1177
1178     return nwords;
1179 }
1180
1181 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1182 static int
1183 scav_vector_long_float(lispobj *where, lispobj object)
1184 {
1185     struct vector *vector;
1186     int length, nwords;
1187
1188     vector = (struct vector *) where;
1189     length = fixnum_value(vector->length);
1190     nwords = CEILING(length *
1191                      LONG_FLOAT_SIZE
1192                      + 2, 2);
1193     return nwords;
1194 }
1195
1196 static lispobj
1197 trans_vector_long_float(lispobj object)
1198 {
1199     struct vector *vector;
1200     int length, nwords;
1201
1202     gc_assert(is_lisp_pointer(object));
1203
1204     vector = (struct vector *) native_pointer(object);
1205     length = fixnum_value(vector->length);
1206     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1207
1208     return copy_large_unboxed_object(object, nwords);
1209 }
1210
1211 static int
1212 size_vector_long_float(lispobj *where)
1213 {
1214     struct vector *vector;
1215     int length, nwords;
1216
1217     vector = (struct vector *) where;
1218     length = fixnum_value(vector->length);
1219     nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1220
1221     return nwords;
1222 }
1223 #endif
1224
1225
1226 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1227 static int
1228 scav_vector_complex_single_float(lispobj *where, lispobj object)
1229 {
1230     struct vector *vector;
1231     int length, nwords;
1232
1233     vector = (struct vector *) where;
1234     length = fixnum_value(vector->length);
1235     nwords = CEILING(length * 2 + 2, 2);
1236
1237     return nwords;
1238 }
1239
1240 static lispobj
1241 trans_vector_complex_single_float(lispobj object)
1242 {
1243     struct vector *vector;
1244     int length, nwords;
1245
1246     gc_assert(is_lisp_pointer(object));
1247
1248     vector = (struct vector *) native_pointer(object);
1249     length = fixnum_value(vector->length);
1250     nwords = CEILING(length * 2 + 2, 2);
1251
1252     return copy_large_unboxed_object(object, nwords);
1253 }
1254
1255 static int
1256 size_vector_complex_single_float(lispobj *where)
1257 {
1258     struct vector *vector;
1259     int length, nwords;
1260
1261     vector = (struct vector *) where;
1262     length = fixnum_value(vector->length);
1263     nwords = CEILING(length * 2 + 2, 2);
1264
1265     return nwords;
1266 }
1267 #endif
1268
1269 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1270 static int
1271 scav_vector_complex_double_float(lispobj *where, lispobj object)
1272 {
1273     struct vector *vector;
1274     int length, nwords;
1275
1276     vector = (struct vector *) where;
1277     length = fixnum_value(vector->length);
1278     nwords = CEILING(length * 4 + 2, 2);
1279
1280     return nwords;
1281 }
1282
1283 static lispobj
1284 trans_vector_complex_double_float(lispobj object)
1285 {
1286     struct vector *vector;
1287     int length, nwords;
1288
1289     gc_assert(is_lisp_pointer(object));
1290
1291     vector = (struct vector *) native_pointer(object);
1292     length = fixnum_value(vector->length);
1293     nwords = CEILING(length * 4 + 2, 2);
1294
1295     return copy_large_unboxed_object(object, nwords);
1296 }
1297
1298 static int
1299 size_vector_complex_double_float(lispobj *where)
1300 {
1301     struct vector *vector;
1302     int length, nwords;
1303
1304     vector = (struct vector *) where;
1305     length = fixnum_value(vector->length);
1306     nwords = CEILING(length * 4 + 2, 2);
1307
1308     return nwords;
1309 }
1310 #endif
1311
1312
1313 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1314 static int
1315 scav_vector_complex_long_float(lispobj *where, lispobj object)
1316 {
1317     struct vector *vector;
1318     int length, nwords;
1319
1320     vector = (struct vector *) where;
1321     length = fixnum_value(vector->length);
1322     nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1323
1324     return nwords;
1325 }
1326
1327 static lispobj
1328 trans_vector_complex_long_float(lispobj object)
1329 {
1330     struct vector *vector;
1331     int length, nwords;
1332
1333     gc_assert(is_lisp_pointer(object));
1334
1335     vector = (struct vector *) native_pointer(object);
1336     length = fixnum_value(vector->length);
1337     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1338
1339     return copy_large_unboxed_object(object, nwords);
1340 }
1341
1342 static int
1343 size_vector_complex_long_float(lispobj *where)
1344 {
1345     struct vector *vector;
1346     int length, nwords;
1347
1348     vector = (struct vector *) where;
1349     length = fixnum_value(vector->length);
1350     nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1351
1352     return nwords;
1353 }
1354 #endif
1355
1356 #define WEAK_POINTER_NWORDS \
1357         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1358
1359 static lispobj
1360 trans_weak_pointer(lispobj object)
1361 {
1362     lispobj copy;
1363 #ifndef LISP_FEATURE_GENCGC
1364     struct weak_pointer *wp;
1365 #endif
1366     gc_assert(is_lisp_pointer(object));
1367
1368 #if defined(DEBUG_WEAK)
1369     printf("Transporting weak pointer from 0x%08x\n", object);
1370 #endif
1371
1372     /* Need to remember where all the weak pointers are that have */
1373     /* been transported so they can be fixed up in a post-GC pass. */
1374
1375     copy = copy_object(object, WEAK_POINTER_NWORDS);
1376 #ifndef LISP_FEATURE_GENCGC
1377     wp = (struct weak_pointer *) native_pointer(copy);
1378
1379     gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1380     /* Push the weak pointer onto the list of weak pointers. */
1381     wp->next = LOW_WORD(weak_pointers);
1382     weak_pointers = wp;
1383 #endif
1384     return copy;
1385 }
1386
1387 static int
1388 size_weak_pointer(lispobj *where)
1389 {
1390     return WEAK_POINTER_NWORDS;
1391 }
1392
1393
1394 void scan_weak_pointers(void)
1395 {
1396     struct weak_pointer *wp;
1397     for (wp = weak_pointers; wp != NULL;
1398          wp=(struct weak_pointer *)native_pointer(wp->next)) {
1399         lispobj value = wp->value;
1400         lispobj *first_pointer;
1401         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1402         if (!(is_lisp_pointer(value) && from_space_p(value)))
1403             continue;
1404
1405         /* Now, we need to check whether the object has been forwarded. If
1406          * it has been, the weak pointer is still good and needs to be
1407          * updated. Otherwise, the weak pointer needs to be nil'ed
1408          * out. */
1409
1410         first_pointer = (lispobj *)native_pointer(value);
1411
1412         if (forwarding_pointer_p(first_pointer)) {
1413             wp->value=
1414                 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1415         } else {
1416             /* Break it. */
1417             wp->value = NIL;
1418             wp->broken = T;
1419         }
1420     }
1421 }
1422
1423
1424 \f
1425 /*
1426  * initialization
1427  */
1428
1429 static int
1430 scav_lose(lispobj *where, lispobj object)
1431 {
1432     lose("no scavenge function for object 0x%08x (widetag 0x%x)",
1433          (unsigned long)object,
1434          widetag_of(*(lispobj*)native_pointer(object)));
1435     return 0; /* bogus return value to satisfy static type checking */
1436 }
1437
1438 static lispobj
1439 trans_lose(lispobj object)
1440 {
1441     lose("no transport function for object 0x%08x (widetag 0x%x)",
1442          (unsigned long)object,
1443          widetag_of(*(lispobj*)native_pointer(object)));
1444     return NIL; /* bogus return value to satisfy static type checking */
1445 }
1446
1447 static int
1448 size_lose(lispobj *where)
1449 {
1450     lose("no size function for object at 0x%08x (widetag 0x%x)",
1451          (unsigned long)where,
1452          widetag_of(LOW_WORD(where)));
1453     return 1; /* bogus return value to satisfy static type checking */
1454 }
1455
1456 \f
1457 /*
1458  * initialization
1459  */
1460
1461 void
1462 gc_init_tables(void)
1463 {
1464     int i;
1465
1466     /* Set default value in all slots of scavenge table.  FIXME
1467      * replace this gnarly sizeof with something based on
1468      * N_WIDETAG_BITS */
1469     for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1470         scavtab[i] = scav_lose;
1471     }
1472
1473     /* For each type which can be selected by the lowtag alone, set
1474      * multiple entries in our widetag scavenge table (one for each
1475      * possible value of the high bits).
1476      */
1477
1478     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1479         scavtab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1480         scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1481         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1482         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1483         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
1484         scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
1485         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1486         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1487     }
1488
1489     /* Other-pointer types (those selected by all eight bits of the
1490      * tag) get one entry each in the scavenge table. */
1491     scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1492     scavtab[RATIO_WIDETAG] = scav_boxed;
1493     scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1494     scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1495 #ifdef LONG_FLOAT_WIDETAG
1496     scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1497 #endif
1498     scavtab[COMPLEX_WIDETAG] = scav_boxed;
1499 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1500     scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1501 #endif
1502 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1503     scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1504 #endif
1505 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1506     scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1507 #endif
1508     scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1509     scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
1510     scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1511     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1512         scav_vector_unsigned_byte_2;
1513     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1514         scav_vector_unsigned_byte_4;
1515     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1516         scav_vector_unsigned_byte_8;
1517     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1518         scav_vector_unsigned_byte_16;
1519     scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1520         scav_vector_unsigned_byte_32;
1521 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1522     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1523 #endif
1524 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1525     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1526         scav_vector_unsigned_byte_16;
1527 #endif
1528 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1529     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1530         scav_vector_unsigned_byte_32;
1531 #endif
1532 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1533     scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1534         scav_vector_unsigned_byte_32;
1535 #endif
1536     scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
1537     scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
1538 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1539     scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
1540 #endif
1541 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1542     scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1543         scav_vector_complex_single_float;
1544 #endif
1545 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1546     scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1547         scav_vector_complex_double_float;
1548 #endif
1549 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1550     scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1551         scav_vector_complex_long_float;
1552 #endif
1553     scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
1554     scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
1555     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
1556     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
1557     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
1558 #ifndef LISP_FEATURE_GENCGC     /* FIXME ..._X86 ? */
1559     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
1560     scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;
1561     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
1562 #endif
1563 #ifdef LISP_FEATURE_X86
1564     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
1565     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
1566 #else
1567     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
1568     scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
1569 #endif
1570     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
1571     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
1572     scavtab[BASE_CHAR_WIDETAG] = scav_immediate;
1573     scavtab[SAP_WIDETAG] = scav_unboxed;
1574     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
1575     scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
1576 #ifdef LISP_FEATURE_SPARC
1577     scavtab[FDEFN_WIDETAG] = scav_boxed;
1578 #else
1579     scavtab[FDEFN_WIDETAG] = scav_fdefn;
1580 #endif
1581
1582     /* transport other table, initialized same way as scavtab */
1583     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
1584         transother[i] = trans_lose;
1585     transother[BIGNUM_WIDETAG] = trans_unboxed;
1586     transother[RATIO_WIDETAG] = trans_boxed;
1587     transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1588     transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1589 #ifdef LONG_FLOAT_WIDETAG
1590     transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
1591 #endif
1592     transother[COMPLEX_WIDETAG] = trans_boxed;
1593 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1594     transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
1595 #endif
1596 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1597     transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
1598 #endif
1599 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1600     transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
1601 #endif
1602     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
1603     transother[SIMPLE_STRING_WIDETAG] = trans_string;
1604     transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
1605     transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
1606     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1607         trans_vector_unsigned_byte_2;
1608     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1609         trans_vector_unsigned_byte_4;
1610     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1611         trans_vector_unsigned_byte_8;
1612     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1613         trans_vector_unsigned_byte_16;
1614     transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1615         trans_vector_unsigned_byte_32;
1616 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1617     transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1618         trans_vector_unsigned_byte_8;
1619 #endif
1620 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1621     transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1622         trans_vector_unsigned_byte_16;
1623 #endif
1624 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1625     transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1626         trans_vector_unsigned_byte_32;
1627 #endif
1628 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1629     transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1630         trans_vector_unsigned_byte_32;
1631 #endif
1632     transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
1633         trans_vector_single_float;
1634     transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
1635         trans_vector_double_float;
1636 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1637     transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
1638         trans_vector_long_float;
1639 #endif
1640 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1641     transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1642         trans_vector_complex_single_float;
1643 #endif
1644 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1645     transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1646         trans_vector_complex_double_float;
1647 #endif
1648 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1649     transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1650         trans_vector_complex_long_float;
1651 #endif
1652     transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
1653     transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
1654     transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
1655     transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
1656     transother[CODE_HEADER_WIDETAG] = trans_code_header;
1657     transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
1658     transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header;
1659     transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
1660     transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
1661     transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
1662     transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
1663     transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
1664     transother[BASE_CHAR_WIDETAG] = trans_immediate;
1665     transother[SAP_WIDETAG] = trans_unboxed;
1666     transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
1667     transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
1668     transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
1669     transother[FDEFN_WIDETAG] = trans_boxed;
1670
1671     /* size table, initialized the same way as scavtab */
1672     for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
1673         sizetab[i] = size_lose;
1674     for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1675         sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
1676         sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
1677         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1678         sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
1679         sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
1680         sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
1681         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1682         sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
1683     }
1684     sizetab[BIGNUM_WIDETAG] = size_unboxed;
1685     sizetab[RATIO_WIDETAG] = size_boxed;
1686     sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
1687     sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1688 #ifdef LONG_FLOAT_WIDETAG
1689     sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
1690 #endif
1691     sizetab[COMPLEX_WIDETAG] = size_boxed;
1692 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1693     sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
1694 #endif
1695 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1696     sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
1697 #endif
1698 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1699     sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
1700 #endif
1701     sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
1702     sizetab[SIMPLE_STRING_WIDETAG] = size_string;
1703     sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
1704     sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
1705     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1706         size_vector_unsigned_byte_2;
1707     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1708         size_vector_unsigned_byte_4;
1709     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1710         size_vector_unsigned_byte_8;
1711     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1712         size_vector_unsigned_byte_16;
1713     sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1714         size_vector_unsigned_byte_32;
1715 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1716     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
1717 #endif
1718 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1719     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1720         size_vector_unsigned_byte_16;
1721 #endif
1722 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1723     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1724         size_vector_unsigned_byte_32;
1725 #endif
1726 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1727     sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1728         size_vector_unsigned_byte_32;
1729 #endif
1730     sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
1731     sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
1732 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1733     sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
1734 #endif
1735 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1736     sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1737         size_vector_complex_single_float;
1738 #endif
1739 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1740     sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1741         size_vector_complex_double_float;
1742 #endif
1743 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1744     sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1745         size_vector_complex_long_float;
1746 #endif
1747     sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
1748     sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
1749     sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
1750     sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
1751     sizetab[CODE_HEADER_WIDETAG] = size_code_header;
1752 #if 0
1753     /* We shouldn't see these, so just lose if it happens. */
1754     sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
1755     sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header;
1756     sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
1757 #endif
1758     sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
1759     sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
1760     sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
1761     sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
1762     sizetab[BASE_CHAR_WIDETAG] = size_immediate;
1763     sizetab[SAP_WIDETAG] = size_unboxed;
1764     sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
1765     sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
1766     sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
1767     sizetab[FDEFN_WIDETAG] = size_boxed;
1768 }