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 = lowtag_of(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 = widetag_of(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 = lowtag_of(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 = widetag_of(header);
604 nwords = (sizetab[type])(pointer);
607 type = widetag_of(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 = widetag_of(first);
649 case SIMPLE_FUN_HEADER_WIDETAG:
650 case CLOSURE_FUN_HEADER_WIDETAG:
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(widetag_of(first) == CODE_HEADER_WIDETAG);
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(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
727 /* Calculate 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(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
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 (lowtag_of(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[widetag_of(*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) {
1210 (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
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);
1499 scav_vector_single_float(lispobj *where, lispobj object)
1501 struct vector *vector;
1504 vector = (struct vector *) where;
1505 length = fixnum_value(vector->length);
1506 nwords = CEILING(length + 2, 2);
1512 trans_vector_single_float(lispobj object)
1514 struct vector *vector;
1517 gc_assert(is_lisp_pointer(object));
1519 vector = (struct vector *) native_pointer(object);
1520 length = fixnum_value(vector->length);
1521 nwords = CEILING(length + 2, 2);
1523 return copy_object(object, nwords);
1527 size_vector_single_float(lispobj *where)
1529 struct vector *vector;
1532 vector = (struct vector *) where;
1533 length = fixnum_value(vector->length);
1534 nwords = CEILING(length + 2, 2);
1541 scav_vector_double_float(lispobj *where, lispobj object)
1543 struct vector *vector;
1546 vector = (struct vector *) where;
1547 length = fixnum_value(vector->length);
1548 nwords = CEILING(length * 2 + 2, 2);
1554 trans_vector_double_float(lispobj object)
1556 struct vector *vector;
1559 gc_assert(is_lisp_pointer(object));
1561 vector = (struct vector *) native_pointer(object);
1562 length = fixnum_value(vector->length);
1563 nwords = CEILING(length * 2 + 2, 2);
1565 return copy_object(object, nwords);
1569 size_vector_double_float(lispobj *where)
1571 struct vector *vector;
1574 vector = (struct vector *) where;
1575 length = fixnum_value(vector->length);
1576 nwords = CEILING(length * 2 + 2, 2);
1582 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1584 scav_vector_long_float(lispobj *where, lispobj object)
1586 struct vector *vector;
1589 vector = (struct vector *) where;
1590 length = fixnum_value(vector->length);
1592 nwords = CEILING(length * 4 + 2, 2);
1599 trans_vector_long_float(lispobj object)
1601 struct vector *vector;
1604 gc_assert(is_lisp_pointer(object));
1606 vector = (struct vector *) native_pointer(object);
1607 length = fixnum_value(vector->length);
1609 nwords = CEILING(length * 4 + 2, 2);
1612 return copy_object(object, nwords);
1616 size_vector_long_float(lispobj *where)
1618 struct vector *vector;
1621 vector = (struct vector *) where;
1622 length = fixnum_value(vector->length);
1624 nwords = CEILING(length * 4 + 2, 2);
1632 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1634 scav_vector_complex_single_float(lispobj *where, lispobj object)
1636 struct vector *vector;
1639 vector = (struct vector *) where;
1640 length = fixnum_value(vector->length);
1641 nwords = CEILING(length * 2 + 2, 2);
1647 trans_vector_complex_single_float(lispobj object)
1649 struct vector *vector;
1652 gc_assert(is_lisp_pointer(object));
1654 vector = (struct vector *) native_pointer(object);
1655 length = fixnum_value(vector->length);
1656 nwords = CEILING(length * 2 + 2, 2);
1658 return copy_object(object, nwords);
1662 size_vector_complex_single_float(lispobj *where)
1664 struct vector *vector;
1667 vector = (struct vector *) where;
1668 length = fixnum_value(vector->length);
1669 nwords = CEILING(length * 2 + 2, 2);
1675 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1677 scav_vector_complex_double_float(lispobj *where, lispobj object)
1679 struct vector *vector;
1682 vector = (struct vector *) where;
1683 length = fixnum_value(vector->length);
1684 nwords = CEILING(length * 4 + 2, 2);
1690 trans_vector_complex_double_float(lispobj object)
1692 struct vector *vector;
1695 gc_assert(is_lisp_pointer(object));
1697 vector = (struct vector *) native_pointer(object);
1698 length = fixnum_value(vector->length);
1699 nwords = CEILING(length * 4 + 2, 2);
1701 return copy_object(object, nwords);
1705 size_vector_complex_double_float(lispobj *where)
1707 struct vector *vector;
1710 vector = (struct vector *) where;
1711 length = fixnum_value(vector->length);
1712 nwords = CEILING(length * 4 + 2, 2);
1718 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1720 scav_vector_complex_long_float(lispobj *where, lispobj object)
1722 struct vector *vector;
1725 vector = (struct vector *) where;
1726 length = fixnum_value(vector->length);
1728 nwords = CEILING(length * 8 + 2, 2);
1735 trans_vector_complex_long_float(lispobj object)
1737 struct vector *vector;
1740 gc_assert(is_lisp_pointer(object));
1742 vector = (struct vector *) native_pointer(object);
1743 length = fixnum_value(vector->length);
1745 nwords = CEILING(length * 8 + 2, 2);
1748 return copy_object(object, nwords);
1752 size_vector_complex_long_float(lispobj *where)
1754 struct vector *vector;
1757 vector = (struct vector *) where;
1758 length = fixnum_value(vector->length);
1760 nwords = CEILING(length * 8 + 2, 2);
1770 #define WEAK_POINTER_NWORDS \
1771 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1774 scav_weak_pointer(lispobj *where, lispobj object)
1776 /* Do not let GC scavenge the value slot of the weak pointer */
1777 /* (that is why it is a weak pointer). Note: we could use */
1778 /* the scav_unboxed method here. */
1780 return WEAK_POINTER_NWORDS;
1784 trans_weak_pointer(lispobj object)
1787 struct weak_pointer *wp;
1789 gc_assert(is_lisp_pointer(object));
1791 #if defined(DEBUG_WEAK)
1792 printf("Transporting weak pointer from 0x%08x\n", object);
1795 /* Need to remember where all the weak pointers are that have */
1796 /* been transported so they can be fixed up in a post-GC pass. */
1798 copy = copy_object(object, WEAK_POINTER_NWORDS);
1799 wp = (struct weak_pointer *) native_pointer(copy);
1802 /* Push the weak pointer onto the list of weak pointers. */
1803 wp->next = LOW_WORD(weak_pointers);
1810 size_weak_pointer(lispobj *where)
1812 return WEAK_POINTER_NWORDS;
1815 void scan_weak_pointers(void)
1817 struct weak_pointer *wp;
1819 for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1820 wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1822 lispobj first, *first_pointer;
1826 #if defined(DEBUG_WEAK)
1827 printf("Weak pointer at 0x%p\n", wp);
1828 printf("Value: 0x%08x\n", (unsigned int) value);
1831 if (!(is_lisp_pointer(value) && from_space_p(value)))
1834 /* Now, we need to check if the object has been */
1835 /* forwarded. If it has been, the weak pointer is */
1836 /* still good and needs to be updated. Otherwise, the */
1837 /* weak pointer needs to be nil'ed out. */
1839 first_pointer = (lispobj *) native_pointer(value);
1840 first = *first_pointer;
1842 #if defined(DEBUG_WEAK)
1843 printf("First: 0x%08x\n", (unsigned long) first);
1846 if (is_lisp_pointer(first) && new_space_p(first))
1857 /* initialization */
1860 scav_lose(lispobj *where, lispobj object)
1862 fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n",
1863 (unsigned int) object, (unsigned long)where);
1869 trans_lose(lispobj object)
1871 fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
1872 (unsigned int)object);
1878 size_lose(lispobj *where)
1880 fprintf(stderr, "Size lossage. No size function for object at 0x%p\n",
1882 fprintf(stderr, "First word of object: 0x%08x\n",
1887 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1888 * precise generational GC is revived, it might have three. It would
1889 * be nice to share the scavtab[] data set up here, and perhaps other
1890 * things too, between all of them, rather than trying to maintain
1891 * multiple copies. -- WHN 2001-05-09 */
1897 /* scavenge table */
1898 for (i = 0; i < 256; i++)
1899 scavtab[i] = scav_lose;
1900 /* scavtab[i] = scav_immediate; */
1902 for (i = 0; i < 32; i++) {
1903 scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1904 scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
1905 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1906 scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
1907 scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1908 scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer;
1909 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1910 scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
1913 scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1914 scavtab[RATIO_WIDETAG] = scav_boxed;
1915 scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1916 scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1917 #ifdef LONG_FLOAT_WIDETAG
1918 scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1920 scavtab[COMPLEX_WIDETAG] = scav_boxed;
1921 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1922 scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1924 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1925 scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1927 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1928 scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1930 scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1931 scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
1932 scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1933 scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
1934 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1935 scav_vector_unsigned_byte_2;
1936 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1937 scav_vector_unsigned_byte_4;
1938 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1939 scav_vector_unsigned_byte_8;
1940 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1941 scav_vector_unsigned_byte_16;
1942 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1943 scav_vector_unsigned_byte_32;
1944 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1945 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1946 scav_vector_unsigned_byte_8;
1948 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1949 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1950 scav_vector_unsigned_byte_16;
1952 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1953 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
1954 scav_vector_unsigned_byte_32;
1956 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1957 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1958 scav_vector_unsigned_byte_32;
1960 scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
1961 scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
1962 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1963 scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
1965 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1966 scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
1967 scav_vector_complex_single_float;
1969 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1970 scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
1971 scav_vector_complex_double_float;
1973 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1974 scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
1975 scav_vector_complex_long_float;
1977 scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
1978 scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
1979 scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
1980 scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
1981 scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
1982 scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
1983 scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;
1984 scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
1986 scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
1987 scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
1989 scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
1990 scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
1992 scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
1993 scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
1994 scavtab[BASE_CHAR_WIDETAG] = scav_immediate;
1995 scavtab[SAP_WIDETAG] = scav_unboxed;
1996 scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
1997 scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
1998 scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
2000 scavtab[FDEFN_WIDETAG] = scav_fdefn;
2002 scavtab[FDEFN_WIDETAG] = scav_boxed;
2005 /* Transport Other Table */
2006 for (i = 0; i < 256; i++)
2007 transother[i] = trans_lose;
2009 transother[BIGNUM_WIDETAG] = trans_unboxed;
2010 transother[RATIO_WIDETAG] = trans_boxed;
2011 transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2012 transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2013 #ifdef LONG_FLOAT_WIDETAG
2014 transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2016 transother[COMPLEX_WIDETAG] = trans_boxed;
2017 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2018 transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2020 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2021 transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2023 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2024 transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2026 transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed;
2027 transother[SIMPLE_STRING_WIDETAG] = trans_string;
2028 transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2029 transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2030 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2031 trans_vector_unsigned_byte_2;
2032 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2033 trans_vector_unsigned_byte_4;
2034 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2035 trans_vector_unsigned_byte_8;
2036 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2037 trans_vector_unsigned_byte_16;
2038 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2039 trans_vector_unsigned_byte_32;
2040 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2041 transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2042 trans_vector_unsigned_byte_8;
2044 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2045 transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2046 trans_vector_unsigned_byte_16;
2048 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2049 transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2050 trans_vector_unsigned_byte_32;
2052 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2053 transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2054 trans_vector_unsigned_byte_32;
2056 transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2057 trans_vector_single_float;
2058 transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2059 trans_vector_double_float;
2060 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2061 transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2062 trans_vector_long_float;
2064 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2065 transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2066 trans_vector_complex_single_float;
2068 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2069 transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2070 trans_vector_complex_double_float;
2072 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2073 transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2074 trans_vector_complex_long_float;
2076 transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
2077 transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2078 transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2079 transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2080 transother[CODE_HEADER_WIDETAG] = trans_code_header;
2081 transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2082 transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header;
2083 transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2084 transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2085 transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2086 transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2087 transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2088 transother[BASE_CHAR_WIDETAG] = trans_immediate;
2089 transother[SAP_WIDETAG] = trans_unboxed;
2090 transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2091 transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2092 transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2093 transother[FDEFN_WIDETAG] = trans_boxed;
2097 for (i = 0; i < 256; i++)
2098 sizetab[i] = size_lose;
2100 for (i = 0; i < 32; i++) {
2101 sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2102 sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
2103 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2104 sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
2105 sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2106 sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
2107 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2108 sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
2111 sizetab[BIGNUM_WIDETAG] = size_unboxed;
2112 sizetab[RATIO_WIDETAG] = size_boxed;
2113 sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2114 sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2115 #ifdef LONG_FLOAT_WIDETAG
2116 sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2118 sizetab[COMPLEX_WIDETAG] = size_boxed;
2119 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2120 sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2122 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2123 sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2125 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2126 sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2128 sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2129 sizetab[SIMPLE_STRING_WIDETAG] = size_string;
2130 sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2131 sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2132 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2133 size_vector_unsigned_byte_2;
2134 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2135 size_vector_unsigned_byte_4;
2136 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2137 size_vector_unsigned_byte_8;
2138 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2139 size_vector_unsigned_byte_16;
2140 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2141 size_vector_unsigned_byte_32;
2142 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2143 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2144 size_vector_unsigned_byte_8;
2146 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2147 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2148 size_vector_unsigned_byte_16;
2150 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2151 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2152 size_vector_unsigned_byte_32;
2154 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2155 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2156 size_vector_unsigned_byte_32;
2158 sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2159 sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2160 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2161 sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2163 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2164 sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2165 size_vector_complex_single_float;
2167 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2168 sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2169 size_vector_complex_double_float;
2171 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2172 sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2173 size_vector_complex_long_float;
2175 sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
2176 sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2177 sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2178 sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2179 sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2181 /* Shouldn't see these so just lose if it happens */
2182 sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2183 sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header;
2184 sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2186 sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2187 sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2188 sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2189 sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2190 sizetab[BASE_CHAR_WIDETAG] = size_immediate;
2191 sizetab[SAP_WIDETAG] = size_unboxed;
2192 sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2193 sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2194 sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2195 sizetab[FDEFN_WIDETAG] = size_boxed;
2198 /* noise to manipulate the gc trigger stuff */
2200 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2202 os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2205 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2207 if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2209 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2210 (unsigned int)dynamic_usage,
2211 (os_vm_address_t)dynamic_space_free_pointer
2212 - (os_vm_address_t)current_dynamic_space);
2215 else if (length < 0) {
2217 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2222 addr=os_round_up_to_page(addr);
2223 length=os_trunc_size_to_page(length);
2225 #if defined(SUNOS) || defined(SOLARIS)
2226 os_invalidate(addr,length);
2228 os_protect(addr, length, 0);
2231 current_auto_gc_trigger = (lispobj *)addr;
2234 void clear_auto_gc_trigger(void)
2236 if(current_auto_gc_trigger!=NULL){
2237 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2238 os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2239 os_vm_size_t length=
2240 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2242 os_validate(addr,length);
2244 os_protect((os_vm_address_t)current_dynamic_space,
2249 current_auto_gc_trigger = NULL;