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