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<<N_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 LIST_POINTER_LOWTAG:
593 case INSTANCE_POINTER_LOWTAG:
594 printf("Don't know about instances yet!\n");
597 case FUN_POINTER_LOWTAG:
600 case OTHER_POINTER_LOWTAG:
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: Shouldn't this be defined in sbcl.h? */
624 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
626 static lispobj trans_fun_header(lispobj object);
627 static lispobj trans_boxed(lispobj object);
630 scav_fun_pointer(lispobj *where, lispobj object)
632 lispobj *first_pointer;
637 gc_assert(is_lisp_pointer(object));
639 /* object is a pointer into from space. Not a FP */
640 first_pointer = (lispobj *) native_pointer(object);
641 first = *first_pointer;
643 /* must transport object -- object may point */
644 /* to either a function header, a closure */
645 /* function header, or to a closure header. */
647 type = TypeOf(first);
649 case type_SimpleFunHeader:
650 case type_ClosureFunHeader:
651 copy = trans_fun_header(object);
654 copy = trans_boxed(object);
658 first = *first_pointer = copy;
660 gc_assert(is_lisp_pointer(first));
661 gc_assert(!from_space_p(first));
668 trans_code(struct code *code)
670 struct code *new_code;
671 lispobj first, l_code, l_new_code;
672 int nheader_words, ncode_words, nwords;
673 unsigned long displacement;
674 lispobj fheaderl, *prev_pointer;
676 #if defined(DEBUG_CODE_GC)
677 printf("\nTransporting code object located at 0x%08x.\n",
678 (unsigned long) code);
681 /* if object has already been transported, just return pointer */
682 first = code->header;
683 if (is_lisp_pointer(first) && new_space_p(first)) {
685 printf("Was already transported\n");
687 return (struct code *) native_pointer(first);
690 gc_assert(TypeOf(first) == type_CodeHeader);
692 /* prepare to transport the code vector */
693 l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
695 ncode_words = fixnum_value(code->code_size);
696 nheader_words = HeaderValue(code->header);
697 nwords = ncode_words + nheader_words;
698 nwords = CEILING(nwords, 2);
700 l_new_code = copy_object(l_code, nwords);
701 new_code = (struct code *) native_pointer(l_new_code);
703 displacement = l_new_code - l_code;
705 #if defined(DEBUG_CODE_GC)
706 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
707 (unsigned long) code, (unsigned long) new_code);
708 printf("Code object is %d words long.\n", nwords);
711 /* set forwarding pointer */
712 code->header = l_new_code;
714 /* set forwarding pointers for all the function headers in the */
715 /* code object. also fix all self pointers */
717 fheaderl = code->entry_points;
718 prev_pointer = &new_code->entry_points;
720 while (fheaderl != NIL) {
721 struct simple_fun *fheaderp, *nfheaderp;
724 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
725 gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
727 /* calcuate the new function pointer and the new */
728 /* function header */
729 nfheaderl = fheaderl + displacement;
730 nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
732 /* set forwarding pointer */
734 printf("fheaderp->header (at %x) <- %x\n",
735 &(fheaderp->header) , nfheaderl);
737 fheaderp->header = nfheaderl;
739 /* fix self pointer */
740 nfheaderp->self = nfheaderl;
742 *prev_pointer = nfheaderl;
744 fheaderl = fheaderp->next;
745 prev_pointer = &nfheaderp->next;
749 os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
750 ncode_words * sizeof(int));
756 scav_code_header(lispobj *where, lispobj object)
759 int nheader_words, ncode_words, nwords;
761 struct simple_fun *fheaderp;
763 code = (struct code *) where;
764 ncode_words = fixnum_value(code->code_size);
765 nheader_words = HeaderValue(object);
766 nwords = ncode_words + nheader_words;
767 nwords = CEILING(nwords, 2);
769 #if defined(DEBUG_CODE_GC)
770 printf("\nScavening code object at 0x%08x.\n",
771 (unsigned long) where);
772 printf("Code object is %d words long.\n", nwords);
773 printf("Scavenging boxed section of code data block (%d words).\n",
777 /* Scavenge the boxed section of the code data block */
778 scavenge(where + 1, nheader_words - 1);
780 /* Scavenge the boxed section of each function object in the */
781 /* code data block */
782 fheaderl = code->entry_points;
783 while (fheaderl != NIL) {
784 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
785 gc_assert(TypeOf(fheaderp->header) == type_SimpleFunHeader);
787 #if defined(DEBUG_CODE_GC)
788 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
789 (unsigned long) native_pointer(fheaderl));
791 scavenge(&fheaderp->name, 1);
792 scavenge(&fheaderp->arglist, 1);
793 scavenge(&fheaderp->type, 1);
795 fheaderl = fheaderp->next;
802 trans_code_header(lispobj object)
806 ncode = trans_code((struct code *) native_pointer(object));
807 return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
811 size_code_header(lispobj *where)
814 int nheader_words, ncode_words, nwords;
816 code = (struct code *) where;
818 ncode_words = fixnum_value(code->code_size);
819 nheader_words = HeaderValue(code->header);
820 nwords = ncode_words + nheader_words;
821 nwords = CEILING(nwords, 2);
828 scav_return_pc_header(lispobj *where, lispobj object)
830 fprintf(stderr, "GC lossage. Should not be scavenging a ");
831 fprintf(stderr, "Return PC Header.\n");
832 fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
838 trans_return_pc_header(lispobj object)
840 struct simple_fun *return_pc;
841 unsigned long offset;
842 struct code *code, *ncode;
844 return_pc = (struct simple_fun *) native_pointer(object);
845 offset = HeaderValue(return_pc->header) * 4 ;
847 /* Transport the whole code object */
848 code = (struct code *) ((unsigned long) return_pc - offset);
850 printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
852 ncode = trans_code(code);
853 if(object==0x304748d7) {
854 /* monitor_or_something(); */
856 ret= ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
858 printf("trans_return_pc_header returning %x\n",ret);
863 /* On the 386, closures hold a pointer to the raw address instead of
864 * the function object, so we can use CALL [$FDEFN+const] to invoke
865 * the function without loading it into a register. Given that code
866 * objects don't move, we don't need to update anything, but we do
867 * have to figure out that the function is still live. */
870 scav_closure_header(where, object)
871 lispobj *where, object;
873 struct closure *closure;
876 closure = (struct closure *)where;
877 fun = closure->fun - FUN_RAW_ADDR_OFFSET;
885 scav_fun_header(lispobj *where, lispobj object)
887 fprintf(stderr, "GC lossage. Should not be scavenging a ");
888 fprintf(stderr, "Function Header.\n");
889 fprintf(stderr, "where = 0x%p, object = 0x%08x",
890 where, (unsigned int) object);
896 trans_fun_header(lispobj object)
898 struct simple_fun *fheader;
899 unsigned long offset;
900 struct code *code, *ncode;
902 fheader = (struct simple_fun *) native_pointer(object);
903 offset = HeaderValue(fheader->header) * 4;
905 /* Transport the whole code object */
906 code = (struct code *) ((unsigned long) fheader - offset);
907 ncode = trans_code(code);
909 return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
917 scav_instance_pointer(lispobj *where, lispobj object)
919 lispobj *first_pointer;
921 /* object is a pointer into from space. Not a FP */
922 first_pointer = (lispobj *) native_pointer(object);
924 *where = *first_pointer = trans_boxed(object);
929 /* lists and conses */
931 static lispobj trans_list(lispobj object);
934 scav_list_pointer(lispobj *where, lispobj object)
936 lispobj first, *first_pointer;
938 gc_assert(is_lisp_pointer(object));
940 /* object is a pointer into from space. Not a FP. */
941 first_pointer = (lispobj *) native_pointer(object);
943 first = *first_pointer = trans_list(object);
945 gc_assert(is_lisp_pointer(first));
946 gc_assert(!from_space_p(first));
953 trans_list(lispobj object)
955 lispobj new_list_pointer;
956 struct cons *cons, *new_cons;
958 cons = (struct cons *) native_pointer(object);
960 /* ### Don't use copy_object here. */
961 new_list_pointer = copy_object(object, 2);
962 new_cons = (struct cons *) native_pointer(new_list_pointer);
964 /* Set forwarding pointer. */
965 cons->car = new_list_pointer;
967 /* Try to linearize the list in the cdr direction to help reduce */
971 lispobj cdr, new_cdr, first;
972 struct cons *cdr_cons, *new_cdr_cons;
976 if (lowtagof(cdr) != LIST_POINTER_LOWTAG ||
977 !from_space_p(cdr) ||
978 (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
979 && new_space_p(first)))
982 cdr_cons = (struct cons *) native_pointer(cdr);
984 /* ### Don't use copy_object here */
985 new_cdr = copy_object(cdr, 2);
986 new_cdr_cons = (struct cons *) native_pointer(new_cdr);
988 /* Set forwarding pointer */
989 cdr_cons->car = new_cdr;
991 /* Update the cdr of the last cons copied into new */
992 /* space to keep the newspace scavenge from having to */
994 new_cons->cdr = new_cdr;
997 new_cons = new_cdr_cons;
1000 return new_list_pointer;
1004 /* scavenging and transporting other pointers */
1007 scav_other_pointer(lispobj *where, lispobj object)
1009 lispobj first, *first_pointer;
1011 gc_assert(is_lisp_pointer(object));
1013 /* Object is a pointer into from space - not a FP */
1014 first_pointer = (lispobj *) native_pointer(object);
1015 first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
1017 gc_assert(is_lisp_pointer(first));
1018 gc_assert(!from_space_p(first));
1025 /* immediate, boxed, and unboxed objects */
1028 size_pointer(lispobj *where)
1034 scav_immediate(lispobj *where, lispobj object)
1040 trans_immediate(lispobj object)
1042 fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
1048 size_immediate(lispobj *where)
1055 scav_boxed(lispobj *where, lispobj object)
1061 trans_boxed(lispobj object)
1064 unsigned long length;
1066 gc_assert(is_lisp_pointer(object));
1068 header = *((lispobj *) native_pointer(object));
1069 length = HeaderValue(header) + 1;
1070 length = CEILING(length, 2);
1072 return copy_object(object, length);
1076 size_boxed(lispobj *where)
1079 unsigned long length;
1082 length = HeaderValue(header) + 1;
1083 length = CEILING(length, 2);
1088 /* Note: on the sparc we don't have to do anything special for fdefns, */
1089 /* 'cause the raw-addr has a function lowtag. */
1092 scav_fdefn(lispobj *where, lispobj object)
1094 struct fdefn *fdefn;
1096 fdefn = (struct fdefn *)where;
1098 if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
1099 == (char *)((unsigned long)(fdefn->raw_addr))) {
1100 scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
1102 (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
1103 return sizeof(struct fdefn) / sizeof(lispobj);
1111 scav_unboxed(lispobj *where, lispobj object)
1113 unsigned long length;
1115 length = HeaderValue(object) + 1;
1116 length = CEILING(length, 2);
1122 trans_unboxed(lispobj object)
1125 unsigned long length;
1128 gc_assert(is_lisp_pointer(object));
1130 header = *((lispobj *) native_pointer(object));
1131 length = HeaderValue(header) + 1;
1132 length = CEILING(length, 2);
1134 return copy_object(object, length);
1138 size_unboxed(lispobj *where)
1141 unsigned long length;
1144 length = HeaderValue(header) + 1;
1145 length = CEILING(length, 2);
1151 /* vector-like objects */
1153 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1156 scav_string(lispobj *where, lispobj object)
1158 struct vector *vector;
1161 /* NOTE: Strings contain one more byte of data than the length */
1162 /* slot indicates. */
1164 vector = (struct vector *) where;
1165 length = fixnum_value(vector->length) + 1;
1166 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1172 trans_string(lispobj object)
1174 struct vector *vector;
1177 gc_assert(is_lisp_pointer(object));
1179 /* NOTE: Strings contain one more byte of data than the length */
1180 /* slot indicates. */
1182 vector = (struct vector *) native_pointer(object);
1183 length = fixnum_value(vector->length) + 1;
1184 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1186 return copy_object(object, nwords);
1190 size_string(lispobj *where)
1192 struct vector *vector;
1195 /* NOTE: Strings contain one more byte of data than the length */
1196 /* slot indicates. */
1198 vector = (struct vector *) where;
1199 length = fixnum_value(vector->length) + 1;
1200 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1206 scav_vector(lispobj *where, lispobj object)
1208 if (HeaderValue(object) == subtype_VectorValidHashing)
1209 *where = (subtype_VectorMustRehash<<N_TYPE_BITS) | type_SimpleVector;
1216 trans_vector(lispobj object)
1218 struct vector *vector;
1221 gc_assert(is_lisp_pointer(object));
1223 vector = (struct vector *) native_pointer(object);
1225 length = fixnum_value(vector->length);
1226 nwords = CEILING(length + 2, 2);
1228 return copy_object(object, nwords);
1232 size_vector(lispobj *where)
1234 struct vector *vector;
1237 vector = (struct vector *) where;
1238 length = fixnum_value(vector->length);
1239 nwords = CEILING(length + 2, 2);
1246 scav_vector_bit(lispobj *where, lispobj object)
1248 struct vector *vector;
1251 vector = (struct vector *) where;
1252 length = fixnum_value(vector->length);
1253 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1259 trans_vector_bit(lispobj object)
1261 struct vector *vector;
1264 gc_assert(is_lisp_pointer(object));
1266 vector = (struct vector *) native_pointer(object);
1267 length = fixnum_value(vector->length);
1268 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1270 return copy_object(object, nwords);
1274 size_vector_bit(lispobj *where)
1276 struct vector *vector;
1279 vector = (struct vector *) where;
1280 length = fixnum_value(vector->length);
1281 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1288 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
1290 struct vector *vector;
1293 vector = (struct vector *) where;
1294 length = fixnum_value(vector->length);
1295 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1301 trans_vector_unsigned_byte_2(lispobj object)
1303 struct vector *vector;
1306 gc_assert(is_lisp_pointer(object));
1308 vector = (struct vector *) native_pointer(object);
1309 length = fixnum_value(vector->length);
1310 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1312 return copy_object(object, nwords);
1316 size_vector_unsigned_byte_2(lispobj *where)
1318 struct vector *vector;
1321 vector = (struct vector *) where;
1322 length = fixnum_value(vector->length);
1323 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1330 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1332 struct vector *vector;
1335 vector = (struct vector *) where;
1336 length = fixnum_value(vector->length);
1337 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1343 trans_vector_unsigned_byte_4(lispobj object)
1345 struct vector *vector;
1348 gc_assert(is_lisp_pointer(object));
1350 vector = (struct vector *) native_pointer(object);
1351 length = fixnum_value(vector->length);
1352 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1354 return copy_object(object, nwords);
1358 size_vector_unsigned_byte_4(lispobj *where)
1360 struct vector *vector;
1363 vector = (struct vector *) where;
1364 length = fixnum_value(vector->length);
1365 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1372 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1374 struct vector *vector;
1377 vector = (struct vector *) where;
1378 length = fixnum_value(vector->length);
1379 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1385 trans_vector_unsigned_byte_8(lispobj object)
1387 struct vector *vector;
1390 gc_assert(is_lisp_pointer(object));
1392 vector = (struct vector *) native_pointer(object);
1393 length = fixnum_value(vector->length);
1394 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1396 return copy_object(object, nwords);
1400 size_vector_unsigned_byte_8(lispobj *where)
1402 struct vector *vector;
1405 vector = (struct vector *) where;
1406 length = fixnum_value(vector->length);
1407 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1414 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1416 struct vector *vector;
1419 vector = (struct vector *) where;
1420 length = fixnum_value(vector->length);
1421 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1427 trans_vector_unsigned_byte_16(lispobj object)
1429 struct vector *vector;
1432 gc_assert(is_lisp_pointer(object));
1434 vector = (struct vector *) native_pointer(object);
1435 length = fixnum_value(vector->length);
1436 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1438 return copy_object(object, nwords);
1442 size_vector_unsigned_byte_16(lispobj *where)
1444 struct vector *vector;
1447 vector = (struct vector *) where;
1448 length = fixnum_value(vector->length);
1449 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1456 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1458 struct vector *vector;
1461 vector = (struct vector *) where;
1462 length = fixnum_value(vector->length);
1463 nwords = CEILING(length + 2, 2);
1469 trans_vector_unsigned_byte_32(lispobj object)
1471 struct vector *vector;
1474 gc_assert(is_lisp_pointer(object));
1476 vector = (struct vector *) native_pointer(object);
1477 length = fixnum_value(vector->length);
1478 nwords = CEILING(length + 2, 2);
1480 return copy_object(object, nwords);
1484 size_vector_unsigned_byte_32(lispobj *where)
1486 struct vector *vector;
1489 vector = (struct vector *) where;
1490 length = fixnum_value(vector->length);
1491 nwords = CEILING(length + 2, 2);
1498 scav_vector_single_float(lispobj *where, lispobj object)
1500 struct vector *vector;
1503 vector = (struct vector *) where;
1504 length = fixnum_value(vector->length);
1505 nwords = CEILING(length + 2, 2);
1511 trans_vector_single_float(lispobj object)
1513 struct vector *vector;
1516 gc_assert(is_lisp_pointer(object));
1518 vector = (struct vector *) native_pointer(object);
1519 length = fixnum_value(vector->length);
1520 nwords = CEILING(length + 2, 2);
1522 return copy_object(object, nwords);
1526 size_vector_single_float(lispobj *where)
1528 struct vector *vector;
1531 vector = (struct vector *) where;
1532 length = fixnum_value(vector->length);
1533 nwords = CEILING(length + 2, 2);
1540 scav_vector_double_float(lispobj *where, lispobj object)
1542 struct vector *vector;
1545 vector = (struct vector *) where;
1546 length = fixnum_value(vector->length);
1547 nwords = CEILING(length * 2 + 2, 2);
1553 trans_vector_double_float(lispobj object)
1555 struct vector *vector;
1558 gc_assert(is_lisp_pointer(object));
1560 vector = (struct vector *) native_pointer(object);
1561 length = fixnum_value(vector->length);
1562 nwords = CEILING(length * 2 + 2, 2);
1564 return copy_object(object, nwords);
1568 size_vector_double_float(lispobj *where)
1570 struct vector *vector;
1573 vector = (struct vector *) where;
1574 length = fixnum_value(vector->length);
1575 nwords = CEILING(length * 2 + 2, 2);
1581 #ifdef type_SimpleArrayLongFloat
1583 scav_vector_long_float(lispobj *where, lispobj object)
1585 struct vector *vector;
1588 vector = (struct vector *) where;
1589 length = fixnum_value(vector->length);
1591 nwords = CEILING(length * 4 + 2, 2);
1598 trans_vector_long_float(lispobj object)
1600 struct vector *vector;
1603 gc_assert(is_lisp_pointer(object));
1605 vector = (struct vector *) native_pointer(object);
1606 length = fixnum_value(vector->length);
1608 nwords = CEILING(length * 4 + 2, 2);
1611 return copy_object(object, nwords);
1615 size_vector_long_float(lispobj *where)
1617 struct vector *vector;
1620 vector = (struct vector *) where;
1621 length = fixnum_value(vector->length);
1623 nwords = CEILING(length * 4 + 2, 2);
1631 #ifdef type_SimpleArrayComplexSingleFloat
1633 scav_vector_complex_single_float(lispobj *where, lispobj object)
1635 struct vector *vector;
1638 vector = (struct vector *) where;
1639 length = fixnum_value(vector->length);
1640 nwords = CEILING(length * 2 + 2, 2);
1646 trans_vector_complex_single_float(lispobj object)
1648 struct vector *vector;
1651 gc_assert(is_lisp_pointer(object));
1653 vector = (struct vector *) native_pointer(object);
1654 length = fixnum_value(vector->length);
1655 nwords = CEILING(length * 2 + 2, 2);
1657 return copy_object(object, nwords);
1661 size_vector_complex_single_float(lispobj *where)
1663 struct vector *vector;
1666 vector = (struct vector *) where;
1667 length = fixnum_value(vector->length);
1668 nwords = CEILING(length * 2 + 2, 2);
1674 #ifdef type_SimpleArrayComplexDoubleFloat
1676 scav_vector_complex_double_float(lispobj *where, lispobj object)
1678 struct vector *vector;
1681 vector = (struct vector *) where;
1682 length = fixnum_value(vector->length);
1683 nwords = CEILING(length * 4 + 2, 2);
1689 trans_vector_complex_double_float(lispobj object)
1691 struct vector *vector;
1694 gc_assert(is_lisp_pointer(object));
1696 vector = (struct vector *) native_pointer(object);
1697 length = fixnum_value(vector->length);
1698 nwords = CEILING(length * 4 + 2, 2);
1700 return copy_object(object, nwords);
1704 size_vector_complex_double_float(lispobj *where)
1706 struct vector *vector;
1709 vector = (struct vector *) where;
1710 length = fixnum_value(vector->length);
1711 nwords = CEILING(length * 4 + 2, 2);
1717 #ifdef type_SimpleArrayComplexLongFloat
1719 scav_vector_complex_long_float(lispobj *where, lispobj object)
1721 struct vector *vector;
1724 vector = (struct vector *) where;
1725 length = fixnum_value(vector->length);
1727 nwords = CEILING(length * 8 + 2, 2);
1734 trans_vector_complex_long_float(lispobj object)
1736 struct vector *vector;
1739 gc_assert(is_lisp_pointer(object));
1741 vector = (struct vector *) native_pointer(object);
1742 length = fixnum_value(vector->length);
1744 nwords = CEILING(length * 8 + 2, 2);
1747 return copy_object(object, nwords);
1751 size_vector_complex_long_float(lispobj *where)
1753 struct vector *vector;
1756 vector = (struct vector *) where;
1757 length = fixnum_value(vector->length);
1759 nwords = CEILING(length * 8 + 2, 2);
1769 #define WEAK_POINTER_NWORDS \
1770 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1773 scav_weak_pointer(lispobj *where, lispobj object)
1775 /* Do not let GC scavenge the value slot of the weak pointer */
1776 /* (that is why it is a weak pointer). Note: we could use */
1777 /* the scav_unboxed method here. */
1779 return WEAK_POINTER_NWORDS;
1783 trans_weak_pointer(lispobj object)
1786 struct weak_pointer *wp;
1788 gc_assert(is_lisp_pointer(object));
1790 #if defined(DEBUG_WEAK)
1791 printf("Transporting weak pointer from 0x%08x\n", object);
1794 /* Need to remember where all the weak pointers are that have */
1795 /* been transported so they can be fixed up in a post-GC pass. */
1797 copy = copy_object(object, WEAK_POINTER_NWORDS);
1798 wp = (struct weak_pointer *) native_pointer(copy);
1801 /* Push the weak pointer onto the list of weak pointers. */
1802 wp->next = LOW_WORD(weak_pointers);
1809 size_weak_pointer(lispobj *where)
1811 return WEAK_POINTER_NWORDS;
1814 void scan_weak_pointers(void)
1816 struct weak_pointer *wp;
1818 for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1819 wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1821 lispobj first, *first_pointer;
1825 #if defined(DEBUG_WEAK)
1826 printf("Weak pointer at 0x%p\n", wp);
1827 printf("Value: 0x%08x\n", (unsigned int) value);
1830 if (!(is_lisp_pointer(value) && from_space_p(value)))
1833 /* Now, we need to check if the object has been */
1834 /* forwarded. If it has been, the weak pointer is */
1835 /* still good and needs to be updated. Otherwise, the */
1836 /* weak pointer needs to be nil'ed out. */
1838 first_pointer = (lispobj *) native_pointer(value);
1839 first = *first_pointer;
1841 #if defined(DEBUG_WEAK)
1842 printf("First: 0x%08x\n", (unsigned long) first);
1845 if (is_lisp_pointer(first) && new_space_p(first))
1856 /* initialization */
1859 scav_lose(lispobj *where, lispobj object)
1861 fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n",
1862 (unsigned int) object, (unsigned long)where);
1868 trans_lose(lispobj object)
1870 fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
1871 (unsigned int)object);
1877 size_lose(lispobj *where)
1879 fprintf(stderr, "Size lossage. No size function for object at 0x%p\n",
1881 fprintf(stderr, "First word of object: 0x%08x\n",
1886 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1887 * precise generational GC is revived, it might have three. It would
1888 * be nice to share the scavtab[] data set up here, and perhaps other
1889 * things too, between all of them, rather than trying to maintain
1890 * multiple copies. -- WHN 2001-05-09 */
1896 /* scavenge table */
1897 for (i = 0; i < 256; i++)
1898 scavtab[i] = scav_lose;
1899 /* scavtab[i] = scav_immediate; */
1901 for (i = 0; i < 32; i++) {
1902 scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1903 scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
1904 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1905 scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
1906 scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1907 scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer;
1908 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1909 scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
1912 scavtab[type_Bignum] = scav_unboxed;
1913 scavtab[type_Ratio] = scav_boxed;
1914 scavtab[type_SingleFloat] = scav_unboxed;
1915 scavtab[type_DoubleFloat] = scav_unboxed;
1916 #ifdef type_LongFloat
1917 scavtab[type_LongFloat] = scav_unboxed;
1919 scavtab[type_Complex] = scav_boxed;
1920 #ifdef type_ComplexSingleFloat
1921 scavtab[type_ComplexSingleFloat] = scav_unboxed;
1923 #ifdef type_ComplexDoubleFloat
1924 scavtab[type_ComplexDoubleFloat] = scav_unboxed;
1926 #ifdef type_ComplexLongFloat
1927 scavtab[type_ComplexLongFloat] = scav_unboxed;
1929 scavtab[type_SimpleArray] = scav_boxed;
1930 scavtab[type_SimpleString] = scav_string;
1931 scavtab[type_SimpleBitVector] = scav_vector_bit;
1932 scavtab[type_SimpleVector] = scav_vector;
1933 scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
1934 scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
1935 scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
1936 scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
1937 scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
1938 #ifdef type_SimpleArraySignedByte8
1939 scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
1941 #ifdef type_SimpleArraySignedByte16
1942 scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
1944 #ifdef type_SimpleArraySignedByte30
1945 scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
1947 #ifdef type_SimpleArraySignedByte32
1948 scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
1950 scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
1951 scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
1952 #ifdef type_SimpleArrayLongFloat
1953 scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
1955 #ifdef type_SimpleArrayComplexSingleFloat
1956 scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
1958 #ifdef type_SimpleArrayComplexDoubleFloat
1959 scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
1961 #ifdef type_SimpleArrayComplexLongFloat
1962 scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
1964 scavtab[type_ComplexString] = scav_boxed;
1965 scavtab[type_ComplexBitVector] = scav_boxed;
1966 scavtab[type_ComplexVector] = scav_boxed;
1967 scavtab[type_ComplexArray] = scav_boxed;
1968 scavtab[type_CodeHeader] = scav_code_header;
1969 scavtab[type_SimpleFunHeader] = scav_fun_header;
1970 scavtab[type_ClosureFunHeader] = scav_fun_header;
1971 scavtab[type_ReturnPcHeader] = scav_return_pc_header;
1973 scavtab[type_ClosureHeader] = scav_closure_header;
1974 scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
1976 scavtab[type_ClosureHeader] = scav_boxed;
1977 scavtab[type_FuncallableInstanceHeader] = scav_boxed;
1979 scavtab[type_ValueCellHeader] = scav_boxed;
1980 scavtab[type_SymbolHeader] = scav_boxed;
1981 scavtab[type_BaseChar] = scav_immediate;
1982 scavtab[type_Sap] = scav_unboxed;
1983 scavtab[type_UnboundMarker] = scav_immediate;
1984 scavtab[type_WeakPointer] = scav_weak_pointer;
1985 scavtab[type_InstanceHeader] = scav_boxed;
1987 scavtab[type_Fdefn] = scav_fdefn;
1989 scavtab[type_Fdefn] = scav_boxed;
1992 /* Transport Other Table */
1993 for (i = 0; i < 256; i++)
1994 transother[i] = trans_lose;
1996 transother[type_Bignum] = trans_unboxed;
1997 transother[type_Ratio] = trans_boxed;
1998 transother[type_SingleFloat] = trans_unboxed;
1999 transother[type_DoubleFloat] = trans_unboxed;
2000 #ifdef type_LongFloat
2001 transother[type_LongFloat] = trans_unboxed;
2003 transother[type_Complex] = trans_boxed;
2004 #ifdef type_ComplexSingleFloat
2005 transother[type_ComplexSingleFloat] = trans_unboxed;
2007 #ifdef type_ComplexDoubleFloat
2008 transother[type_ComplexDoubleFloat] = trans_unboxed;
2010 #ifdef type_ComplexLongFloat
2011 transother[type_ComplexLongFloat] = trans_unboxed;
2013 transother[type_SimpleArray] = trans_boxed;
2014 transother[type_SimpleString] = trans_string;
2015 transother[type_SimpleBitVector] = trans_vector_bit;
2016 transother[type_SimpleVector] = trans_vector;
2017 transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2018 transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2019 transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2020 transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2021 transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
2022 #ifdef type_SimpleArraySignedByte8
2023 transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
2025 #ifdef type_SimpleArraySignedByte16
2026 transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
2028 #ifdef type_SimpleArraySignedByte30
2029 transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
2031 #ifdef type_SimpleArraySignedByte32
2032 transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
2034 transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2035 transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
2036 #ifdef type_SimpleArrayLongFloat
2037 transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
2039 #ifdef type_SimpleArrayComplexSingleFloat
2040 transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
2042 #ifdef type_SimpleArrayComplexDoubleFloat
2043 transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
2045 #ifdef type_SimpleArrayComplexLongFloat
2046 transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
2048 transother[type_ComplexString] = trans_boxed;
2049 transother[type_ComplexBitVector] = trans_boxed;
2050 transother[type_ComplexVector] = trans_boxed;
2051 transother[type_ComplexArray] = trans_boxed;
2052 transother[type_CodeHeader] = trans_code_header;
2053 transother[type_SimpleFunHeader] = trans_fun_header;
2054 transother[type_ClosureFunHeader] = trans_fun_header;
2055 transother[type_ReturnPcHeader] = trans_return_pc_header;
2056 transother[type_ClosureHeader] = trans_boxed;
2057 transother[type_FuncallableInstanceHeader] = trans_boxed;
2058 transother[type_ValueCellHeader] = trans_boxed;
2059 transother[type_SymbolHeader] = trans_boxed;
2060 transother[type_BaseChar] = trans_immediate;
2061 transother[type_Sap] = trans_unboxed;
2062 transother[type_UnboundMarker] = trans_immediate;
2063 transother[type_WeakPointer] = trans_weak_pointer;
2064 transother[type_InstanceHeader] = trans_boxed;
2065 transother[type_Fdefn] = trans_boxed;
2069 for (i = 0; i < 256; i++)
2070 sizetab[i] = size_lose;
2072 for (i = 0; i < 32; i++) {
2073 sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2074 sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
2075 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2076 sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
2077 sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2078 sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
2079 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2080 sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
2083 sizetab[type_Bignum] = size_unboxed;
2084 sizetab[type_Ratio] = size_boxed;
2085 sizetab[type_SingleFloat] = size_unboxed;
2086 sizetab[type_DoubleFloat] = size_unboxed;
2087 #ifdef type_LongFloat
2088 sizetab[type_LongFloat] = size_unboxed;
2090 sizetab[type_Complex] = size_boxed;
2091 #ifdef type_ComplexSingleFloat
2092 sizetab[type_ComplexSingleFloat] = size_unboxed;
2094 #ifdef type_ComplexDoubleFloat
2095 sizetab[type_ComplexDoubleFloat] = size_unboxed;
2097 #ifdef type_ComplexLongFloat
2098 sizetab[type_ComplexLongFloat] = size_unboxed;
2100 sizetab[type_SimpleArray] = size_boxed;
2101 sizetab[type_SimpleString] = size_string;
2102 sizetab[type_SimpleBitVector] = size_vector_bit;
2103 sizetab[type_SimpleVector] = size_vector;
2104 sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2105 sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2106 sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2107 sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2108 sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
2109 #ifdef type_SimpleArraySignedByte8
2110 sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
2112 #ifdef type_SimpleArraySignedByte16
2113 sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
2115 #ifdef type_SimpleArraySignedByte30
2116 sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
2118 #ifdef type_SimpleArraySignedByte32
2119 sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
2121 sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2122 sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
2123 #ifdef type_SimpleArrayLongFloat
2124 sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
2126 #ifdef type_SimpleArrayComplexSingleFloat
2127 sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
2129 #ifdef type_SimpleArrayComplexDoubleFloat
2130 sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
2132 #ifdef type_SimpleArrayComplexLongFloat
2133 sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
2135 sizetab[type_ComplexString] = size_boxed;
2136 sizetab[type_ComplexBitVector] = size_boxed;
2137 sizetab[type_ComplexVector] = size_boxed;
2138 sizetab[type_ComplexArray] = size_boxed;
2139 sizetab[type_CodeHeader] = size_code_header;
2141 /* Shouldn't see these so just lose if it happens */
2142 sizetab[type_SimpleFunHeader] = size_function_header;
2143 sizetab[type_ClosureFunHeader] = size_function_header;
2144 sizetab[type_ReturnPcHeader] = size_return_pc_header;
2146 sizetab[type_ClosureHeader] = size_boxed;
2147 sizetab[type_FuncallableInstanceHeader] = size_boxed;
2148 sizetab[type_ValueCellHeader] = size_boxed;
2149 sizetab[type_SymbolHeader] = size_boxed;
2150 sizetab[type_BaseChar] = size_immediate;
2151 sizetab[type_Sap] = size_unboxed;
2152 sizetab[type_UnboundMarker] = size_immediate;
2153 sizetab[type_WeakPointer] = size_weak_pointer;
2154 sizetab[type_InstanceHeader] = size_boxed;
2155 sizetab[type_Fdefn] = size_boxed;
2158 /* noise to manipulate the gc trigger stuff */
2160 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2162 os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2165 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2167 if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2169 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2170 (unsigned int)dynamic_usage,
2171 (os_vm_address_t)dynamic_space_free_pointer
2172 - (os_vm_address_t)current_dynamic_space);
2175 else if (length < 0) {
2177 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2182 addr=os_round_up_to_page(addr);
2183 length=os_trunc_size_to_page(length);
2185 #if defined(SUNOS) || defined(SOLARIS)
2186 os_invalidate(addr,length);
2188 os_protect(addr, length, 0);
2191 current_auto_gc_trigger = (lispobj *)addr;
2194 void clear_auto_gc_trigger(void)
2196 if(current_auto_gc_trigger!=NULL){
2197 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2198 os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2199 os_vm_size_t length=
2200 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2202 os_validate(addr,length);
2204 os_protect((os_vm_address_t)current_dynamic_space,
2209 current_auto_gc_trigger = NULL;