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