src/runtime/gc-common.c

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