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