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? */
32 #define DEBUG_SPACE_PREDICATES
34 #define DEBUG_SPACE_PREDICATES
35 #define DEBUG_SCAVENGE_VERBOSE
36 #define DEBUG_COPY_VERBOSE
40 static lispobj *from_space;
41 static lispobj *from_space_free_pointer;
43 static lispobj *new_space;
44 static lispobj *new_space_free_pointer;
46 static int (*scavtab[256])(lispobj *where, lispobj object);
47 static lispobj (*transother[256])(lispobj object);
48 static int (*sizetab[256])(lispobj *where);
50 static struct weak_pointer *weak_pointers;
52 static void scavenge(lispobj *start, u32 nwords);
53 static void scavenge_newspace(void);
54 static void scavenge_interrupt_contexts(void);
55 static void scan_weak_pointers(void);
56 static int scav_lose(lispobj *where, lispobj object);
58 #define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
62 #define gc_assert(ex) do { \
63 if (!(ex)) gc_abort(); \
69 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
74 #if defined(DEBUG_SPACE_PREDICATES)
77 from_space_p(lispobj object)
81 /* this can be called for untagged pointers as well as for
82 descriptors, so this assertion's not applicable
83 gc_assert(is_lisp_pointer(object));
85 ptr = (lispobj *) native_pointer(object);
87 return ((from_space <= ptr) &&
88 (ptr < from_space_free_pointer));
92 new_space_p(lispobj object)
96 gc_assert(is_lisp_pointer(object));
98 ptr = (lispobj *) native_pointer(object);
100 return ((new_space <= ptr) &&
101 (ptr < new_space_free_pointer));
106 #define from_space_p(ptr) \
107 ((from_space <= ((lispobj *) ptr)) && \
108 (((lispobj *) ptr) < from_space_free_pointer))
110 #define new_space_p(ptr) \
111 ((new_space <= ((lispobj *) ptr)) && \
112 (((lispobj *) ptr) < new_space_free_pointer))
117 /* copying objects */
120 copy_object(lispobj object, int nwords)
124 lispobj *source, *dest;
126 gc_assert(is_lisp_pointer(object));
127 gc_assert(from_space_p(object));
128 gc_assert((nwords & 0x01) == 0);
130 /* get tag of object */
131 tag = lowtag_of(object);
134 new = new_space_free_pointer;
135 new_space_free_pointer += nwords;
138 source = (lispobj *) native_pointer(object);
140 #ifdef DEBUG_COPY_VERBOSE
141 fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new);
144 /* copy the object */
152 /* return lisp pointer of new object */
153 return (lispobj)(LOW_WORD(new) | tag);
157 /* collecting garbage */
161 tv_diff(struct timeval *x, struct timeval *y)
163 return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
164 ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
168 #define BYTES_ZERO_BEFORE_END (1<<12)
173 #define U32 unsigned long
178 U32 *ptr = (U32 *)current_control_stack_pointer;
184 } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
189 } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
196 /* Note: The generic GC interface we're implementing passes us a
197 * last_generation argument. That's meaningless for us, since we're
198 * not a generational GC. So we ignore it. */
200 collect_garbage(unsigned ignore)
203 struct timeval start_tv, stop_tv;
204 struct rusage start_rusage, stop_rusage;
205 double real_time, system_time, user_time;
206 double percent_retained, gc_rate;
207 unsigned long size_discarded;
208 unsigned long size_retained;
210 lispobj *current_static_space_free_pointer;
211 unsigned long static_space_size;
212 unsigned long control_stack_size, binding_stack_size;
216 printf("[Collecting garbage ... \n");
218 getrusage(RUSAGE_SELF, &start_rusage);
219 gettimeofday(&start_tv, (struct timezone *) 0);
223 sigaddset_blockable(&tmp);
224 sigprocmask(SIG_BLOCK, &tmp, &old);
226 current_static_space_free_pointer =
227 (lispobj *) ((unsigned long)
228 SymbolValue(STATIC_SPACE_FREE_POINTER));
231 /* Set up from space and new space pointers. */
233 from_space = current_dynamic_space;
234 from_space_free_pointer = dynamic_space_free_pointer;
237 fprintf(stderr,"from_space = %lx\n",
238 (unsigned long) current_dynamic_space);
240 if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START)
241 new_space = (lispobj *)DYNAMIC_1_SPACE_START;
242 else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START)
243 new_space = (lispobj *) DYNAMIC_0_SPACE_START;
245 lose("GC lossage. Current dynamic space is bogus!\n");
247 new_space_free_pointer = new_space;
249 /* at one time we had the bright idea of using mprotect() to
250 * hide the semispace that we're not using at the moment, so
251 * we'd see immediately if anyone had a pointer to it.
252 * Unfortunately, if we gc during a call to an assembler
253 * routine with a "raw" return style, at least on PPC we are
254 * expected to return into oldspace because we can't easily
255 * update the link register - it's not tagged, and we can't do
256 * it as an offset of reg_CODE because the calling routine
257 * might be nowhere near our code vector. We hope that we
258 * don't run very far in oldspace before it catapults us into
259 * newspace by either calling something else or returning
263 os_protect(new_space,DYNAMIC_SPACE_SIZE,OS_VM_PROT_ALL);
266 /* Initialize the weak pointer list. */
267 weak_pointers = (struct weak_pointer *) NULL;
270 /* Scavenge all of the roots. */
272 printf("Scavenging interrupt contexts ...\n");
274 scavenge_interrupt_contexts();
277 printf("Scavenging interrupt handlers (%d bytes) ...\n",
278 (int)sizeof(interrupt_handlers));
280 scavenge((lispobj *) interrupt_handlers,
281 sizeof(interrupt_handlers) / sizeof(lispobj));
283 /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
285 current_control_stack_pointer-
286 (lispobj *)CONTROL_STACK_START;
288 printf("Scavenging the control stack at %p (%ld words) ...\n",
289 ((lispobj *)CONTROL_STACK_START),
292 scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
296 current_binding_stack_pointer -
297 (lispobj *)BINDING_STACK_START;
299 printf("Scavenging the binding stack %x - %x (%d words) ...\n",
300 BINDING_STACK_START,current_binding_stack_pointer,
301 (int)(binding_stack_size));
303 scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
306 current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
308 printf("Scavenging static space %x - %x (%d words) ...\n",
309 STATIC_SPACE_START,current_static_space_free_pointer,
310 (int)(static_space_size));
312 scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
314 /* Scavenge newspace. */
316 printf("Scavenging new space (%d bytes) ...\n",
317 (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
322 #if defined(DEBUG_PRINT_GARBAGE)
323 print_garbage(from_space, from_space_free_pointer);
326 /* Scan the weak pointers. */
328 printf("Scanning weak pointers ...\n");
330 scan_weak_pointers();
335 printf("Flipping spaces ...\n");
338 os_zero((os_vm_address_t) current_dynamic_space,
339 (os_vm_size_t) DYNAMIC_SPACE_SIZE);
341 current_dynamic_space = new_space;
342 dynamic_space_free_pointer = new_space_free_pointer;
345 size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
346 size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
351 printf("Zeroing empty part of control stack ...\n");
355 sigprocmask(SIG_SETMASK, &old, 0);
359 gettimeofday(&stop_tv, (struct timezone *) 0);
360 getrusage(RUSAGE_SELF, &stop_rusage);
364 percent_retained = (((float) size_retained) /
365 ((float) size_discarded)) * 100.0;
367 printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
368 size_retained, size_discarded, percent_retained);
370 real_time = tv_diff(&stop_tv, &start_tv);
371 user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
372 system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
375 printf("Statistics:\n");
376 printf("%10.2f sec of real time\n", real_time);
377 printf("%10.2f sec of user time,\n", user_time);
378 printf("%10.2f sec of system time.\n", system_time);
380 printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
381 real_time, user_time, system_time);
384 gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
386 printf("%10.2f M bytes/sec collected.\n", gc_rate);
388 /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */
391 /* see comment above about mprotecting oldspace */
393 /* zero the from space now, to make it easier to find stale
396 /* pray that both dynamic spaces are the same size ... */
397 memset(from_space,(DYNAMIC_0_SPACE_END-DYNAMIC_0_SPACE_START-1),0);
398 os_protect(from_space,DYNAMIC_SPACE_SIZE,0); /* write-protect */
406 scavenge(lispobj *start, u32 nwords)
410 int type, words_scavenged;
413 type = widetag_of(object);
415 #if defined(DEBUG_SCAVENGE_VERBOSE)
416 fprintf(stderr,"Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
417 (unsigned long) start, (unsigned long) object, type);
420 if (is_lisp_pointer(object)) {
421 /* It be a pointer. */
422 if (from_space_p(object)) {
423 /* It currently points to old space. Check for a */
424 /* forwarding pointer. */
427 first_word = *((lispobj *)native_pointer(object));
428 if (is_lisp_pointer(first_word) &&
429 new_space_p(first_word)) {
430 /* Yep, there be a forwarding pointer. */
435 /* Scavenge that pointer. */
436 words_scavenged = (scavtab[type])(start, object);
440 /* It points somewhere other than oldspace. Leave */
445 else if (nwords==1) {
446 /* there are some situations where an
447 other-immediate may end up in a descriptor
448 register. I'm not sure whether this is
449 supposed to happen, but if it does then we
450 don't want to (a) barf or (b) scavenge over the
451 data-block, because there isn't one. So, if
452 we're checking a single word and it's anything
453 other than a pointer, just hush it up */
456 if ((scavtab[type]==scav_lose) ||
457 (((scavtab[type])(start,object))>1)) {
458 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",
462 else if ((object & 3) == 0) {
463 /* It's a fixnum. Real easy. */
467 /* It's some random header object. */
468 words_scavenged = (scavtab[type])(start, object);
472 start += words_scavenged;
473 nwords -= words_scavenged;
475 gc_assert(nwords == 0);
479 scavenge_newspace(void)
481 lispobj *here, *next;
484 while (here < new_space_free_pointer) {
485 /* printf("here=%lx, new_space_free_pointer=%lx\n",
486 here,new_space_free_pointer); */
487 next = new_space_free_pointer;
488 scavenge(here, next - here);
491 /* printf("done with newspace\n"); */
494 /* scavenging interrupt contexts */
496 static int boxed_registers[] = BOXED_REGISTERS;
499 scavenge_interrupt_context(os_context_t *context)
504 unsigned long lip_offset;
505 int lip_register_pair;
507 unsigned long pc_code_offset;
508 #ifdef ARCH_HAS_LINK_REGISTER
509 unsigned long lr_code_offset;
511 #ifdef ARCH_HAS_NPC_REGISTER
512 unsigned long npc_code_offset;
514 fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context);
515 /* Find the LIP's register pair and calculate its offset */
516 /* before we scavenge the context. */
518 lip = *os_context_register_addr(context, reg_LIP);
519 /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
520 lip_offset = 0x7FFFFFFF;
521 lip_register_pair = -1;
522 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
527 index = boxed_registers[i];
528 reg = *os_context_register_addr(context, index);
529 /* would be using PTR if not for integer length issues */
530 if ((reg & ~((1L<<N_LOWTAG_BITS)-1)) <= lip) {
532 if (offset < lip_offset) {
534 lip_register_pair = index;
540 /* Compute the PC's offset from the start of the CODE */
543 *os_context_pc_addr(context) -
544 *os_context_register_addr(context, reg_CODE);
545 #ifdef ARCH_HAS_NPC_REGISTER
547 *os_context_npc_addr(context) -
548 *os_context_register_addr(context, reg_CODE);
550 #ifdef ARCH_HAS_LINK_REGISTER
552 *os_context_lr_addr(context) -
553 *os_context_register_addr(context, reg_CODE);
556 /* Scavenge all boxed registers in the context. */
557 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
561 index = boxed_registers[i];
562 foo = *os_context_register_addr(context,index);
563 scavenge((lispobj *) &foo, 1);
564 *os_context_register_addr(context,index) = foo;
566 /* this is unlikely to work as intended on bigendian
567 * 64 bit platforms */
570 os_context_register_addr(context, index), 1);
575 *os_context_register_addr(context, reg_LIP) =
576 *os_context_register_addr(context, lip_register_pair) + lip_offset;
579 /* Fix the PC if it was in from space */
580 if (from_space_p(*os_context_pc_addr(context)))
581 *os_context_pc_addr(context) =
582 *os_context_register_addr(context, reg_CODE) + pc_code_offset;
583 #ifdef ARCH_HAS_LINK_REGISTER
584 /* Fix the LR ditto; important if we're being called from
585 * an assembly routine that expects to return using blr, otherwise
587 if (from_space_p(*os_context_lr_addr(context)))
588 *os_context_lr_addr(context) =
589 *os_context_register_addr(context, reg_CODE) + lr_code_offset;
592 #ifdef ARCH_HAS_NPC_REGISTER
593 if (from_space_p(*os_context_npc_addr(context)))
594 *os_context_npc_addr(context) =
595 *os_context_register_addr(context, reg_CODE) + npc_code_offset;
599 void scavenge_interrupt_contexts(void)
602 os_context_t *context;
604 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
606 fprintf(stderr, "%d interrupt contexts to scan\n",index);
607 for (i = 0; i < index; i++) {
608 context = lisp_interrupt_contexts[i];
609 scavenge_interrupt_context(context);
617 print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
620 int total_words_not_copied;
622 printf("Scanning from space ...\n");
624 total_words_not_copied = 0;
626 while (start < from_space_free_pointer) {
628 int forwardp, type, nwords;
632 forwardp = is_lisp_pointer(object) && new_space_p(object);
638 tag = lowtag_of(object);
641 case LIST_POINTER_LOWTAG:
644 case INSTANCE_POINTER_LOWTAG:
645 printf("Don't know about instances yet!\n");
648 case FUN_POINTER_LOWTAG:
651 case OTHER_POINTER_LOWTAG:
652 pointer = (lispobj *) native_pointer(object);
654 type = widetag_of(header);
655 nwords = (sizetab[type])(pointer);
658 type = widetag_of(object);
659 nwords = (sizetab[type])(start);
660 total_words_not_copied += nwords;
661 printf("%4d words not copied at 0x%16lx; ",
662 nwords, (unsigned long) start);
663 printf("Header word is 0x%08x\n",
664 (unsigned int) object);
668 printf("%d total words not copied.\n", total_words_not_copied);
672 /* code and code-related objects */
674 /* FIXME: Shouldn't this be defined in sbcl.h? */
675 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
677 static lispobj trans_fun_header(lispobj object);
678 static lispobj trans_boxed(lispobj object);
681 scav_fun_pointer(lispobj *where, lispobj object)
683 lispobj *first_pointer;
688 gc_assert(is_lisp_pointer(object));
690 /* object is a pointer into from space. Not a FP */
691 first_pointer = (lispobj *) native_pointer(object);
692 first = *first_pointer;
694 /* must transport object -- object may point */
695 /* to either a function header, a closure */
696 /* function header, or to a closure header. */
698 type = widetag_of(first);
700 case SIMPLE_FUN_HEADER_WIDETAG:
701 case CLOSURE_FUN_HEADER_WIDETAG:
702 copy = trans_fun_header(object);
705 copy = trans_boxed(object);
709 first = *first_pointer = copy;
711 gc_assert(is_lisp_pointer(first));
712 gc_assert(!from_space_p(first));
719 trans_code(struct code *code)
721 struct code *new_code;
722 lispobj first, l_code, l_new_code;
723 int nheader_words, ncode_words, nwords;
724 unsigned long displacement;
725 lispobj fheaderl, *prev_pointer;
727 #if defined(DEBUG_CODE_GC)
728 printf("\nTransporting code object located at 0x%08x.\n",
729 (unsigned long) code);
732 /* if object has already been transported, just return pointer */
733 first = code->header;
734 if (is_lisp_pointer(first) && new_space_p(first)) {
736 printf("Was already transported\n");
738 return (struct code *) native_pointer(first);
741 gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
743 /* prepare to transport the code vector */
744 l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
746 ncode_words = fixnum_value(code->code_size);
747 nheader_words = HeaderValue(code->header);
748 nwords = ncode_words + nheader_words;
749 nwords = CEILING(nwords, 2);
751 l_new_code = copy_object(l_code, nwords);
752 new_code = (struct code *) native_pointer(l_new_code);
754 displacement = l_new_code - l_code;
756 #if defined(DEBUG_CODE_GC)
757 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
758 (unsigned long) code, (unsigned long) new_code);
759 printf("Code object is %d words long.\n", nwords);
762 /* set forwarding pointer */
763 code->header = l_new_code;
765 /* set forwarding pointers for all the function headers in the */
766 /* code object. also fix all self pointers */
768 fheaderl = code->entry_points;
769 prev_pointer = &new_code->entry_points;
771 while (fheaderl != NIL) {
772 struct simple_fun *fheaderp, *nfheaderp;
775 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
776 gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
778 /* Calculate the new function pointer and the new */
779 /* function header. */
780 nfheaderl = fheaderl + displacement;
781 nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
783 /* set forwarding pointer */
785 printf("fheaderp->header (at %x) <- %x\n",
786 &(fheaderp->header) , nfheaderl);
788 fheaderp->header = nfheaderl;
790 /* fix self pointer */
791 nfheaderp->self = nfheaderl;
793 *prev_pointer = nfheaderl;
795 fheaderl = fheaderp->next;
796 prev_pointer = &nfheaderp->next;
800 os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
801 ncode_words * sizeof(int));
807 scav_code_header(lispobj *where, lispobj object)
810 int nheader_words, ncode_words, nwords;
812 struct simple_fun *fheaderp;
814 code = (struct code *) where;
815 ncode_words = fixnum_value(code->code_size);
816 nheader_words = HeaderValue(object);
817 nwords = ncode_words + nheader_words;
818 nwords = CEILING(nwords, 2);
820 #if defined(DEBUG_CODE_GC)
821 printf("\nScavening code object at 0x%08x.\n",
822 (unsigned long) where);
823 printf("Code object is %d words long.\n", nwords);
824 printf("Scavenging boxed section of code data block (%d words).\n",
828 /* Scavenge the boxed section of the code data block */
829 scavenge(where + 1, nheader_words - 1);
831 /* Scavenge the boxed section of each function object in the */
832 /* code data block */
833 fheaderl = code->entry_points;
834 while (fheaderl != NIL) {
835 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
836 gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
838 #if defined(DEBUG_CODE_GC)
839 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
840 (unsigned long) native_pointer(fheaderl));
842 scavenge(&fheaderp->name, 1);
843 scavenge(&fheaderp->arglist, 1);
844 scavenge(&fheaderp->type, 1);
846 fheaderl = fheaderp->next;
853 trans_code_header(lispobj object)
857 ncode = trans_code((struct code *) native_pointer(object));
858 return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
862 size_code_header(lispobj *where)
865 int nheader_words, ncode_words, nwords;
867 code = (struct code *) where;
869 ncode_words = fixnum_value(code->code_size);
870 nheader_words = HeaderValue(code->header);
871 nwords = ncode_words + nheader_words;
872 nwords = CEILING(nwords, 2);
879 scav_return_pc_header(lispobj *where, lispobj object)
881 fprintf(stderr, "GC lossage. Should not be scavenging a ");
882 fprintf(stderr, "Return PC Header.\n");
883 fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
889 trans_return_pc_header(lispobj object)
891 struct simple_fun *return_pc;
892 unsigned long offset;
893 struct code *code, *ncode;
895 return_pc = (struct simple_fun *) native_pointer(object);
896 offset = HeaderValue(return_pc->header) * 4 ;
898 /* Transport the whole code object */
899 code = (struct code *) ((unsigned long) return_pc - offset);
901 printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
903 ncode = trans_code(code);
904 if (object==0x304748d7) {
905 /* monitor_or_something(); */
907 ret= ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
909 printf("trans_return_pc_header returning %x\n",ret);
914 /* On the 386, closures hold a pointer to the raw address instead of
915 * the function object, so we can use CALL [$FDEFN+const] to invoke
916 * the function without loading it into a register. Given that code
917 * objects don't move, we don't need to update anything, but we do
918 * have to figure out that the function is still live. */
921 scav_closure_header(where, object)
922 lispobj *where, object;
924 struct closure *closure;
927 closure = (struct closure *)where;
928 fun = closure->fun - FUN_RAW_ADDR_OFFSET;
936 scav_fun_header(lispobj *where, lispobj object)
938 fprintf(stderr, "GC lossage. Should not be scavenging a ");
939 fprintf(stderr, "Function Header.\n");
940 fprintf(stderr, "where = 0x%p, object = 0x%08x",
941 where, (unsigned int) object);
947 trans_fun_header(lispobj object)
949 struct simple_fun *fheader;
950 unsigned long offset;
951 struct code *code, *ncode;
953 fheader = (struct simple_fun *) native_pointer(object);
954 offset = HeaderValue(fheader->header) * 4;
956 /* Transport the whole code object */
957 code = (struct code *) ((unsigned long) fheader - offset);
958 ncode = trans_code(code);
960 return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
968 scav_instance_pointer(lispobj *where, lispobj object)
970 lispobj *first_pointer;
972 /* object is a pointer into from space. Not a FP */
973 first_pointer = (lispobj *) native_pointer(object);
975 *where = *first_pointer = trans_boxed(object);
980 /* lists and conses */
982 static lispobj trans_list(lispobj object);
985 scav_list_pointer(lispobj *where, lispobj object)
987 lispobj first, *first_pointer;
989 gc_assert(is_lisp_pointer(object));
991 /* object is a pointer into from space. Not a FP. */
992 first_pointer = (lispobj *) native_pointer(object);
994 first = *first_pointer = trans_list(object);
996 gc_assert(is_lisp_pointer(first));
997 gc_assert(!from_space_p(first));
1004 trans_list(lispobj object)
1006 lispobj new_list_pointer;
1007 struct cons *cons, *new_cons;
1009 cons = (struct cons *) native_pointer(object);
1011 /* ### Don't use copy_object here. */
1012 new_list_pointer = copy_object(object, 2);
1013 new_cons = (struct cons *) native_pointer(new_list_pointer);
1015 /* Set forwarding pointer. */
1016 cons->car = new_list_pointer;
1018 /* Try to linearize the list in the cdr direction to help reduce */
1022 lispobj cdr, new_cdr, first;
1023 struct cons *cdr_cons, *new_cdr_cons;
1027 if (lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
1028 !from_space_p(cdr) ||
1029 (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
1030 && new_space_p(first)))
1033 cdr_cons = (struct cons *) native_pointer(cdr);
1035 /* ### Don't use copy_object here */
1036 new_cdr = copy_object(cdr, 2);
1037 new_cdr_cons = (struct cons *) native_pointer(new_cdr);
1039 /* Set forwarding pointer */
1040 cdr_cons->car = new_cdr;
1042 /* Update the cdr of the last cons copied into new */
1043 /* space to keep the newspace scavenge from having to */
1045 new_cons->cdr = new_cdr;
1048 new_cons = new_cdr_cons;
1051 return new_list_pointer;
1055 /* scavenging and transporting other pointers */
1058 scav_other_pointer(lispobj *where, lispobj object)
1060 lispobj first, *first_pointer;
1062 gc_assert(is_lisp_pointer(object));
1064 /* Object is a pointer into from space - not a FP */
1065 first_pointer = (lispobj *) native_pointer(object);
1066 first = *first_pointer = (transother[widetag_of(*first_pointer)])(object);
1068 gc_assert(is_lisp_pointer(first));
1069 gc_assert(!from_space_p(first));
1076 /* immediate, boxed, and unboxed objects */
1079 size_pointer(lispobj *where)
1085 scav_immediate(lispobj *where, lispobj object)
1091 trans_immediate(lispobj object)
1093 fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
1099 size_immediate(lispobj *where)
1106 scav_boxed(lispobj *where, lispobj object)
1112 trans_boxed(lispobj object)
1115 unsigned long length;
1117 gc_assert(is_lisp_pointer(object));
1119 header = *((lispobj *) native_pointer(object));
1120 length = HeaderValue(header) + 1;
1121 length = CEILING(length, 2);
1123 return copy_object(object, length);
1127 size_boxed(lispobj *where)
1130 unsigned long length;
1133 length = HeaderValue(header) + 1;
1134 length = CEILING(length, 2);
1139 /* Note: on the sparc we don't have to do anything special for fdefns, */
1140 /* 'cause the raw-addr has a function lowtag. */
1143 scav_fdefn(lispobj *where, lispobj object)
1145 struct fdefn *fdefn;
1147 fdefn = (struct fdefn *)where;
1149 if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
1150 == (char *)((unsigned long)(fdefn->raw_addr))) {
1151 scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
1153 (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
1154 return sizeof(struct fdefn) / sizeof(lispobj);
1162 scav_unboxed(lispobj *where, lispobj object)
1164 unsigned long length;
1166 length = HeaderValue(object) + 1;
1167 length = CEILING(length, 2);
1173 trans_unboxed(lispobj object)
1176 unsigned long length;
1179 gc_assert(is_lisp_pointer(object));
1181 header = *((lispobj *) native_pointer(object));
1182 length = HeaderValue(header) + 1;
1183 length = CEILING(length, 2);
1185 return copy_object(object, length);
1189 size_unboxed(lispobj *where)
1192 unsigned long length;
1195 length = HeaderValue(header) + 1;
1196 length = CEILING(length, 2);
1202 /* vector-like objects */
1204 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1207 scav_string(lispobj *where, lispobj object)
1209 struct vector *vector;
1212 /* NOTE: Strings contain one more byte of data than the length */
1213 /* slot indicates. */
1215 vector = (struct vector *) where;
1216 length = fixnum_value(vector->length) + 1;
1217 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1223 trans_string(lispobj object)
1225 struct vector *vector;
1228 gc_assert(is_lisp_pointer(object));
1230 /* NOTE: Strings contain one more byte of data than the length */
1231 /* slot indicates. */
1233 vector = (struct vector *) native_pointer(object);
1234 length = fixnum_value(vector->length) + 1;
1235 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1237 return copy_object(object, nwords);
1241 size_string(lispobj *where)
1243 struct vector *vector;
1246 /* NOTE: Strings contain one more byte of data than the length */
1247 /* slot indicates. */
1249 vector = (struct vector *) where;
1250 length = fixnum_value(vector->length) + 1;
1251 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1257 scav_vector(lispobj *where, lispobj object)
1259 if (HeaderValue(object) == subtype_VectorValidHashing) {
1261 (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
1269 trans_vector(lispobj object)
1271 struct vector *vector;
1274 gc_assert(is_lisp_pointer(object));
1276 vector = (struct vector *) native_pointer(object);
1278 length = fixnum_value(vector->length);
1279 nwords = CEILING(length + 2, 2);
1281 return copy_object(object, nwords);
1285 size_vector(lispobj *where)
1287 struct vector *vector;
1290 vector = (struct vector *) where;
1291 length = fixnum_value(vector->length);
1292 nwords = CEILING(length + 2, 2);
1299 scav_vector_bit(lispobj *where, lispobj object)
1301 struct vector *vector;
1304 vector = (struct vector *) where;
1305 length = fixnum_value(vector->length);
1306 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1312 trans_vector_bit(lispobj object)
1314 struct vector *vector;
1317 gc_assert(is_lisp_pointer(object));
1319 vector = (struct vector *) native_pointer(object);
1320 length = fixnum_value(vector->length);
1321 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1323 return copy_object(object, nwords);
1327 size_vector_bit(lispobj *where)
1329 struct vector *vector;
1332 vector = (struct vector *) where;
1333 length = fixnum_value(vector->length);
1334 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1341 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
1343 struct vector *vector;
1346 vector = (struct vector *) where;
1347 length = fixnum_value(vector->length);
1348 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1354 trans_vector_unsigned_byte_2(lispobj object)
1356 struct vector *vector;
1359 gc_assert(is_lisp_pointer(object));
1361 vector = (struct vector *) native_pointer(object);
1362 length = fixnum_value(vector->length);
1363 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1365 return copy_object(object, nwords);
1369 size_vector_unsigned_byte_2(lispobj *where)
1371 struct vector *vector;
1374 vector = (struct vector *) where;
1375 length = fixnum_value(vector->length);
1376 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1383 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1385 struct vector *vector;
1388 vector = (struct vector *) where;
1389 length = fixnum_value(vector->length);
1390 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1396 trans_vector_unsigned_byte_4(lispobj object)
1398 struct vector *vector;
1401 gc_assert(is_lisp_pointer(object));
1403 vector = (struct vector *) native_pointer(object);
1404 length = fixnum_value(vector->length);
1405 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1407 return copy_object(object, nwords);
1411 size_vector_unsigned_byte_4(lispobj *where)
1413 struct vector *vector;
1416 vector = (struct vector *) where;
1417 length = fixnum_value(vector->length);
1418 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1425 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1427 struct vector *vector;
1430 vector = (struct vector *) where;
1431 length = fixnum_value(vector->length);
1432 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1438 trans_vector_unsigned_byte_8(lispobj object)
1440 struct vector *vector;
1443 gc_assert(is_lisp_pointer(object));
1445 vector = (struct vector *) native_pointer(object);
1446 length = fixnum_value(vector->length);
1447 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1449 return copy_object(object, nwords);
1453 size_vector_unsigned_byte_8(lispobj *where)
1455 struct vector *vector;
1458 vector = (struct vector *) where;
1459 length = fixnum_value(vector->length);
1460 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1467 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1469 struct vector *vector;
1472 vector = (struct vector *) where;
1473 length = fixnum_value(vector->length);
1474 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1480 trans_vector_unsigned_byte_16(lispobj object)
1482 struct vector *vector;
1485 gc_assert(is_lisp_pointer(object));
1487 vector = (struct vector *) native_pointer(object);
1488 length = fixnum_value(vector->length);
1489 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1491 return copy_object(object, nwords);
1495 size_vector_unsigned_byte_16(lispobj *where)
1497 struct vector *vector;
1500 vector = (struct vector *) where;
1501 length = fixnum_value(vector->length);
1502 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1509 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1511 struct vector *vector;
1514 vector = (struct vector *) where;
1515 length = fixnum_value(vector->length);
1516 nwords = CEILING(length + 2, 2);
1522 trans_vector_unsigned_byte_32(lispobj object)
1524 struct vector *vector;
1527 gc_assert(is_lisp_pointer(object));
1529 vector = (struct vector *) native_pointer(object);
1530 length = fixnum_value(vector->length);
1531 nwords = CEILING(length + 2, 2);
1533 return copy_object(object, nwords);
1537 size_vector_unsigned_byte_32(lispobj *where)
1539 struct vector *vector;
1542 vector = (struct vector *) where;
1543 length = fixnum_value(vector->length);
1544 nwords = CEILING(length + 2, 2);
1550 scav_vector_single_float(lispobj *where, lispobj object)
1552 struct vector *vector;
1555 vector = (struct vector *) where;
1556 length = fixnum_value(vector->length);
1557 nwords = CEILING(length + 2, 2);
1563 trans_vector_single_float(lispobj object)
1565 struct vector *vector;
1568 gc_assert(is_lisp_pointer(object));
1570 vector = (struct vector *) native_pointer(object);
1571 length = fixnum_value(vector->length);
1572 nwords = CEILING(length + 2, 2);
1574 return copy_object(object, nwords);
1578 size_vector_single_float(lispobj *where)
1580 struct vector *vector;
1583 vector = (struct vector *) where;
1584 length = fixnum_value(vector->length);
1585 nwords = CEILING(length + 2, 2);
1592 scav_vector_double_float(lispobj *where, lispobj object)
1594 struct vector *vector;
1597 vector = (struct vector *) where;
1598 length = fixnum_value(vector->length);
1599 nwords = CEILING(length * 2 + 2, 2);
1605 trans_vector_double_float(lispobj object)
1607 struct vector *vector;
1610 gc_assert(is_lisp_pointer(object));
1612 vector = (struct vector *) native_pointer(object);
1613 length = fixnum_value(vector->length);
1614 nwords = CEILING(length * 2 + 2, 2);
1616 return copy_object(object, nwords);
1620 size_vector_double_float(lispobj *where)
1622 struct vector *vector;
1625 vector = (struct vector *) where;
1626 length = fixnum_value(vector->length);
1627 nwords = CEILING(length * 2 + 2, 2);
1633 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1635 scav_vector_long_float(lispobj *where, lispobj object)
1637 struct vector *vector;
1640 vector = (struct vector *) where;
1641 length = fixnum_value(vector->length);
1643 nwords = CEILING(length * 4 + 2, 2);
1650 trans_vector_long_float(lispobj object)
1652 struct vector *vector;
1655 gc_assert(is_lisp_pointer(object));
1657 vector = (struct vector *) native_pointer(object);
1658 length = fixnum_value(vector->length);
1660 nwords = CEILING(length * 4 + 2, 2);
1663 return copy_object(object, nwords);
1667 size_vector_long_float(lispobj *where)
1669 struct vector *vector;
1672 vector = (struct vector *) where;
1673 length = fixnum_value(vector->length);
1675 nwords = CEILING(length * 4 + 2, 2);
1683 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1685 scav_vector_complex_single_float(lispobj *where, lispobj object)
1687 struct vector *vector;
1690 vector = (struct vector *) where;
1691 length = fixnum_value(vector->length);
1692 nwords = CEILING(length * 2 + 2, 2);
1698 trans_vector_complex_single_float(lispobj object)
1700 struct vector *vector;
1703 gc_assert(is_lisp_pointer(object));
1705 vector = (struct vector *) native_pointer(object);
1706 length = fixnum_value(vector->length);
1707 nwords = CEILING(length * 2 + 2, 2);
1709 return copy_object(object, nwords);
1713 size_vector_complex_single_float(lispobj *where)
1715 struct vector *vector;
1718 vector = (struct vector *) where;
1719 length = fixnum_value(vector->length);
1720 nwords = CEILING(length * 2 + 2, 2);
1726 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1728 scav_vector_complex_double_float(lispobj *where, lispobj object)
1730 struct vector *vector;
1733 vector = (struct vector *) where;
1734 length = fixnum_value(vector->length);
1735 nwords = CEILING(length * 4 + 2, 2);
1741 trans_vector_complex_double_float(lispobj object)
1743 struct vector *vector;
1746 gc_assert(is_lisp_pointer(object));
1748 vector = (struct vector *) native_pointer(object);
1749 length = fixnum_value(vector->length);
1750 nwords = CEILING(length * 4 + 2, 2);
1752 return copy_object(object, nwords);
1756 size_vector_complex_double_float(lispobj *where)
1758 struct vector *vector;
1761 vector = (struct vector *) where;
1762 length = fixnum_value(vector->length);
1763 nwords = CEILING(length * 4 + 2, 2);
1769 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1771 scav_vector_complex_long_float(lispobj *where, lispobj object)
1773 struct vector *vector;
1776 vector = (struct vector *) where;
1777 length = fixnum_value(vector->length);
1779 nwords = CEILING(length * 8 + 2, 2);
1786 trans_vector_complex_long_float(lispobj object)
1788 struct vector *vector;
1791 gc_assert(is_lisp_pointer(object));
1793 vector = (struct vector *) native_pointer(object);
1794 length = fixnum_value(vector->length);
1796 nwords = CEILING(length * 8 + 2, 2);
1799 return copy_object(object, nwords);
1803 size_vector_complex_long_float(lispobj *where)
1805 struct vector *vector;
1808 vector = (struct vector *) where;
1809 length = fixnum_value(vector->length);
1811 nwords = CEILING(length * 8 + 2, 2);
1821 #define WEAK_POINTER_NWORDS \
1822 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1825 scav_weak_pointer(lispobj *where, lispobj object)
1827 /* Do not let GC scavenge the value slot of the weak pointer */
1828 /* (that is why it is a weak pointer). Note: we could use */
1829 /* the scav_unboxed method here. */
1831 return WEAK_POINTER_NWORDS;
1835 trans_weak_pointer(lispobj object)
1838 struct weak_pointer *wp;
1840 gc_assert(is_lisp_pointer(object));
1842 #if defined(DEBUG_WEAK)
1843 printf("Transporting weak pointer from 0x%08x\n", object);
1846 /* Need to remember where all the weak pointers are that have */
1847 /* been transported so they can be fixed up in a post-GC pass. */
1849 copy = copy_object(object, WEAK_POINTER_NWORDS);
1850 wp = (struct weak_pointer *) native_pointer(copy);
1853 /* Push the weak pointer onto the list of weak pointers. */
1854 wp->next = LOW_WORD(weak_pointers);
1861 size_weak_pointer(lispobj *where)
1863 return WEAK_POINTER_NWORDS;
1866 void scan_weak_pointers(void)
1868 struct weak_pointer *wp;
1870 for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1871 wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1873 lispobj first, *first_pointer;
1877 #if defined(DEBUG_WEAK)
1878 printf("Weak pointer at 0x%p\n", wp);
1879 printf("Value: 0x%08x\n", (unsigned int) value);
1882 if (!(is_lisp_pointer(value) && from_space_p(value)))
1885 /* Now, we need to check if the object has been */
1886 /* forwarded. If it has been, the weak pointer is */
1887 /* still good and needs to be updated. Otherwise, the */
1888 /* weak pointer needs to be nil'ed out. */
1890 first_pointer = (lispobj *) native_pointer(value);
1891 first = *first_pointer;
1893 #if defined(DEBUG_WEAK)
1894 printf("First: 0x%08x\n", (unsigned long) first);
1897 if (is_lisp_pointer(first) && new_space_p(first))
1908 /* initialization */
1911 scav_lose(lispobj *where, lispobj object)
1913 fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n",
1914 (unsigned int) object, (unsigned long)where);
1920 trans_lose(lispobj object)
1922 fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
1923 (unsigned int)object);
1929 size_lose(lispobj *where)
1931 fprintf(stderr, "Size lossage. No size function for object at 0x%p\n",
1933 fprintf(stderr, "First word of object: 0x%08x\n",
1938 /* KLUDGE: SBCL already has two GC implementations, and if someday the
1939 * precise generational GC is revived, it might have three. It would
1940 * be nice to share the scavtab[] data set up here, and perhaps other
1941 * things too, between all of them, rather than trying to maintain
1942 * multiple copies. -- WHN 2001-05-09 */
1948 /* scavenge table */
1949 for (i = 0; i < 256; i++)
1950 scavtab[i] = scav_lose;
1951 /* scavtab[i] = scav_immediate; */
1953 for (i = 0; i < 32; i++) {
1954 scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1955 scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
1956 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1957 scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
1958 scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
1959 scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer;
1960 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1961 scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
1964 scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1965 scavtab[RATIO_WIDETAG] = scav_boxed;
1966 scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1967 scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1968 #ifdef LONG_FLOAT_WIDETAG
1969 scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1971 scavtab[COMPLEX_WIDETAG] = scav_boxed;
1972 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1973 scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1975 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1976 scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1978 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1979 scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1981 scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1982 scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
1983 scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1984 scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
1985 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1986 scav_vector_unsigned_byte_2;
1987 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1988 scav_vector_unsigned_byte_4;
1989 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1990 scav_vector_unsigned_byte_8;
1991 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1992 scav_vector_unsigned_byte_16;
1993 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1994 scav_vector_unsigned_byte_32;
1995 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1996 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
1997 scav_vector_unsigned_byte_8;
1999 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2000 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2001 scav_vector_unsigned_byte_16;
2003 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2004 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2005 scav_vector_unsigned_byte_32;
2007 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2008 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2009 scav_vector_unsigned_byte_32;
2011 scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2012 scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2013 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2014 scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2016 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2017 scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2018 scav_vector_complex_single_float;
2020 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2021 scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2022 scav_vector_complex_double_float;
2024 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2025 scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2026 scav_vector_complex_long_float;
2028 scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
2029 scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2030 scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2031 scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2032 scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2033 scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2034 scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;
2035 scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2037 scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2038 scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
2040 scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2041 scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2043 scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2044 scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2045 scavtab[BASE_CHAR_WIDETAG] = scav_immediate;
2046 scavtab[SAP_WIDETAG] = scav_unboxed;
2047 scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2048 scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
2049 scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
2051 scavtab[FDEFN_WIDETAG] = scav_fdefn;
2053 scavtab[FDEFN_WIDETAG] = scav_boxed;
2056 /* Transport Other Table */
2057 for (i = 0; i < 256; i++)
2058 transother[i] = trans_lose;
2060 transother[BIGNUM_WIDETAG] = trans_unboxed;
2061 transother[RATIO_WIDETAG] = trans_boxed;
2062 transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2063 transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2064 #ifdef LONG_FLOAT_WIDETAG
2065 transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2067 transother[COMPLEX_WIDETAG] = trans_boxed;
2068 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2069 transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2071 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2072 transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2074 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2075 transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2077 transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed;
2078 transother[SIMPLE_STRING_WIDETAG] = trans_string;
2079 transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2080 transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2081 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2082 trans_vector_unsigned_byte_2;
2083 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2084 trans_vector_unsigned_byte_4;
2085 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2086 trans_vector_unsigned_byte_8;
2087 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2088 trans_vector_unsigned_byte_16;
2089 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2090 trans_vector_unsigned_byte_32;
2091 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2092 transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2093 trans_vector_unsigned_byte_8;
2095 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2096 transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2097 trans_vector_unsigned_byte_16;
2099 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2100 transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2101 trans_vector_unsigned_byte_32;
2103 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2104 transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2105 trans_vector_unsigned_byte_32;
2107 transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2108 trans_vector_single_float;
2109 transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2110 trans_vector_double_float;
2111 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2112 transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2113 trans_vector_long_float;
2115 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2116 transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2117 trans_vector_complex_single_float;
2119 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2120 transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2121 trans_vector_complex_double_float;
2123 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2124 transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2125 trans_vector_complex_long_float;
2127 transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
2128 transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2129 transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2130 transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2131 transother[CODE_HEADER_WIDETAG] = trans_code_header;
2132 transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2133 transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header;
2134 transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2135 transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2136 transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2137 transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2138 transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2139 transother[BASE_CHAR_WIDETAG] = trans_immediate;
2140 transother[SAP_WIDETAG] = trans_unboxed;
2141 transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2142 transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2143 transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2144 transother[FDEFN_WIDETAG] = trans_boxed;
2148 for (i = 0; i < 256; i++)
2149 sizetab[i] = size_lose;
2151 for (i = 0; i < 32; i++) {
2152 sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2153 sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
2154 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2155 sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
2156 sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
2157 sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
2158 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2159 sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
2162 sizetab[BIGNUM_WIDETAG] = size_unboxed;
2163 sizetab[RATIO_WIDETAG] = size_boxed;
2164 sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2165 sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2166 #ifdef LONG_FLOAT_WIDETAG
2167 sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2169 sizetab[COMPLEX_WIDETAG] = size_boxed;
2170 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2171 sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2173 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2174 sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2176 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2177 sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2179 sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2180 sizetab[SIMPLE_STRING_WIDETAG] = size_string;
2181 sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2182 sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2183 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2184 size_vector_unsigned_byte_2;
2185 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2186 size_vector_unsigned_byte_4;
2187 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2188 size_vector_unsigned_byte_8;
2189 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2190 size_vector_unsigned_byte_16;
2191 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2192 size_vector_unsigned_byte_32;
2193 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2194 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2195 size_vector_unsigned_byte_8;
2197 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2198 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2199 size_vector_unsigned_byte_16;
2201 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2202 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
2203 size_vector_unsigned_byte_32;
2205 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2206 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2207 size_vector_unsigned_byte_32;
2209 sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2210 sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2211 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2212 sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2214 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2215 sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2216 size_vector_complex_single_float;
2218 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2219 sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2220 size_vector_complex_double_float;
2222 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2223 sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2224 size_vector_complex_long_float;
2226 sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
2227 sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2228 sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2229 sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2230 sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2232 /* Shouldn't see these so just lose if it happens */
2233 sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2234 sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header;
2235 sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2237 sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2238 sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2239 sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2240 sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2241 sizetab[BASE_CHAR_WIDETAG] = size_immediate;
2242 sizetab[SAP_WIDETAG] = size_unboxed;
2243 sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
2244 sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
2245 sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
2246 sizetab[FDEFN_WIDETAG] = size_boxed;
2249 /* noise to manipulate the gc trigger stuff */
2251 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2253 os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2256 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2258 if (addr < (os_vm_address_t)dynamic_space_free_pointer) {
2260 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2261 (unsigned int)dynamic_usage,
2262 (os_vm_address_t)dynamic_space_free_pointer
2263 - (os_vm_address_t)current_dynamic_space);
2266 else if (length < 0) {
2268 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2273 addr=os_round_up_to_page(addr);
2274 length=os_trunc_size_to_page(length);
2276 #if defined(SUNOS) || defined(SOLARIS)
2277 os_invalidate(addr,length);
2279 os_protect(addr, length, 0);
2282 current_auto_gc_trigger = (lispobj *)addr;
2285 void clear_auto_gc_trigger(void)
2287 if (current_auto_gc_trigger!=NULL){
2288 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2289 os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2290 os_vm_size_t length=
2291 DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2293 os_validate(addr,length);
2295 os_protect((os_vm_address_t)current_dynamic_space,
2300 current_auto_gc_trigger = NULL;