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