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