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