2 * C-level stuff to implement Lisp-level PURIFY
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.
17 #include <sys/types.h>
25 #include "interrupt.h"
35 /* again, what's so special about the x86 that this is differently
36 * visible there than on other platforms? -dan 20010125
38 static lispobj *dynamic_space_free_pointer;
42 lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
45 #define gc_assert(ex) do { \
46 if (!(ex)) gc_abort(); \
53 /* These hold the original end of the read_only and static spaces so
54 * we can tell what are forwarding pointers. */
56 static lispobj *read_only_end, *static_end;
58 static lispobj *read_only_free, *static_free;
60 static lispobj *pscav(lispobj *addr, int nwords, boolean constant);
62 #define LATERBLOCKSIZE 1020
63 #define LATERMAXCOUNT 10
72 } *later_blocks = NULL;
73 static int later_count = 0;
75 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
76 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
79 #define RAW_ADDR_OFFSET 0
81 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
85 forwarding_pointer_p(lispobj obj)
91 return ((static_end <= ptr && ptr <= static_free) ||
92 (read_only_end <= ptr && ptr <= read_only_free));
96 dynamic_pointer_p(lispobj ptr)
99 /* KLUDGE: This has an implicit dependence on the ordering of
100 * address spaces, and is therefore basically wrong. I'd fix it,
101 * but I don't have a non-386 port to test it on. Porters are
102 * encouraged to fix it. -- WHN 2000-10-17 */
103 return (ptr >= (lispobj)DYNAMIC_SPACE_START);
105 /* Be more conservative, and remember, this is a maybe. */
106 return (ptr >= (lispobj)DYNAMIC_SPACE_START
108 ptr < (lispobj)dynamic_space_free_pointer);
117 * enhanced x86/GENCGC stack scavenging by Douglas Crosher
119 * Scavenging the stack on the i386 is problematic due to conservative
120 * roots and raw return addresses. Here it is handled in two passes:
121 * the first pass runs before any objects are moved and tries to
122 * identify valid pointers and return address on the stack, the second
123 * pass scavenges these.
126 static unsigned pointer_filter_verbose = 0;
128 /* FIXME: This is substantially the same code as in gencgc.c. (There
129 * are some differences, at least (1) the gencgc.c code needs to worry
130 * about return addresses on the stack pinning code objects, (2) the
131 * gencgc.c code needs to worry about the GC maybe happening in an
132 * interrupt service routine when the main thread of control was
133 * interrupted just as it had allocated memory and before it
134 * initialized it, while PURIFY needn't worry about that, and (3) the
135 * gencgc.c code has mutated more under maintenance since the fork
136 * from CMU CL than the code here has.) The two versions should be
137 * made to explicitly share common code, instead of just two different
138 * cut-and-pasted versions. */
140 valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
142 /* If it's not a return address then it needs to be a valid Lisp
144 if (!is_lisp_pointer((lispobj)pointer))
147 /* Check that the object pointed to is consistent with the pointer
149 switch (LowtagOf((lispobj)pointer)) {
150 case type_FunctionPointer:
151 /* Start_addr should be the enclosing code object, or a closure
153 switch (TypeOf(*start_addr)) {
154 case type_CodeHeader:
155 /* This case is probably caught above. */
157 case type_ClosureHeader:
158 case type_FuncallableInstanceHeader:
159 case type_ByteCodeFunction:
160 case type_ByteCodeClosure:
161 if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
162 if (pointer_filter_verbose) {
163 fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer,
164 (unsigned int) start_addr, *start_addr);
170 if (pointer_filter_verbose) {
171 fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer,
172 (unsigned int) start_addr, *start_addr);
177 case type_ListPointer:
178 if ((int)pointer != ((int)start_addr+type_ListPointer)) {
179 if (pointer_filter_verbose)
180 fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer,
181 (unsigned int) start_addr, *start_addr);
184 /* Is it plausible cons? */
185 if((is_lisp_pointer(start_addr[0])
186 || ((start_addr[0] & 3) == 0) /* fixnum */
187 || (TypeOf(start_addr[0]) == type_BaseChar)
188 || (TypeOf(start_addr[0]) == type_UnboundMarker))
189 && (is_lisp_pointer(start_addr[1])
190 || ((start_addr[1] & 3) == 0) /* fixnum */
191 || (TypeOf(start_addr[1]) == type_BaseChar)
192 || (TypeOf(start_addr[1]) == type_UnboundMarker))) {
195 if (pointer_filter_verbose) {
196 fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned int) pointer,
197 (unsigned int) start_addr, *start_addr);
201 case type_InstancePointer:
202 if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
203 if (pointer_filter_verbose) {
204 fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer,
205 (unsigned int) start_addr, *start_addr);
209 if (TypeOf(start_addr[0]) != type_InstanceHeader) {
210 if (pointer_filter_verbose) {
211 fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer,
212 (unsigned int) start_addr, *start_addr);
217 case type_OtherPointer:
218 if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
219 if (pointer_filter_verbose) {
220 fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer,
221 (unsigned int) start_addr, *start_addr);
225 /* Is it plausible? Not a cons. X should check the headers. */
226 if(is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
227 if (pointer_filter_verbose) {
228 fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
229 (unsigned int) start_addr, *start_addr);
233 switch (TypeOf(start_addr[0])) {
234 case type_UnboundMarker:
236 if (pointer_filter_verbose) {
237 fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned int) pointer,
238 (unsigned int) start_addr, *start_addr);
242 /* only pointed to by function pointers? */
243 case type_ClosureHeader:
244 case type_FuncallableInstanceHeader:
245 case type_ByteCodeFunction:
246 case type_ByteCodeClosure:
247 if (pointer_filter_verbose) {
248 fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned int) pointer,
249 (unsigned int) start_addr, *start_addr);
253 case type_InstanceHeader:
254 if (pointer_filter_verbose) {
255 fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer,
256 (unsigned int) start_addr, *start_addr);
260 /* the valid other immediate pointer objects */
261 case type_SimpleVector:
264 #ifdef type_ComplexSingleFloat
265 case type_ComplexSingleFloat:
267 #ifdef type_ComplexDoubleFloat
268 case type_ComplexDoubleFloat:
270 #ifdef type_ComplexLongFloat
271 case type_ComplexLongFloat:
273 case type_SimpleArray:
274 case type_ComplexString:
275 case type_ComplexBitVector:
276 case type_ComplexVector:
277 case type_ComplexArray:
278 case type_ValueCellHeader:
279 case type_SymbolHeader:
281 case type_CodeHeader:
283 case type_SingleFloat:
284 case type_DoubleFloat:
285 #ifdef type_LongFloat
288 case type_SimpleString:
289 case type_SimpleBitVector:
290 case type_SimpleArrayUnsignedByte2:
291 case type_SimpleArrayUnsignedByte4:
292 case type_SimpleArrayUnsignedByte8:
293 case type_SimpleArrayUnsignedByte16:
294 case type_SimpleArrayUnsignedByte32:
295 #ifdef type_SimpleArraySignedByte8
296 case type_SimpleArraySignedByte8:
298 #ifdef type_SimpleArraySignedByte16
299 case type_SimpleArraySignedByte16:
301 #ifdef type_SimpleArraySignedByte30
302 case type_SimpleArraySignedByte30:
304 #ifdef type_SimpleArraySignedByte32
305 case type_SimpleArraySignedByte32:
307 case type_SimpleArraySingleFloat:
308 case type_SimpleArrayDoubleFloat:
309 #ifdef type_SimpleArrayLongFloat
310 case type_SimpleArrayLongFloat:
312 #ifdef type_SimpleArrayComplexSingleFloat
313 case type_SimpleArrayComplexSingleFloat:
315 #ifdef type_SimpleArrayComplexDoubleFloat
316 case type_SimpleArrayComplexDoubleFloat:
318 #ifdef type_SimpleArrayComplexLongFloat
319 case type_SimpleArrayComplexLongFloat:
322 case type_WeakPointer:
326 if (pointer_filter_verbose) {
327 fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer,
328 (unsigned int) start_addr, *start_addr);
334 if (pointer_filter_verbose) {
335 fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer,
336 (unsigned int) start_addr, *start_addr);
345 #define MAX_STACK_POINTERS 256
346 lispobj *valid_stack_locations[MAX_STACK_POINTERS];
347 unsigned int num_valid_stack_locations;
349 #define MAX_STACK_RETURN_ADDRESSES 128
350 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
351 lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
352 unsigned int num_valid_stack_ra_locations;
354 /* Identify valid stack slots. */
356 setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
358 lispobj *sp = lowaddr;
359 num_valid_stack_locations = 0;
360 num_valid_stack_ra_locations = 0;
361 for (sp = lowaddr; sp < base; sp++) {
363 /* Find the object start address */
364 lispobj *start_addr = search_dynamic_space((void *)thing);
366 /* We need to allow raw pointers into Code objects for
367 * return addresses. This will also pick up pointers to
368 * functions in code objects. */
369 if (TypeOf(*start_addr) == type_CodeHeader) {
370 gc_assert(num_valid_stack_ra_locations <
371 MAX_STACK_RETURN_ADDRESSES);
372 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
373 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
374 (lispobj *)((int)start_addr + type_OtherPointer);
376 if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
377 gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
378 valid_stack_locations[num_valid_stack_locations++] = sp;
383 if (pointer_filter_verbose) {
384 fprintf(stderr, "number of valid stack pointers = %d\n",
385 num_valid_stack_locations);
386 fprintf(stderr, "number of stack return addresses = %d\n",
387 num_valid_stack_ra_locations);
392 pscav_i386_stack(void)
396 for (i = 0; i < num_valid_stack_locations; i++)
397 pscav(valid_stack_locations[i], 1, 0);
399 for (i = 0; i < num_valid_stack_ra_locations; i++) {
400 lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
401 pscav(&code_obj, 1, 0);
402 if (pointer_filter_verbose) {
403 fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
404 *valid_stack_ra_locations[i],
405 (int)(*valid_stack_ra_locations[i])
406 - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
407 (unsigned int) valid_stack_ra_code_objects[i], code_obj);
409 *valid_stack_ra_locations[i] =
410 ((int)(*valid_stack_ra_locations[i])
411 - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
419 pscav_later(lispobj *where, int count)
423 if (count > LATERMAXCOUNT) {
424 while (count > LATERMAXCOUNT) {
425 pscav_later(where, LATERMAXCOUNT);
426 count -= LATERMAXCOUNT;
427 where += LATERMAXCOUNT;
431 if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
432 (later_count == LATERBLOCKSIZE-1 && count > 1)) {
433 new = (struct later *)malloc(sizeof(struct later));
434 new->next = later_blocks;
435 if (later_blocks && later_count < LATERBLOCKSIZE)
436 later_blocks->u[later_count].ptr = NULL;
442 later_blocks->u[later_count++].count = count;
443 later_blocks->u[later_count++].ptr = where;
448 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
451 lispobj result, *new, *old;
453 nwords = 1 + HeaderValue(header);
456 old = (lispobj *)native_pointer(thing);
458 new = read_only_free;
459 read_only_free += CEILING(nwords, 2);
463 static_free += CEILING(nwords, 2);
467 bcopy(old, new, nwords * sizeof(lispobj));
469 /* Deposit forwarding pointer. */
470 result = (lispobj)new | LowtagOf(thing);
474 pscav(new, nwords, constant);
479 /* We need to look at the layout to see whether it is a pure structure
480 * class, and only then can we transport as constant. If it is pure,
481 * we can ALWAYS transport as a constant. */
483 ptrans_instance(lispobj thing, lispobj header, boolean constant)
485 lispobj layout = ((struct instance *)native_pointer(thing))->slots[0];
486 lispobj pure = ((struct instance *)native_pointer(layout))->slots[15];
490 return (ptrans_boxed(thing, header, 1));
492 return (ptrans_boxed(thing, header, 0));
495 /* Substructure: special case for the COMPACT-INFO-ENVs,
496 * where the instance may have a point to the dynamic
497 * space placed into it (e.g. the cache-name slot), but
498 * the lists and arrays at the time of a purify can be
499 * moved to the RO space. */
501 lispobj result, *new, *old;
503 nwords = 1 + HeaderValue(header);
506 old = (lispobj *)native_pointer(thing);
508 static_free += CEILING(nwords, 2);
511 bcopy(old, new, nwords * sizeof(lispobj));
513 /* Deposit forwarding pointer. */
514 result = (lispobj)new | LowtagOf(thing);
518 pscav(new, nwords, 1);
524 return NIL; /* dummy value: return something ... */
529 ptrans_fdefn(lispobj thing, lispobj header)
532 lispobj result, *new, *old, oldfn;
535 nwords = 1 + HeaderValue(header);
538 old = (lispobj *)native_pointer(thing);
540 static_free += CEILING(nwords, 2);
543 bcopy(old, new, nwords * sizeof(lispobj));
545 /* Deposit forwarding pointer. */
546 result = (lispobj)new | LowtagOf(thing);
549 /* Scavenge the function. */
550 fdefn = (struct fdefn *)new;
551 oldfn = fdefn->function;
552 pscav(&fdefn->function, 1, 0);
553 if ((char *)oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
554 fdefn->raw_addr = (char *)fdefn->function + RAW_ADDR_OFFSET;
560 ptrans_unboxed(lispobj thing, lispobj header)
563 lispobj result, *new, *old;
565 nwords = 1 + HeaderValue(header);
568 old = (lispobj *)native_pointer(thing);
569 new = read_only_free;
570 read_only_free += CEILING(nwords, 2);
573 bcopy(old, new, nwords * sizeof(lispobj));
575 /* Deposit forwarding pointer. */
576 result = (lispobj)new | LowtagOf(thing);
583 ptrans_vector(lispobj thing, int bits, int extra,
584 boolean boxed, boolean constant)
586 struct vector *vector;
588 lispobj result, *new;
590 vector = (struct vector *)native_pointer(thing);
591 nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
593 if (boxed && !constant) {
595 static_free += CEILING(nwords, 2);
598 new = read_only_free;
599 read_only_free += CEILING(nwords, 2);
602 bcopy(vector, new, nwords * sizeof(lispobj));
604 result = (lispobj)new | LowtagOf(thing);
605 vector->header = result;
608 pscav(new, nwords, constant);
615 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
617 int nheader_words, ncode_words, nwords;
618 void *constants_start_addr, *constants_end_addr;
619 void *code_start_addr, *code_end_addr;
620 lispobj fixups = NIL;
621 unsigned displacement = (unsigned)new_code - (unsigned)old_code;
622 struct vector *fixups_vector;
624 /* Byte compiled code has no fixups. The trace table offset will be
625 * a fixnum if it's x86 compiled code - check. */
626 if (new_code->trace_table_offset & 0x3)
629 /* Else it's x86 machine code. */
630 ncode_words = fixnum_value(new_code->code_size);
631 nheader_words = HeaderValue(*(lispobj *)new_code);
632 nwords = ncode_words + nheader_words;
634 constants_start_addr = (void *)new_code + 5*4;
635 constants_end_addr = (void *)new_code + nheader_words*4;
636 code_start_addr = (void *)new_code + nheader_words*4;
637 code_end_addr = (void *)new_code + nwords*4;
639 /* The first constant should be a pointer to the fixups for this
640 * code objects. Check. */
641 fixups = new_code->constants[0];
643 /* It will be 0 or the unbound-marker if there are no fixups, and
644 * will be an other-pointer to a vector if it is valid. */
646 (fixups==type_UnboundMarker) ||
647 !is_lisp_pointer(fixups)) {
649 /* Check for a possible errors. */
650 sniff_code_object(new_code,displacement);
655 fixups_vector = (struct vector *)native_pointer(fixups);
657 /* Could be pointing to a forwarding pointer. */
658 if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups))
659 && forwarding_pointer_p(*(lispobj *)fixups_vector)) {
660 /* If so then follow it. */
661 fixups_vector = (struct vector *)native_pointer(*(lispobj *)fixups_vector);
664 if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
665 /* We got the fixups for the code block. Now work through the vector,
666 * and apply a fixup at each address. */
667 int length = fixnum_value(fixups_vector->length);
669 for (i=0; i<length; i++) {
670 unsigned offset = fixups_vector->data[i];
671 /* Now check the current value of offset. */
672 unsigned old_value = *(unsigned *)((unsigned)code_start_addr + offset);
674 /* If it's within the old_code object then it must be an
675 * absolute fixup (relative ones are not saved) */
676 if ((old_value>=(unsigned)old_code)
677 && (old_value<((unsigned)old_code + nwords*4)))
678 /* So add the dispacement. */
679 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
682 /* It is outside the old code object so it must be a relative
683 * fixup (absolute fixups are not saved). So subtract the
685 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
690 /* No longer need the fixups. */
691 new_code->constants[0] = 0;
694 /* Check for possible errors. */
695 sniff_code_object(new_code,displacement);
701 ptrans_code(lispobj thing)
703 struct code *code, *new;
705 lispobj func, result;
707 code = (struct code *)native_pointer(thing);
708 nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
710 new = (struct code *)read_only_free;
711 read_only_free += CEILING(nwords, 2);
713 bcopy(code, new, nwords * sizeof(lispobj));
716 apply_code_fixups_during_purify(code,new);
719 result = (lispobj)new | type_OtherPointer;
721 /* Stick in a forwarding pointer for the code object. */
722 *(lispobj *)code = result;
724 /* Put in forwarding pointers for all the functions. */
725 for (func = code->entry_points;
727 func = ((struct function *)native_pointer(func))->next) {
729 gc_assert(LowtagOf(func) == type_FunctionPointer);
731 *(lispobj *)native_pointer(func) = result + (func - thing);
734 /* Arrange to scavenge the debug info later. */
735 pscav_later(&new->debug_info, 1);
737 if(new->trace_table_offset & 0x3)
739 pscav(&new->trace_table_offset, 1, 0);
741 new->trace_table_offset = NIL; /* limit lifetime */
744 /* Scavenge the constants. */
745 pscav(new->constants, HeaderValue(new->header)-5, 1);
747 /* Scavenge all the functions. */
748 pscav(&new->entry_points, 1, 1);
749 for (func = new->entry_points;
751 func = ((struct function *)native_pointer(func))->next) {
752 gc_assert(LowtagOf(func) == type_FunctionPointer);
753 gc_assert(!dynamic_pointer_p(func));
756 /* Temporarly convert the self pointer to a real function
758 ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
760 pscav(&((struct function *)native_pointer(func))->self, 2, 1);
762 ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
764 pscav_later(&((struct function *)native_pointer(func))->name, 3);
771 ptrans_func(lispobj thing, lispobj header)
774 lispobj code, *new, *old, result;
775 struct function *function;
777 /* Thing can either be a function header, a closure function
778 * header, a closure, or a funcallable-instance. If it's a closure
779 * or a funcallable-instance, we do the same as ptrans_boxed.
780 * Otherwise we have to do something strange, 'cause it is buried
781 * inside a code object. */
783 if (TypeOf(header) == type_FunctionHeader ||
784 TypeOf(header) == type_ClosureFunctionHeader) {
786 /* We can only end up here if the code object has not been
787 * scavenged, because if it had been scavenged, forwarding pointers
788 * would have been left behind for all the entry points. */
790 function = (struct function *)native_pointer(thing);
792 (native_pointer(thing) -
793 (HeaderValue(function->header)*sizeof(lispobj))) |
796 /* This will cause the function's header to be replaced with a
797 * forwarding pointer. */
800 /* So we can just return that. */
801 return function->header;
804 /* It's some kind of closure-like thing. */
805 nwords = 1 + HeaderValue(header);
806 old = (lispobj *)native_pointer(thing);
808 /* Allocate the new one. */
809 if (TypeOf(header) == type_FuncallableInstanceHeader) {
810 /* FINs *must* not go in read_only space. */
812 static_free += CEILING(nwords, 2);
815 /* Closures can always go in read-only space, 'cause they
818 new = read_only_free;
819 read_only_free += CEILING(nwords, 2);
822 bcopy(old, new, nwords * sizeof(lispobj));
824 /* Deposit forwarding pointer. */
825 result = (lispobj)new | LowtagOf(thing);
829 pscav(new, nwords, 0);
836 ptrans_returnpc(lispobj thing, lispobj header)
840 /* Find the corresponding code object. */
841 code = thing - HeaderValue(header)*sizeof(lispobj);
843 /* Make sure it's been transported. */
844 new = *(lispobj *)native_pointer(code);
845 if (!forwarding_pointer_p(new))
846 new = ptrans_code(code);
848 /* Maintain the offset: */
849 return new + (thing - code);
852 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
855 ptrans_list(lispobj thing, boolean constant)
857 struct cons *old, *new, *orig;
861 orig = (struct cons *)read_only_free;
863 orig = (struct cons *)static_free;
867 /* Allocate a new cons cell. */
868 old = (struct cons *)native_pointer(thing);
870 new = (struct cons *)read_only_free;
871 read_only_free += WORDS_PER_CONS;
874 new = (struct cons *)static_free;
875 static_free += WORDS_PER_CONS;
878 /* Copy the cons cell and keep a pointer to the cdr. */
880 thing = new->cdr = old->cdr;
882 /* Set up the forwarding pointer. */
883 *(lispobj *)old = ((lispobj)new) | type_ListPointer;
885 /* And count this cell. */
887 } while (LowtagOf(thing) == type_ListPointer &&
888 dynamic_pointer_p(thing) &&
889 !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
891 /* Scavenge the list we just copied. */
892 pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
894 return ((lispobj)orig) | type_ListPointer;
898 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
900 switch (TypeOf(header)) {
902 case type_SingleFloat:
903 case type_DoubleFloat:
904 #ifdef type_LongFloat
907 #ifdef type_ComplexSingleFloat
908 case type_ComplexSingleFloat:
910 #ifdef type_ComplexDoubleFloat
911 case type_ComplexDoubleFloat:
913 #ifdef type_ComplexLongFloat
914 case type_ComplexLongFloat:
917 return ptrans_unboxed(thing, header);
921 case type_SimpleArray:
922 case type_ComplexString:
923 case type_ComplexVector:
924 case type_ComplexArray:
925 return ptrans_boxed(thing, header, constant);
927 case type_ValueCellHeader:
928 case type_WeakPointer:
929 return ptrans_boxed(thing, header, 0);
931 case type_SymbolHeader:
932 return ptrans_boxed(thing, header, 0);
934 case type_SimpleString:
935 return ptrans_vector(thing, 8, 1, 0, constant);
937 case type_SimpleBitVector:
938 return ptrans_vector(thing, 1, 0, 0, constant);
940 case type_SimpleVector:
941 return ptrans_vector(thing, 32, 0, 1, constant);
943 case type_SimpleArrayUnsignedByte2:
944 return ptrans_vector(thing, 2, 0, 0, constant);
946 case type_SimpleArrayUnsignedByte4:
947 return ptrans_vector(thing, 4, 0, 0, constant);
949 case type_SimpleArrayUnsignedByte8:
950 #ifdef type_SimpleArraySignedByte8
951 case type_SimpleArraySignedByte8:
953 return ptrans_vector(thing, 8, 0, 0, constant);
955 case type_SimpleArrayUnsignedByte16:
956 #ifdef type_SimpleArraySignedByte16
957 case type_SimpleArraySignedByte16:
959 return ptrans_vector(thing, 16, 0, 0, constant);
961 case type_SimpleArrayUnsignedByte32:
962 #ifdef type_SimpleArraySignedByte30
963 case type_SimpleArraySignedByte30:
965 #ifdef type_SimpleArraySignedByte32
966 case type_SimpleArraySignedByte32:
968 return ptrans_vector(thing, 32, 0, 0, constant);
970 case type_SimpleArraySingleFloat:
971 return ptrans_vector(thing, 32, 0, 0, constant);
973 case type_SimpleArrayDoubleFloat:
974 return ptrans_vector(thing, 64, 0, 0, constant);
976 #ifdef type_SimpleArrayLongFloat
977 case type_SimpleArrayLongFloat:
979 return ptrans_vector(thing, 96, 0, 0, constant);
982 return ptrans_vector(thing, 128, 0, 0, constant);
986 #ifdef type_SimpleArrayComplexSingleFloat
987 case type_SimpleArrayComplexSingleFloat:
988 return ptrans_vector(thing, 64, 0, 0, constant);
991 #ifdef type_SimpleArrayComplexDoubleFloat
992 case type_SimpleArrayComplexDoubleFloat:
993 return ptrans_vector(thing, 128, 0, 0, constant);
996 #ifdef type_SimpleArrayComplexLongFloat
997 case type_SimpleArrayComplexLongFloat:
999 return ptrans_vector(thing, 192, 0, 0, constant);
1002 return ptrans_vector(thing, 256, 0, 0, constant);
1006 case type_CodeHeader:
1007 return ptrans_code(thing);
1009 case type_ReturnPcHeader:
1010 return ptrans_returnpc(thing, header);
1013 return ptrans_fdefn(thing, header);
1016 /* Should only come across other pointers to the above stuff. */
1023 pscav_fdefn(struct fdefn *fdefn)
1027 fix_func = ((char *)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr);
1028 pscav(&fdefn->name, 1, 1);
1029 pscav(&fdefn->function, 1, 0);
1031 fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
1032 return sizeof(struct fdefn) / sizeof(lispobj);
1036 /* now putting code objects in static space */
1038 pscav_code(struct code*code)
1042 nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
1044 /* Arrange to scavenge the debug info later. */
1045 pscav_later(&code->debug_info, 1);
1047 /* Scavenge the constants. */
1048 pscav(code->constants, HeaderValue(code->header)-5, 1);
1050 /* Scavenge all the functions. */
1051 pscav(&code->entry_points, 1, 1);
1052 for (func = code->entry_points;
1054 func = ((struct function *)native_pointer(func))->next) {
1055 gc_assert(LowtagOf(func) == type_FunctionPointer);
1056 gc_assert(!dynamic_pointer_p(func));
1059 /* Temporarly convert the self pointer to a real function
1061 ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
1063 pscav(&((struct function *)native_pointer(func))->self, 2, 1);
1065 ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
1067 pscav_later(&((struct function *)native_pointer(func))->name, 3);
1070 return CEILING(nwords,2);
1075 pscav(lispobj *addr, int nwords, boolean constant)
1077 lispobj thing, *thingp, header;
1078 int count = 0; /* (0 = dummy init value to stop GCC warning) */
1079 struct vector *vector;
1081 while (nwords > 0) {
1083 if (is_lisp_pointer(thing)) {
1084 /* It's a pointer. Is it something we might have to move? */
1085 if (dynamic_pointer_p(thing)) {
1086 /* Maybe. Have we already moved it? */
1087 thingp = (lispobj *)native_pointer(thing);
1089 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
1090 /* Yep, so just copy the forwarding pointer. */
1093 /* Nope, copy the object. */
1094 switch (LowtagOf(thing)) {
1095 case type_FunctionPointer:
1096 thing = ptrans_func(thing, header);
1099 case type_ListPointer:
1100 thing = ptrans_list(thing, constant);
1103 case type_InstancePointer:
1104 thing = ptrans_instance(thing, header, constant);
1107 case type_OtherPointer:
1108 thing = ptrans_otherptr(thing, header, constant);
1112 /* It was a pointer, but not one of them? */
1120 else if (thing & 3) {
1121 /* It's an other immediate. Maybe the header for an unboxed */
1123 switch (TypeOf(thing)) {
1125 case type_SingleFloat:
1126 case type_DoubleFloat:
1127 #ifdef type_LongFloat
1128 case type_LongFloat:
1131 /* It's an unboxed simple object. */
1132 count = HeaderValue(thing)+1;
1135 case type_SimpleVector:
1136 if (HeaderValue(thing) == subtype_VectorValidHashing)
1137 *addr = (subtype_VectorMustRehash<<type_Bits) |
1142 case type_SimpleString:
1143 vector = (struct vector *)addr;
1144 count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
1147 case type_SimpleBitVector:
1148 vector = (struct vector *)addr;
1149 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
1152 case type_SimpleArrayUnsignedByte2:
1153 vector = (struct vector *)addr;
1154 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
1157 case type_SimpleArrayUnsignedByte4:
1158 vector = (struct vector *)addr;
1159 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
1162 case type_SimpleArrayUnsignedByte8:
1163 #ifdef type_SimpleArraySignedByte8
1164 case type_SimpleArraySignedByte8:
1166 vector = (struct vector *)addr;
1167 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
1170 case type_SimpleArrayUnsignedByte16:
1171 #ifdef type_SimpleArraySignedByte16
1172 case type_SimpleArraySignedByte16:
1174 vector = (struct vector *)addr;
1175 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
1178 case type_SimpleArrayUnsignedByte32:
1179 #ifdef type_SimpleArraySignedByte30
1180 case type_SimpleArraySignedByte30:
1182 #ifdef type_SimpleArraySignedByte32
1183 case type_SimpleArraySignedByte32:
1185 vector = (struct vector *)addr;
1186 count = CEILING(fixnum_value(vector->length)+2,2);
1189 case type_SimpleArraySingleFloat:
1190 vector = (struct vector *)addr;
1191 count = CEILING(fixnum_value(vector->length)+2,2);
1194 case type_SimpleArrayDoubleFloat:
1195 #ifdef type_SimpleArrayComplexSingleFloat
1196 case type_SimpleArrayComplexSingleFloat:
1198 vector = (struct vector *)addr;
1199 count = fixnum_value(vector->length)*2+2;
1202 #ifdef type_SimpleArrayLongFloat
1203 case type_SimpleArrayLongFloat:
1204 vector = (struct vector *)addr;
1206 count = fixnum_value(vector->length)*3+2;
1209 count = fixnum_value(vector->length)*4+2;
1214 #ifdef type_SimpleArrayComplexDoubleFloat
1215 case type_SimpleArrayComplexDoubleFloat:
1216 vector = (struct vector *)addr;
1217 count = fixnum_value(vector->length)*4+2;
1221 #ifdef type_SimpleArrayComplexLongFloat
1222 case type_SimpleArrayComplexLongFloat:
1223 vector = (struct vector *)addr;
1225 count = fixnum_value(vector->length)*6+2;
1228 count = fixnum_value(vector->length)*8+2;
1233 case type_CodeHeader:
1235 gc_abort(); /* no code headers in static space */
1237 count = pscav_code((struct code*)addr);
1241 case type_FunctionHeader:
1242 case type_ClosureFunctionHeader:
1243 case type_ReturnPcHeader:
1244 /* We should never hit any of these, 'cause they occur
1245 * buried in the middle of code objects. */
1250 case type_ClosureHeader:
1251 case type_FuncallableInstanceHeader:
1252 case type_ByteCodeFunction:
1253 case type_ByteCodeClosure:
1254 /* The function self pointer needs special care on the
1255 * x86 because it is the real entry point. */
1257 lispobj fun = ((struct closure *)addr)->function
1259 pscav(&fun, 1, constant);
1260 ((struct closure *)addr)->function = fun + RAW_ADDR_OFFSET;
1266 case type_WeakPointer:
1267 /* Weak pointers get preserved during purify, 'cause I
1268 * don't feel like figuring out how to break them. */
1269 pscav(addr+1, 2, constant);
1274 /* We have to handle fdefn objects specially, so we
1275 * can fix up the raw function address. */
1276 count = pscav_fdefn((struct fdefn *)addr);
1285 /* It's a fixnum. */
1297 purify(lispobj static_roots, lispobj read_only_roots)
1301 struct later *laters, *next;
1304 printf("[doing purification:");
1308 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
1309 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
1310 * its error simply by a. printing a string b. to stdout instead
1312 printf(" Ack! Can't purify interrupt contexts. ");
1317 #if defined(__i386__)
1318 dynamic_space_free_pointer =
1319 (lispobj*)SymbolValue(ALLOCATION_POINTER);
1322 read_only_end = read_only_free =
1323 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1324 static_end = static_free =
1325 (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
1333 gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1));
1334 setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END);
1337 pscav(&static_roots, 1, 0);
1338 pscav(&read_only_roots, 1, 1);
1341 printf(" handlers");
1344 pscav((lispobj *) interrupt_handlers,
1345 sizeof(interrupt_handlers) / sizeof(lispobj),
1353 pscav((lispobj *)CONTROL_STACK_START,
1354 current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
1363 printf(" bindings");
1366 #if !defined(__i386__)
1367 pscav( (lispobj *)BINDING_STACK_START,
1368 (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
1371 pscav( (lispobj *)BINDING_STACK_START,
1372 (lispobj *)SymbolValue(BINDING_STACK_POINTER) -
1373 (lispobj *)BINDING_STACK_START,
1377 /* The original CMU CL code had scavenge-read-only-space code
1378 * controlled by the Lisp-level variable
1379 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
1380 * wasn't documented under what circumstances it was useful or
1381 * safe to turn it on, so it's been turned off in SBCL. If you
1382 * want/need this functionality, and can test and document it,
1383 * please submit a patch. */
1385 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
1386 && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1387 unsigned read_only_space_size =
1388 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1389 (lispobj *)READ_ONLY_SPACE_START;
1391 "scavenging read only space: %d bytes\n",
1392 read_only_space_size * sizeof(lispobj));
1393 pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
1401 clean = (lispobj *)STATIC_SPACE_START;
1403 while (clean != static_free)
1404 clean = pscav(clean, static_free - clean, 0);
1405 laters = later_blocks;
1406 count = later_count;
1407 later_blocks = NULL;
1409 while (laters != NULL) {
1410 for (i = 0; i < count; i++) {
1411 if (laters->u[i].count == 0) {
1413 } else if (laters->u[i].count <= LATERMAXCOUNT) {
1414 pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
1417 pscav(laters->u[i].ptr, 1, 1);
1420 next = laters->next;
1423 count = LATERBLOCKSIZE;
1425 } while (clean != static_free || later_blocks != NULL);
1432 os_zero((os_vm_address_t) current_dynamic_space,
1433 (os_vm_size_t) DYNAMIC_SPACE_SIZE);
1435 /* Zero the stack. Note that the stack is also zeroed by SUB-GC
1436 * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
1438 os_zero((os_vm_address_t) current_control_stack_pointer,
1439 (os_vm_size_t) (CONTROL_STACK_SIZE -
1440 ((current_control_stack_pointer -
1441 (lispobj *)CONTROL_STACK_START) *
1445 /* It helps to update the heap free pointers so that free_heap can
1446 * verify after it's done. */
1447 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
1448 SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
1450 #if !defined(__i386__)
1451 dynamic_space_free_pointer = current_dynamic_space;
1456 #error unsupported case /* in CMU CL, was "ibmrt using GC" */