2 * stop and copy GC based on Cheney's algorithm
6 * This software is part of the SBCL system. See the README file for
9 * This software is derived from the CMU CL system, which was
10 * written at Carnegie Mellon University and released into the
11 * public domain. The software is in the public domain and is
12 * provided with absolutely no warranty. See the COPYING and CREDITS
13 * files for more information.
18 #include <sys/resource.h>
25 #include "interrupt.h"
30 /* So you need to debug? */
33 #define DEBUG_SPACE_PREDICATES
34 #define DEBUG_SCAVENGE_VERBOSE
35 #define DEBUG_COPY_VERBOSE
39 static lispobj *from_space;
40 static lispobj *from_space_free_pointer;
42 static lispobj *new_space;
43 static lispobj *new_space_free_pointer;
45 static int (*scavtab[256])(lispobj *where, lispobj object);
46 static lispobj (*transother[256])(lispobj object);
47 static int (*sizetab[256])(lispobj *where);
49 static struct weak_pointer *weak_pointers;
51 static void scavenge(lispobj *start, u32 nwords);
52 static void scavenge_newspace(void);
53 static void scavenge_interrupt_contexts(void);
54 static void scan_weak_pointers(void);
55 static int scav_lose(lispobj *where, lispobj object);
57 #define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
61 #define gc_assert(ex) do { \
62 if (!(ex)) gc_abort(); \
68 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
73 #if defined(DEBUG_SPACE_PREDICATES)
76 from_space_p(lispobj object)
80 /* this can be called for untagged pointers as well as for
81 descriptors, so this assertion's not applicable
82 gc_assert(is_lisp_pointer(object));
84 ptr = (lispobj *) native_pointer(object);
86 return ((from_space <= ptr) &&
87 (ptr < from_space_free_pointer));
91 new_space_p(lispobj object)
95 gc_assert(is_lisp_pointer(object));
97 ptr = (lispobj *) native_pointer(object);
99 return ((new_space <= ptr) &&
100 (ptr < new_space_free_pointer));
105 #define from_space_p(ptr) \
106 ((from_space <= ((lispobj *) ptr)) && \
107 (((lispobj *) ptr) < from_space_free_pointer))
109 #define new_space_p(ptr) \
110 ((new_space <= ((lispobj *) ptr)) && \
111 (((lispobj *) ptr) < new_space_free_pointer))
116 /* copying objects */
119 copy_object(lispobj object, int nwords)
123 lispobj *source, *dest;
125 gc_assert(is_lisp_pointer(object));
126 gc_assert(from_space_p(object));
127 gc_assert((nwords & 0x01) == 0);
129 /* get tag of object */
130 tag = LowtagOf(object);
133 new = new_space_free_pointer;
134 new_space_free_pointer += nwords;
137 source = (lispobj *) native_pointer(object);
139 #ifdef DEBUG_COPY_VERBOSE
140 fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new);
143 /* copy the object */
151 /* return lisp pointer of new object */
152 return (lispobj)(LOW_WORD(new) | tag);
156 /* collecting garbage */
160 tv_diff(struct timeval *x, struct timeval *y)
162 return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
163 ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
167 #define BYTES_ZERO_BEFORE_END (1<<12)
172 #define U32 unsigned long
177 U32 *ptr = (U32 *)current_control_stack_pointer;
183 } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
188 } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
195 /* Note: The generic GC interface we're implementing passes us a
196 * last_generation argument. That's meaningless for us, since we're
197 * not a generational GC. So we ignore it. */
199 collect_garbage(unsigned ignore)
202 struct timeval start_tv, stop_tv;
203 struct rusage start_rusage, stop_rusage;
204 double real_time, system_time, user_time;
205 double percent_retained, gc_rate;
206 unsigned long size_discarded;
207 unsigned long size_retained;
209 lispobj *current_static_space_free_pointer;
210 unsigned long static_space_size;
211 unsigned long control_stack_size, binding_stack_size;
215 printf("[Collecting garbage ... \n");
217 getrusage(RUSAGE_SELF, &start_rusage);
218 gettimeofday(&start_tv, (struct timezone *) 0);
222 sigaddset_blockable(&tmp);
223 sigprocmask(SIG_BLOCK, &tmp, &old);
225 current_static_space_free_pointer =
226 (lispobj *) ((unsigned long)
227 SymbolValue(STATIC_SPACE_FREE_POINTER));
230 /* Set up from space and new space pointers. */
232 from_space = current_dynamic_space;
233 from_space_free_pointer = dynamic_space_free_pointer;
236 fprintf(stderr,"from_space = %lx\n",
237 (unsigned long) current_dynamic_space);
239 if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START)
240 new_space = (lispobj *)DYNAMIC_1_SPACE_START;
241 else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START)
242 new_space = (lispobj *) DYNAMIC_0_SPACE_START;
244 lose("GC lossage. Current dynamic space is bogus!\n");
246 new_space_free_pointer = new_space;
249 /* Initialize the weak pointer list. */
250 weak_pointers = (struct weak_pointer *) NULL;
253 /* Scavenge all of the roots. */
255 printf("Scavenging interrupt contexts ...\n");
257 scavenge_interrupt_contexts();
260 printf("Scavenging interrupt handlers (%d bytes) ...\n",
261 (int)sizeof(interrupt_handlers));
263 scavenge((lispobj *) interrupt_handlers,
264 sizeof(interrupt_handlers) / sizeof(lispobj));
266 /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
268 current_control_stack_pointer-
269 (lispobj *)CONTROL_STACK_START;
271 printf("Scavenging the control stack at %p (%ld words) ...\n",
272 ((lispobj *)CONTROL_STACK_START),
275 scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
279 current_binding_stack_pointer -
280 (lispobj *)BINDING_STACK_START;
282 printf("Scavenging the binding stack %x - %x (%d words) ...\n",
283 BINDING_STACK_START,current_binding_stack_pointer,
284 (int)(binding_stack_size));
286 scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
289 current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
291 printf("Scavenging static space %x - %x (%d words) ...\n",
292 STATIC_SPACE_START,current_static_space_free_pointer,
293 (int)(static_space_size));
295 scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
297 /* Scavenge newspace. */
299 printf("Scavenging new space (%d bytes) ...\n",
300 (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
305 #if defined(DEBUG_PRINT_GARBAGE)
306 print_garbage(from_space, from_space_free_pointer);
309 /* Scan the weak pointers. */
311 printf("Scanning weak pointers ...\n");
313 scan_weak_pointers();
318 printf("Flipping spaces ...\n");
321 os_zero((os_vm_address_t) current_dynamic_space,
322 (os_vm_size_t) DYNAMIC_SPACE_SIZE);
324 current_dynamic_space = new_space;
325 dynamic_space_free_pointer = new_space_free_pointer;
328 size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
329 size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
334 printf("Zeroing empty part of control stack ...\n");
338 sigprocmask(SIG_SETMASK, &old, 0);
342 gettimeofday(&stop_tv, (struct timezone *) 0);
343 getrusage(RUSAGE_SELF, &stop_rusage);
347 percent_retained = (((float) size_retained) /
348 ((float) size_discarded)) * 100.0;
350 printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
351 size_retained, size_discarded, percent_retained);
353 real_time = tv_diff(&stop_tv, &start_tv);
354 user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
355 system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
358 printf("Statistics:\n");
359 printf("%10.2f sec of real time\n", real_time);
360 printf("%10.2f sec of user time,\n", user_time);
361 printf("%10.2f sec of system time.\n", system_time);
363 printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
364 real_time, user_time, system_time);
367 gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
369 printf("%10.2f M bytes/sec collected.\n", gc_rate);
377 scavenge(lispobj *start, u32 nwords)
381 int type, words_scavenged;
384 type = TypeOf(object);
386 #if defined(DEBUG_SCAVENGE_VERBOSE)
387 fprintf(stderr,"Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
388 (unsigned long) start, (unsigned long) object, type);
391 if (is_lisp_pointer(object)) {
392 /* It be a pointer. */
393 if (from_space_p(object)) {
394 /* It currently points to old space. Check for a */
395 /* forwarding pointer. */
398 first_word = *((lispobj *)native_pointer(object));
399 if (is_lisp_pointer(first_word) &&
400 new_space_p(first_word)) {
401 /* Yep, there be a forwarding pointer. */
406 /* Scavenge that pointer. */
407 words_scavenged = (scavtab[type])(start, object);
411 /* It points somewhere other than oldspace. Leave */
417 /* there are some situations where an
418 other-immediate may end up in a descriptor
419 register. I'm not sure whether this is
420 supposed to happen, but if it does then we
421 don't want to (a) barf or (b) scavenge over the
422 data-block, because there isn't one. So, if
423 we're checking a single word and it's anything
424 other than a pointer, just hush it up */
427 if((scavtab[type]==scav_lose) ||
428 (((scavtab[type])(start,object))>1)) {
429 fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a test case to sbcl-devel@lists.sourceforge.net\n",
433 else if ((object & 3) == 0) {
434 /* It's a fixnum. Real easy. */
438 /* It's some random header object. */
439 words_scavenged = (scavtab[type])(start, object);
443 start += words_scavenged;
444 nwords -= words_scavenged;
446 gc_assert(nwords == 0);
450 scavenge_newspace(void)
452 lispobj *here, *next;
455 while (here < new_space_free_pointer) {
456 /* printf("here=%lx, new_space_free_pointer=%lx\n",
457 here,new_space_free_pointer); */
458 next = new_space_free_pointer;
459 scavenge(here, next - here);
462 /* printf("done with newspace\n"); */
465 /* scavenging interrupt contexts */
467 static int boxed_registers[] = BOXED_REGISTERS;
470 scavenge_interrupt_context(os_context_t *context)
475 unsigned long lip_offset;
476 int lip_register_pair;
478 unsigned long pc_code_offset;
480 unsigned long npc_code_offset;
483 /* Find the LIP's register pair and calculate its offset */
484 /* before we scavenge the context. */
486 lip = *os_context_register_addr(context, reg_LIP);
487 /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
488 lip_offset = 0x7FFFFFFF;
489 lip_register_pair = -1;
490 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
495 index = boxed_registers[i];
496 reg = *os_context_register_addr(context, index);
497 /* would be using PTR if not for integer length issues */
498 if ((reg & ~((1L<<lowtag_Bits)-1)) <= lip) {
500 if (offset < lip_offset) {
502 lip_register_pair = index;
508 /* Compute the PC's offset from the start of the CODE */
510 pc_code_offset = *os_context_pc_addr(context) -
511 *os_context_register_addr(context, reg_CODE);
513 npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
516 /* Scanvenge all boxed registers in the context. */
517 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
521 index = boxed_registers[i];
522 foo = *os_context_register_addr(context,index);
523 scavenge((lispobj *) &foo, 1);
524 *os_context_register_addr(context,index) = foo;
526 /* this is unlikely to work as intended on bigendian
527 * 64 bit platforms */
530 os_context_register_addr(context, index), 1);
535 *os_context_register_addr(context, reg_LIP) =
536 *os_context_register_addr(context, lip_register_pair) + lip_offset;
539 /* Fix the PC if it was in from space */
540 if (from_space_p(*os_context_pc_addr(context)))
541 *os_context_pc_addr(context) =
542 *os_context_register_addr(context, reg_CODE) + pc_code_offset;
544 if (from_space_p(SC_NPC(context)))
545 SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
549 void scavenge_interrupt_contexts(void)
552 os_context_t *context;
554 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
556 for (i = 0; i < index; i++) {
557 context = lisp_interrupt_contexts[i];
558 scavenge_interrupt_context(context);
566 print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
569 int total_words_not_copied;
571 printf("Scanning from space ...\n");
573 total_words_not_copied = 0;
575 while (start < from_space_free_pointer) {
577 int forwardp, type, nwords;
581 forwardp = is_lisp_pointer(object) && new_space_p(object);
587 tag = LowtagOf(object);
590 case type_ListPointer:
593 case type_InstancePointer:
594 printf("Don't know about instances yet!\n");
597 case type_FunPointer:
600 case type_OtherPointer:
601 pointer = (lispobj *) native_pointer(object);
603 type = TypeOf(header);
604 nwords = (sizetab[type])(pointer);
607 type = TypeOf(object);
608 nwords = (sizetab[type])(start);
609 total_words_not_copied += nwords;
610 printf("%4d words not copied at 0x%16lx; ",
611 nwords, (unsigned long) start);
612 printf("Header word is 0x%08x\n",
613 (unsigned int) object);
617 printf("%d total words not copied.\n", total_words_not_copied);
621 /* code and code-related objects */
623 /* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
624 * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
625 * in words, that's measured in bytes. Gotta love CMU CL..) */
626 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
628 static lispobj trans_fun_header(lispobj object);
629 static lispobj trans_boxed(lispobj object);
632 scav_fun_pointer(lispobj *where, lispobj object)
634 lispobj *first_pointer;
639 gc_assert(is_lisp_pointer(object));
641 /* object is a pointer into from space. Not a FP */
642 first_pointer = (lispobj *) native_pointer(object);
643 first = *first_pointer;
645 /* must transport object -- object may point */
646 /* to either a function header, a closure */
647 /* function header, or to a closure header. */
649 type = TypeOf(first);
651 case type_SimpleFunHeader:
652 case type_ClosureFunHeader:
653 copy = trans_fun_header(object);
656 copy = trans_boxed(object);
660 first = *first_pointer = copy;
662 gc_assert(is_lisp_pointer(first));
663 gc_assert(!from_space_p(first));
670 trans_code(struct code *code)
672 struct code *new_code;
673 lispobj first, l_code, l_new_code;
674 int nheader_words, ncode_words, nwords;
675 unsigned long displacement;
676 lispobj fheaderl, *prev_pointer;
678 #if defined(DEBUG_CODE_GC)
679 printf("\nTransporting code object located at 0x%08x.\n",
680 (unsigned long) code);
683 /* if object has already been transported, just return pointer */
684 first = code->header;
685 if (is_lisp_pointer(first) && new_space_p(first)) {
687 printf("Was already transported\n");
689 return (struct code *) native_pointer(first);
692 gc_assert(TypeOf(first) == type_CodeHeader);
694 /* prepare to transport the code vector */
695 l_code = (lispobj) LOW_WORD(code) | type_OtherPointer;
697 ncode_words = fixnum_value(code->code_size);
698 nheader_words = HeaderValue(code->header);
699 nwords = ncode_words + nheader_words;
700 nwords = CEILING(nwords, 2);
702 l_new_code = copy_object(l_code, nwords);
703 new_code = (struct code *) native_pointer(l_new_code);
705 displacement = l_new_code - l_code;
707 #if defined(DEBUG_CODE_GC)
708 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
709 (unsigned long) code, (unsigned long) new_code);
710 printf("Code object is %d words long.\n", nwords);
713 /* set forwarding pointer */
714 code->header = l_new_code;
716 /* set forwarding pointers for all the function headers in the */
717 /* code object. also fix all self pointers */
719 fheaderl = code->entry_points;
720 prev_pointer = &new_code->entry_points;
722 while (fheaderl != NIL) {
723 struct simple_fun *fheaderp, *nfheaderp;
726 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
727 gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
729 /* calcuate the new function pointer and the new */
730 /* function header */
731 nfheaderl = fheaderl + displacement;
732 nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
734 /* set forwarding pointer */
736 printf("fheaderp->header (at %x) <- %x\n",
737 &(fheaderp->header) , nfheaderl);
739 fheaderp->header = nfheaderl;
741 /* fix self pointer */
742 nfheaderp->self = nfheaderl;
744 *prev_pointer = nfheaderl;
746 fheaderl = fheaderp->next;
747 prev_pointer = &nfheaderp->next;
751 os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
752 ncode_words * sizeof(int));
758 scav_code_header(lispobj *where, lispobj object)
761 int nheader_words, ncode_words, nwords;
763 struct simple_fun *fheaderp;
765 code = (struct code *) where;
766 ncode_words = fixnum_value(code->code_size);
767 nheader_words = HeaderValue(object);
768 nwords = ncode_words + nheader_words;
769 nwords = CEILING(nwords, 2);
771 #if defined(DEBUG_CODE_GC)
772 printf("\nScavening code object at 0x%08x.\n",
773 (unsigned long) where);
774 printf("Code object is %d words long.\n", nwords);
775 printf("Scavenging boxed section of code data block (%d words).\n",
779 /* Scavenge the boxed section of the code data block */
780 scavenge(where + 1, nheader_words - 1);
782 /* Scavenge the boxed section of each function object in the */
783 /* code data block */
784 fheaderl = code->entry_points;
785 while (fheaderl != NIL) {
786 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
787 gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
789 #if defined(DEBUG_CODE_GC)
790 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
791 (unsigned long) native_pointer(fheaderl));
793 scavenge(&fheaderp->name, 1);
794 scavenge(&fheaderp->arglist, 1);
795 scavenge(&fheaderp->type, 1);
797 fheaderl = fheaderp->next;
804 trans_code_header(lispobj object)
808 ncode = trans_code((struct code *) native_pointer(object));
809 return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
813 size_code_header(lispobj *where)
816 int nheader_words, ncode_words, nwords;
818 code = (struct code *) where;
820 ncode_words = fixnum_value(code->code_size);
821 nheader_words = HeaderValue(code->header);
822 nwords = ncode_words + nheader_words;
823 nwords = CEILING(nwords, 2);
830 scav_return_pc_header(lispobj *where, lispobj object)
832 fprintf(stderr, "GC lossage. Should not be scavenging a ");
833 fprintf(stderr, "Return PC Header.\n");
834 fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
840 trans_return_pc_header(lispobj object)
842 struct simple_fun *return_pc;
843 unsigned long offset;
844 struct code *code, *ncode;
846 return_pc = (struct simple_fun *) native_pointer(object);
847 offset = HeaderValue(return_pc->header) * 4 ;
849 /* Transport the whole code object */
850 code = (struct code *) ((unsigned long) return_pc - offset);
852 printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
854 ncode = trans_code(code);
855 if(object==0x304748d7) {
856 /* monitor_or_something(); */
858 ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
860 printf("trans_return_pc_header returning %x\n",ret);
865 /* On the 386, closures hold a pointer to the raw address instead of
866 * the function object, so we can use CALL [$FDEFN+const] to invoke
867 * the function without loading it into a register. Given that code
868 * objects don't move, we don't need to update anything, but we do
869 * have to figure out that the function is still live. */
872 scav_closure_header(where, object)
873 lispobj *where, object;
875 struct closure *closure;
878 closure = (struct closure *)where;
879 fun = closure->fun - FUN_RAW_ADDR_OFFSET;
887 scav_fun_header(lispobj *where, lispobj object)
889 fprintf(stderr, "GC lossage. Should not be scavenging a ");
890 fprintf(stderr, "Function Header.\n");
891 fprintf(stderr, "where = 0x%p, object = 0x%08x",
892 where, (unsigned int) object);
898 trans_fun_header(lispobj object)
900 struct simple_fun *fheader;
901 unsigned long offset;
902 struct code *code, *ncode;
904 fheader = (struct simple_fun *) native_pointer(object);
905 offset = HeaderValue(fheader->header) * 4;
907 /* Transport the whole code object */
908 code = (struct code *) ((unsigned long) fheader - offset);
909 ncode = trans_code(code);
911 return ((lispobj) LOW_WORD(ncode) + offset) | type_FunPointer;
919 scav_instance_pointer(lispobj *where, lispobj object)
921 lispobj *first_pointer;
923 /* object is a pointer into from space. Not a FP */
924 first_pointer = (lispobj *) native_pointer(object);
926 *where = *first_pointer = trans_boxed(object);
931 /* lists and conses */
933 static lispobj trans_list(lispobj object);
936 scav_list_pointer(lispobj *where, lispobj object)
938 lispobj first, *first_pointer;
940 gc_assert(is_lisp_pointer(object));
942 /* object is a pointer into from space. Not a FP. */
943 first_pointer = (lispobj *) native_pointer(object);
945 first = *first_pointer = trans_list(object);
947 gc_assert(is_lisp_pointer(first));
948 gc_assert(!from_space_p(first));
955 trans_list(lispobj object)
957 lispobj new_list_pointer;
958 struct cons *cons, *new_cons;
960 cons = (struct cons *) native_pointer(object);
962 /* ### Don't use copy_object here. */
963 new_list_pointer = copy_object(object, 2);
964 new_cons = (struct cons *) native_pointer(new_list_pointer);
966 /* Set forwarding pointer. */
967 cons->car = new_list_pointer;
969 /* Try to linearize the list in the cdr direction to help reduce */
973 lispobj cdr, new_cdr, first;
974 struct cons *cdr_cons, *new_cdr_cons;
978 if (LowtagOf(cdr) != type_ListPointer ||
979 !from_space_p(cdr) ||
980 (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
981 && new_space_p(first)))
984 cdr_cons = (struct cons *) native_pointer(cdr);
986 /* ### Don't use copy_object here */
987 new_cdr = copy_object(cdr, 2);
988 new_cdr_cons = (struct cons *) native_pointer(new_cdr);
990 /* Set forwarding pointer */
991 cdr_cons->car = new_cdr;
993 /* Update the cdr of the last cons copied into new */
994 /* space to keep the newspace scavenge from having to */
996 new_cons->cdr = new_cdr;
999 new_cons = new_cdr_cons;
1002 return new_list_pointer;
1006 /* scavenging and transporting other pointers */
1009 scav_other_pointer(lispobj *where, lispobj object)
1011 lispobj first, *first_pointer;
1013 gc_assert(is_lisp_pointer(object));
1015 /* Object is a pointer into from space - not a FP */
1016 first_pointer = (lispobj *) native_pointer(object);
1017 first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
1019 gc_assert(is_lisp_pointer(first));
1020 gc_assert(!from_space_p(first));
1027 /* immediate, boxed, and unboxed objects */
1030 size_pointer(lispobj *where)
1036 scav_immediate(lispobj *where, lispobj object)
1042 trans_immediate(lispobj object)
1044 fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
1050 size_immediate(lispobj *where)
1057 scav_boxed(lispobj *where, lispobj object)
1063 trans_boxed(lispobj object)
1066 unsigned long length;
1068 gc_assert(is_lisp_pointer(object));
1070 header = *((lispobj *) native_pointer(object));
1071 length = HeaderValue(header) + 1;
1072 length = CEILING(length, 2);
1074 return copy_object(object, length);
1078 size_boxed(lispobj *where)
1081 unsigned long length;
1084 length = HeaderValue(header) + 1;
1085 length = CEILING(length, 2);
1090 /* Note: on the sparc we don't have to do anything special for fdefns, */
1091 /* 'cause the raw-addr has a function lowtag. */
1094 scav_fdefn(lispobj *where, lispobj object)
1096 struct fdefn *fdefn;
1098 fdefn = (struct fdefn *)where;
1100 if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
1101 == (char *)((unsigned long)(fdefn->raw_addr))) {
1102 scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
1104 (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
1105 return sizeof(struct fdefn) / sizeof(lispobj);
1113 scav_unboxed(lispobj *where, lispobj object)
1115 unsigned long length;
1117 length = HeaderValue(object) + 1;
1118 length = CEILING(length, 2);
1124 trans_unboxed(lispobj object)
1127 unsigned long length;
1130 gc_assert(is_lisp_pointer(object));
1132 header = *((lispobj *) native_pointer(object));
1133 length = HeaderValue(header) + 1;
1134 length = CEILING(length, 2);
1136 return copy_object(object, length);
1140 size_unboxed(lispobj *where)
1143 unsigned long length;
1146 length = HeaderValue(header) + 1;
1147 length = CEILING(length, 2);
1153 /* vector-like objects */
1155 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1158 scav_string(lispobj *where, lispobj object)
1160 struct vector *vector;
1163 /* NOTE: Strings contain one more byte of data than the length */
1164 /* slot indicates. */
1166 vector = (struct vector *) where;
1167 length = fixnum_value(vector->length) + 1;
1168 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1174 trans_string(lispobj object)
1176 struct vector *vector;
1179 gc_assert(is_lisp_pointer(object));
1181 /* NOTE: Strings contain one more byte of data than the length */
1182 /* slot indicates. */
1184 vector = (struct vector *) native_pointer(object);
1185 length = fixnum_value(vector->length) + 1;
1186 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1188 return copy_object(object, nwords);
1192 size_string(lispobj *where)
1194 struct vector *vector;
1197 /* NOTE: Strings contain one more byte of data than the length */
1198 /* slot indicates. */
1200 vector = (struct vector *) where;
1201 length = fixnum_value(vector->length) + 1;
1202 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1208 scav_vector(lispobj *where, lispobj object)
1210 if (HeaderValue(object) == subtype_VectorValidHashing)
1211 *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
1218 trans_vector(lispobj object)
1220 struct vector *vector;
1223 gc_assert(is_lisp_pointer(object));
1225 vector = (struct vector *) native_pointer(object);
1227 length = fixnum_value(vector->length);
1228 nwords = CEILING(length + 2, 2);
1230 return copy_object(object, nwords);
1234 size_vector(lispobj *where)
1236 struct vector *vector;
1239 vector = (struct vector *) where;
1240 length = fixnum_value(vector->length);
1241 nwords = CEILING(length + 2, 2);
1248 scav_vector_bit(lispobj *where, lispobj object)
1250 struct vector *vector;
1253 vector = (struct vector *) where;
1254 length = fixnum_value(vector->length);
1255 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1261 trans_vector_bit(lispobj object)
1263 struct vector *vector;
1266 gc_assert(is_lisp_pointer(object));
1268 vector = (struct vector *) native_pointer(object);
1269 length = fixnum_value(vector->length);
1270 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1272 return copy_object(object, nwords);
1276 size_vector_bit(lispobj *where)
1278 struct vector *vector;
1281 vector = (struct vector *) where;
1282 length = fixnum_value(vector->length);
1283 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1290 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
1292 struct vector *vector;
1295 vector = (struct vector *) where;
1296 length = fixnum_value(vector->length);
1297 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1303 trans_vector_unsigned_byte_2(lispobj object)
1305 struct vector *vector;
1308 gc_assert(is_lisp_pointer(object));
1310 vector = (struct vector *) native_pointer(object);
1311 length = fixnum_value(vector->length);
1312 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1314 return copy_object(object, nwords);
1318 size_vector_unsigned_byte_2(lispobj *where)
1320 struct vector *vector;
1323 vector = (struct vector *) where;
1324 length = fixnum_value(vector->length);
1325 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1332 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1334 struct vector *vector;
1337 vector = (struct vector *) where;
1338 length = fixnum_value(vector->length);
1339 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1345 trans_vector_unsigned_byte_4(lispobj object)
1347 struct vector *vector;
1350 gc_assert(is_lisp_pointer(object));
1352 vector = (struct vector *) native_pointer(object);
1353 length = fixnum_value(vector->length);
1354 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1356 return copy_object(object, nwords);
1360 size_vector_unsigned_byte_4(lispobj *where)
1362 struct vector *vector;
1365 vector = (struct vector *) where;
1366 length = fixnum_value(vector->length);
1367 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1374 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1376 struct vector *vector;
1379 vector = (struct vector *) where;
1380 length = fixnum_value(vector->length);
1381 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1387 trans_vector_unsigned_byte_8(lispobj object)
1389 struct vector *vector;
1392 gc_assert(is_lisp_pointer(object));
1394 vector = (struct vector *) native_pointer(object);
1395 length = fixnum_value(vector->length);
1396 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1398 return copy_object(object, nwords);
1402 size_vector_unsigned_byte_8(lispobj *where)
1404 struct vector *vector;
1407 vector = (struct vector *) where;
1408 length = fixnum_value(vector->length);
1409 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1416 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1418 struct vector *vector;
1421 vector = (struct vector *) where;
1422 length = fixnum_value(vector->length);
1423 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1429 trans_vector_unsigned_byte_16(lispobj object)
1431 struct vector *vector;
1434 gc_assert(is_lisp_pointer(object));
1436 vector = (struct vector *) native_pointer(object);
1437 length = fixnum_value(vector->length);
1438 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1440 return copy_object(object, nwords);
1444 size_vector_unsigned_byte_16(lispobj *where)
1446 struct vector *vector;
1449 vector = (struct vector *) where;
1450 length = fixnum_value(vector->length);
1451 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1458 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1460 struct vector *vector;
1463 vector = (struct vector *) where;
1464 length = fixnum_value(vector->length);
1465 nwords = CEILING(length + 2, 2);
1471 trans_vector_unsigned_byte_32(lispobj object)
1473 struct vector *vector;
1476 gc_assert(is_lisp_pointer(object));
1478 vector = (struct vector *) native_pointer(object);
1479 length = fixnum_value(vector->length);
1480 nwords = CEILING(length + 2, 2);
1482 return copy_object(object, nwords);
1486 size_vector_unsigned_byte_32(lispobj *where)
1488 struct vector *vector;
1491 vector = (struct vector *) where;
1492 length = fixnum_value(vector->length);
1493 nwords = CEILING(length + 2, 2);
1500 scav_vector_single_float(lispobj *where, lispobj object)
1502 struct vector *vector;
1505 vector = (struct vector *) where;
1506 length = fixnum_value(vector->length);
1507 nwords = CEILING(length + 2, 2);
1513 trans_vector_single_float(lispobj object)
1515 struct vector *vector;
1518 gc_assert(is_lisp_pointer(object));
1520 vector = (struct vector *) native_pointer(object);
1521 length = fixnum_value(vector->length);
1522 nwords = CEILING(length + 2, 2);
1524 return copy_object(object, nwords);
1528 size_vector_single_float(lispobj *where)
1530 struct vector *vector;
1533 vector = (struct vector *) where;
1534 length = fixnum_value(vector->length);
1535 nwords = CEILING(length + 2, 2);
1542 scav_vector_double_float(lispobj *where, lispobj object)
1544 struct vector *vector;
1547 vector = (struct vector *) where;
1548 length = fixnum_value(vector->length);
1549 nwords = CEILING(length * 2 + 2, 2);
1555 trans_vector_double_float(lispobj object)
1557 struct vector *vector;
1560 gc_assert(is_lisp_pointer(object));
1562 vector = (struct vector *) native_pointer(object);
1563 length = fixnum_value(vector->length);
1564 nwords = CEILING(length * 2 + 2, 2);
1566 return copy_object(object, nwords);
1570 size_vector_double_float(lispobj *where)
1572 struct vector *vector;
1575 vector = (struct vector *) where;
1576 length = fixnum_value(vector->length);
1577 nwords = CEILING(length * 2 + 2, 2);
1583 #ifdef type_SimpleArrayLongFloat
1585 scav_vector_long_float(lispobj *where, lispobj object)
1587 struct vector *vector;
1590 vector = (struct vector *) where;
1591 length = fixnum_value(vector->length);
1593 nwords = CEILING(length * 4 + 2, 2);
1600 trans_vector_long_float(lispobj object)
1602 struct vector *vector;
1605 gc_assert(is_lisp_pointer(object));
1607 vector = (struct vector *) native_pointer(object);
1608 length = fixnum_value(vector->length);
1610 nwords = CEILING(length * 4 + 2, 2);
1613 return copy_object(object, nwords);
1617 size_vector_long_float(lispobj *where)
1619 struct vector *vector;
1622 vector = (struct vector *) where;
1623 length = fixnum_value(vector->length);
1625 nwords = CEILING(length * 4 + 2, 2);
1633 #ifdef type_SimpleArrayComplexSingleFloat
1635 scav_vector_complex_single_float(lispobj *where, lispobj object)
1637 struct vector *vector;
1640 vector = (struct vector *) where;
1641 length = fixnum_value(vector->length);
1642 nwords = CEILING(length * 2 + 2, 2);
1648 trans_vector_complex_single_float(lispobj object)
1650 struct vector *vector;
1653 gc_assert(is_lisp_pointer(object));
1655 vector = (struct vector *) native_pointer(object);
1656 length = fixnum_value(vector->length);
1657 nwords = CEILING(length * 2 + 2, 2);
1659 return copy_object(object, nwords);
1663 size_vector_complex_single_float(lispobj *where)
1665 struct vector *vector;
1668 vector = (struct vector *) where;
1669 length = fixnum_value(vector->length);
1670 nwords = CEILING(length * 2 + 2, 2);
1676 #ifdef type_SimpleArrayComplexDoubleFloat
1678 scav_vector_complex_double_float(lispobj *where, lispobj object)
1680 struct vector *vector;
1683 vector = (struct vector *) where;
1684 length = fixnum_value(vector->length);
1685 nwords = CEILING(length * 4 + 2, 2);
1691 trans_vector_complex_double_float(lispobj object)
1693 struct vector *vector;
1696 gc_assert(is_lisp_pointer(object));
1698 vector = (struct vector *) native_pointer(object);
1699 length = fixnum_value(vector->length);
1700 nwords = CEILING(length * 4 + 2, 2);
1702 return copy_object(object, nwords);
1706 size_vector_complex_double_float(lispobj *where)
1708 struct vector *vector;
1711 vector = (struct vector *) where;
1712 length = fixnum_value(vector->length);
1713 nwords = CEILING(length * 4 + 2, 2);
1719 #ifdef type_SimpleArrayComplexLongFloat
1721 scav_vector_complex_long_float(lispobj *where, lispobj object)
1723 struct vector *vector;
1726 vector = (struct vector *) where;
1727 length = fixnum_value(vector->length);
1729 nwords = CEILING(length * 8 + 2, 2);
1736 trans_vector_complex_long_float(lispobj object)
1738 struct vector *vector;
1741 gc_assert(is_lisp_pointer(object));
1743 vector = (struct vector *) native_pointer(object);
1744 length = fixnum_value(vector->length);
1746 nwords = CEILING(length * 8 + 2, 2);
1749 return copy_object(object, nwords);
1753 size_vector_complex_long_float(lispobj *where)
1755 struct vector *vector;
1758 vector = (struct vector *) where;
1759 length = fixnum_value(vector->length);
1761 nwords = CEILING(length * 8 + 2, 2);
1771 #define WEAK_POINTER_NWORDS \
1772 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1775 scav_weak_pointer(lispobj *where, lispobj object)
1777 /* Do not let GC scavenge the value slot of the weak pointer */
1778 /* (that is why it is a weak pointer). Note: we could use */
1779 /* the scav_unboxed method here. */
1781 return WEAK_POINTER_NWORDS;
1785 trans_weak_pointer(lispobj object)
1788 struct weak_pointer *wp;
1790 gc_assert(is_lisp_pointer(object));
1792 #if defined(DEBUG_WEAK)
1793 printf("Transporting weak pointer from 0x%08x\n", object);
1796 /* Need to remember where all the weak pointers are that have */
1797 /* been transported so they can be fixed up in a post-GC pass. */
1799 copy = copy_object(object, WEAK_POINTER_NWORDS);
1800 wp = (struct weak_pointer *) native_pointer(copy);
1803 /* Push the weak pointer onto the list of weak pointers. */
1804 wp->next = LOW_WORD(weak_pointers);
1811 size_weak_pointer(lispobj *where)
1813 return WEAK_POINTER_NWORDS;
1816 void scan_weak_pointers(void)
1818 struct weak_pointer *wp;
1820 for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1821 wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1823 lispobj first, *first_pointer;
1827 #if defined(DEBUG_WEAK)
1828 printf("Weak pointer at 0x%p\n", wp);
1829 printf("Value: 0x%08x\n", (unsigned int) value);
1832 if (!(is_lisp_pointer(value) && from_space_p(value)))
1835 /* Now, we need to check if the object has been */
1836 /* forwarded. If it has been, the weak pointer is */
1837 /* still good and needs to be updated. Otherwise, the */
1838 /* weak pointer needs to be nil'ed out. */
1840 first_pointer = (lispobj *) native_pointer(value);
1841 first = *first_pointer;
1843 #if defined(DEBUG_WEAK)
1844 printf("First: 0x%08x\n", (unsigned long) first);
1847 if (is_lisp_pointer(first) && new_space_p(first))
1858 /* initialization */
1861 scav_lose(lispobj *where, lispobj object)
1863 fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n",
1864 (unsigned int) object, (unsigned long)where);
1870 trans_lose(lispobj object)
1872 fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
1873 (unsigned int)object);
1879 size_lose(lispobj *where)
1881 fprintf(stderr, "Size lossage. No size function for object at 0x%p\n",
1883 fprintf(stderr, "First word of object: 0x%08x\n",
1888 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1889 * precise generational GC is revived, it might have three. It would
1890 * be nice to share the scavtab[] data set up here, and perhaps other
1891 * things too, between all of them, rather than trying to maintain
1892 * multiple copies. -- WHN 2001-05-09 */
1898 /* scavenge table */
1899 for (i = 0; i < 256; i++)
1900 scavtab[i] = scav_lose;
1901 /* scavtab[i] = scav_immediate; */
1903 for (i = 0; i < 32; i++) {
1904 scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
1905 scavtab[type_FunPointer|(i<<3)] = scav_fun_pointer;
1906 /* OtherImmediate0 */
1907 scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
1908 scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
1909 scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
1910 /* OtherImmediate1 */
1911 scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
1914 scavtab[type_Bignum] = scav_unboxed;
1915 scavtab[type_Ratio] = scav_boxed;
1916 scavtab[type_SingleFloat] = scav_unboxed;
1917 scavtab[type_DoubleFloat] = scav_unboxed;
1918 #ifdef type_LongFloat
1919 scavtab[type_LongFloat] = scav_unboxed;
1921 scavtab[type_Complex] = scav_boxed;
1922 #ifdef type_ComplexSingleFloat
1923 scavtab[type_ComplexSingleFloat] = scav_unboxed;
1925 #ifdef type_ComplexDoubleFloat
1926 scavtab[type_ComplexDoubleFloat] = scav_unboxed;
1928 #ifdef type_ComplexLongFloat
1929 scavtab[type_ComplexLongFloat] = scav_unboxed;
1931 scavtab[type_SimpleArray] = scav_boxed;
1932 scavtab[type_SimpleString] = scav_string;
1933 scavtab[type_SimpleBitVector] = scav_vector_bit;
1934 scavtab[type_SimpleVector] = scav_vector;
1935 scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
1936 scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
1937 scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
1938 scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
1939 scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
1940 #ifdef type_SimpleArraySignedByte8
1941 scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
1943 #ifdef type_SimpleArraySignedByte16
1944 scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
1946 #ifdef type_SimpleArraySignedByte30
1947 scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
1949 #ifdef type_SimpleArraySignedByte32
1950 scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
1952 scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
1953 scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
1954 #ifdef type_SimpleArrayLongFloat
1955 scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
1957 #ifdef type_SimpleArrayComplexSingleFloat
1958 scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
1960 #ifdef type_SimpleArrayComplexDoubleFloat
1961 scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
1963 #ifdef type_SimpleArrayComplexLongFloat
1964 scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
1966 scavtab[type_ComplexString] = scav_boxed;
1967 scavtab[type_ComplexBitVector] = scav_boxed;
1968 scavtab[type_ComplexVector] = scav_boxed;
1969 scavtab[type_ComplexArray] = scav_boxed;
1970 scavtab[type_CodeHeader] = scav_code_header;
1971 scavtab[type_SimpleFunHeader] = scav_fun_header;
1972 scavtab[type_ClosureFunHeader] = scav_fun_header;
1973 scavtab[type_ReturnPcHeader] = scav_return_pc_header;
1975 scavtab[type_ClosureHeader] = scav_closure_header;
1976 scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
1978 scavtab[type_ClosureHeader] = scav_boxed;
1979 scavtab[type_FuncallableInstanceHeader] = scav_boxed;
1981 scavtab[type_ValueCellHeader] = scav_boxed;
1982 scavtab[type_SymbolHeader] = scav_boxed;
1983 scavtab[type_BaseChar] = scav_immediate;
1984 scavtab[type_Sap] = scav_unboxed;
1985 scavtab[type_UnboundMarker] = scav_immediate;
1986 scavtab[type_WeakPointer] = scav_weak_pointer;
1987 scavtab[type_InstanceHeader] = scav_boxed;
1989 scavtab[type_Fdefn] = scav_fdefn;
1991 scavtab[type_Fdefn] = scav_boxed;
1994 /* Transport Other Table */
1995 for (i = 0; i < 256; i++)
1996 transother[i] = trans_lose;
1998 transother[type_Bignum] = trans_unboxed;
1999 transother[type_Ratio] = trans_boxed;
2000 transother[type_SingleFloat] = trans_unboxed;
2001 transother[type_DoubleFloat] = trans_unboxed;
2002 #ifdef type_LongFloat
2003 transother[type_LongFloat] = trans_unboxed;
2005 transother[type_Complex] = trans_boxed;
2006 #ifdef type_ComplexSingleFloat
2007 transother[type_ComplexSingleFloat] = trans_unboxed;
2009 #ifdef type_ComplexDoubleFloat
2010 transother[type_ComplexDoubleFloat] = trans_unboxed;
2012 #ifdef type_ComplexLongFloat
2013 transother[type_ComplexLongFloat] = trans_unboxed;
2015 transother[type_SimpleArray] = trans_boxed;
2016 transother[type_SimpleString] = trans_string;
2017 transother[type_SimpleBitVector] = trans_vector_bit;
2018 transother[type_SimpleVector] = trans_vector;
2019 transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2020 transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2021 transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2022 transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2023 transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
2024 #ifdef type_SimpleArraySignedByte8
2025 transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
2027 #ifdef type_SimpleArraySignedByte16
2028 transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
2030 #ifdef type_SimpleArraySignedByte30
2031 transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
2033 #ifdef type_SimpleArraySignedByte32
2034 transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
2036 transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2037 transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
2038 #ifdef type_SimpleArrayLongFloat
2039 transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
2041 #ifdef type_SimpleArrayComplexSingleFloat
2042 transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
2044 #ifdef type_SimpleArrayComplexDoubleFloat
2045 transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
2047 #ifdef type_SimpleArrayComplexLongFloat
2048 transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
2050 transother[type_ComplexString] = trans_boxed;
2051 transother[type_ComplexBitVector] = trans_boxed;
2052 transother[type_ComplexVector] = trans_boxed;
2053 transother[type_ComplexArray] = trans_boxed;
2054 transother[type_CodeHeader] = trans_code_header;
2055 transother[type_SimpleFunHeader] = trans_fun_header;
2056 transother[type_ClosureFunHeader] = trans_fun_header;
2057 transother[type_ReturnPcHeader] = trans_return_pc_header;
2058 transother[type_ClosureHeader] = trans_boxed;
2059 transother[type_FuncallableInstanceHeader] = trans_boxed;
2060 transother[type_ValueCellHeader] = trans_boxed;
2061 transother[type_SymbolHeader] = trans_boxed;
2062 transother[type_BaseChar] = trans_immediate;
2063 transother[type_Sap] = trans_unboxed;
2064 transother[type_UnboundMarker] = trans_immediate;
2065 transother[type_WeakPointer] = trans_weak_pointer;
2066 transother[type_InstanceHeader] = trans_boxed;
2067 transother[type_Fdefn] = trans_boxed;
2071 for (i = 0; i < 256; i++)
2072 sizetab[i] = size_lose;
2074 for (i = 0; i < 32; i++) {
2075 sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
2076 sizetab[type_FunPointer|(i<<3)] = size_pointer;
2077 /* OtherImmediate0 */
2078 sizetab[type_ListPointer|(i<<3)] = size_pointer;
2079 sizetab[type_OddFixnum|(i<<3)] = size_immediate;
2080 sizetab[type_InstancePointer|(i<<3)] = size_pointer;
2081 /* OtherImmediate1 */
2082 sizetab[type_OtherPointer|(i<<3)] = size_pointer;
2085 sizetab[type_Bignum] = size_unboxed;
2086 sizetab[type_Ratio] = size_boxed;
2087 sizetab[type_SingleFloat] = size_unboxed;
2088 sizetab[type_DoubleFloat] = size_unboxed;
2089 #ifdef type_LongFloat
2090 sizetab[type_LongFloat] = size_unboxed;
2092 sizetab[type_Complex] = size_boxed;
2093 #ifdef type_ComplexSingleFloat
2094 sizetab[type_ComplexSingleFloat] = size_unboxed;
2096 #ifdef type_ComplexDoubleFloat
2097 sizetab[type_ComplexDoubleFloat] = size_unboxed;
2099 #ifdef type_ComplexLongFloat
2100 sizetab[type_ComplexLongFloat] = size_unboxed;
2102 sizetab[type_SimpleArray] = size_boxed;
2103 sizetab[type_SimpleString] = size_string;
2104 sizetab[type_SimpleBitVector] = size_vector_bit;
2105 sizetab[type_SimpleVector] = size_vector;
2106 sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2107 sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2108 sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2109 sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2110 sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
2111 #ifdef type_SimpleArraySignedByte8
2112 sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
2114 #ifdef type_SimpleArraySignedByte16
2115 sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
2117 #ifdef type_SimpleArraySignedByte30
2118 sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
2120 #ifdef type_SimpleArraySignedByte32
2121 sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
2123 sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2124 sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
2125 #ifdef type_SimpleArrayLongFloat
2126 sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
2128 #ifdef type_SimpleArrayComplexSingleFloat
2129 sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
2131 #ifdef type_SimpleArrayComplexDoubleFloat
2132 sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
2134 #ifdef type_SimpleArrayComplexLongFloat
2135 sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
2137 sizetab[type_ComplexString] = size_boxed;
2138 sizetab[type_ComplexBitVector] = size_boxed;
2139 sizetab[type_ComplexVector] = size_boxed;
2140 sizetab[type_ComplexArray] = size_boxed;
2141 sizetab[type_CodeHeader] = size_code_header;
2143 /* Shouldn't see these so just lose if it happens */
2144 sizetab[type_SimpleFunHeader] = size_function_header;
2145 sizetab[type_ClosureFunHeader] = size_function_header;
2146 sizetab[type_ReturnPcHeader] = size_return_pc_header;
2148 sizetab[type_ClosureHeader] = size_boxed;
2149 sizetab[type_FuncallableInstanceHeader] = size_boxed;
2150 sizetab[type_ValueCellHeader] = size_boxed;
2151 sizetab[type_SymbolHeader] = size_boxed;
2152 sizetab[type_BaseChar] = size_immediate;
2153 sizetab[type_Sap] = size_unboxed;
2154 sizetab[type_UnboundMarker] = size_immediate;
2155 sizetab[type_WeakPointer] = size_weak_pointer;
2156 sizetab[type_InstanceHeader] = size_boxed;
2157 sizetab[type_Fdefn] = size_boxed;
2160 /* noise to manipulate the gc trigger stuff */
2162 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2164 os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2167 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2169 if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2171 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2172 (unsigned int)dynamic_usage,
2173 (os_vm_address_t)dynamic_space_free_pointer
2174 - (os_vm_address_t)current_dynamic_space);
2177 else if (length < 0) {
2179 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2184 addr=os_round_up_to_page(addr);
2185 length=os_trunc_size_to_page(length);
2187 #if defined(SUNOS) || defined(SOLARIS)
2188 os_invalidate(addr,length);
2190 os_protect(addr, length, 0);
2193 current_auto_gc_trigger = (lispobj *)addr;
2196 void clear_auto_gc_trigger(void)
2198 if(current_auto_gc_trigger!=NULL){
2199 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2200 os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2201 os_vm_size_t length=
2202 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2204 os_validate(addr,length);
2206 os_protect((os_vm_address_t)current_dynamic_space,
2211 current_auto_gc_trigger = NULL;