src/runtime/gc-common.c

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