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