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