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