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 /* pw--The trace_table_offset slot can contain a list pointer. This
1045 * occurs when the code object is a top level form that initializes
1046 * a byte-compiled function. The fact that PURIFY was ignoring this
1047 * slot may be a bug unrelated to the x86 port, except that TLF's
1048 * normally become unreachable after the loader calls them and
1049 * won't be seen by PURIFY at all!! */
1050 if(code->trace_table_offset & 0x3)
1052 pscav(&code->trace_table_offset, 1, 0);
1054 code->trace_table_offset = NIL; /* limit lifetime */
1057 /* Arrange to scavenge the debug info later. */
1058 pscav_later(&code->debug_info, 1);
1060 /* Scavenge the constants. */
1061 pscav(code->constants, HeaderValue(code->header)-5, 1);
1063 /* Scavenge all the functions. */
1064 pscav(&code->entry_points, 1, 1);
1065 for (func = code->entry_points;
1067 func = ((struct function *)native_pointer(func))->next) {
1068 gc_assert(LowtagOf(func) == type_FunctionPointer);
1069 gc_assert(!dynamic_pointer_p(func));
1072 /* Temporarly convert the self pointer to a real function
1074 ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
1076 pscav(&((struct function *)native_pointer(func))->self, 2, 1);
1078 ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
1080 pscav_later(&((struct function *)native_pointer(func))->name, 3);
1083 return CEILING(nwords,2);
1088 pscav(lispobj *addr, int nwords, boolean constant)
1090 lispobj thing, *thingp, header;
1091 int count = 0; /* (0 = dummy init value to stop GCC warning) */
1092 struct vector *vector;
1094 while (nwords > 0) {
1096 if (is_lisp_pointer(thing)) {
1097 /* It's a pointer. Is it something we might have to move? */
1098 if (dynamic_pointer_p(thing)) {
1099 /* Maybe. Have we already moved it? */
1100 thingp = (lispobj *)native_pointer(thing);
1102 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
1103 /* Yep, so just copy the forwarding pointer. */
1106 /* Nope, copy the object. */
1107 switch (LowtagOf(thing)) {
1108 case type_FunctionPointer:
1109 thing = ptrans_func(thing, header);
1112 case type_ListPointer:
1113 thing = ptrans_list(thing, constant);
1116 case type_InstancePointer:
1117 thing = ptrans_instance(thing, header, constant);
1120 case type_OtherPointer:
1121 thing = ptrans_otherptr(thing, header, constant);
1125 /* It was a pointer, but not one of them? */
1133 else if (thing & 3) {
1134 /* It's an other immediate. Maybe the header for an unboxed */
1136 switch (TypeOf(thing)) {
1138 case type_SingleFloat:
1139 case type_DoubleFloat:
1140 #ifdef type_LongFloat
1141 case type_LongFloat:
1144 /* It's an unboxed simple object. */
1145 count = HeaderValue(thing)+1;
1148 case type_SimpleVector:
1149 if (HeaderValue(thing) == subtype_VectorValidHashing)
1150 *addr = (subtype_VectorMustRehash<<type_Bits) |
1155 case type_SimpleString:
1156 vector = (struct vector *)addr;
1157 count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
1160 case type_SimpleBitVector:
1161 vector = (struct vector *)addr;
1162 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
1165 case type_SimpleArrayUnsignedByte2:
1166 vector = (struct vector *)addr;
1167 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
1170 case type_SimpleArrayUnsignedByte4:
1171 vector = (struct vector *)addr;
1172 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
1175 case type_SimpleArrayUnsignedByte8:
1176 #ifdef type_SimpleArraySignedByte8
1177 case type_SimpleArraySignedByte8:
1179 vector = (struct vector *)addr;
1180 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
1183 case type_SimpleArrayUnsignedByte16:
1184 #ifdef type_SimpleArraySignedByte16
1185 case type_SimpleArraySignedByte16:
1187 vector = (struct vector *)addr;
1188 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
1191 case type_SimpleArrayUnsignedByte32:
1192 #ifdef type_SimpleArraySignedByte30
1193 case type_SimpleArraySignedByte30:
1195 #ifdef type_SimpleArraySignedByte32
1196 case type_SimpleArraySignedByte32:
1198 vector = (struct vector *)addr;
1199 count = CEILING(fixnum_value(vector->length)+2,2);
1202 case type_SimpleArraySingleFloat:
1203 vector = (struct vector *)addr;
1204 count = CEILING(fixnum_value(vector->length)+2,2);
1207 case type_SimpleArrayDoubleFloat:
1208 #ifdef type_SimpleArrayComplexSingleFloat
1209 case type_SimpleArrayComplexSingleFloat:
1211 vector = (struct vector *)addr;
1212 count = fixnum_value(vector->length)*2+2;
1215 #ifdef type_SimpleArrayLongFloat
1216 case type_SimpleArrayLongFloat:
1217 vector = (struct vector *)addr;
1219 count = fixnum_value(vector->length)*3+2;
1222 count = fixnum_value(vector->length)*4+2;
1227 #ifdef type_SimpleArrayComplexDoubleFloat
1228 case type_SimpleArrayComplexDoubleFloat:
1229 vector = (struct vector *)addr;
1230 count = fixnum_value(vector->length)*4+2;
1234 #ifdef type_SimpleArrayComplexLongFloat
1235 case type_SimpleArrayComplexLongFloat:
1236 vector = (struct vector *)addr;
1238 count = fixnum_value(vector->length)*6+2;
1241 count = fixnum_value(vector->length)*8+2;
1246 case type_CodeHeader:
1248 gc_abort(); /* no code headers in static space */
1250 count = pscav_code((struct code*)addr);
1254 case type_FunctionHeader:
1255 case type_ClosureFunctionHeader:
1256 case type_ReturnPcHeader:
1257 /* We should never hit any of these, 'cause they occur
1258 * buried in the middle of code objects. */
1263 case type_ClosureHeader:
1264 case type_FuncallableInstanceHeader:
1265 case type_ByteCodeFunction:
1266 case type_ByteCodeClosure:
1267 /* The function self pointer needs special care on the
1268 * x86 because it is the real entry point. */
1270 lispobj fun = ((struct closure *)addr)->function
1272 pscav(&fun, 1, constant);
1273 ((struct closure *)addr)->function = fun + RAW_ADDR_OFFSET;
1279 case type_WeakPointer:
1280 /* Weak pointers get preserved during purify, 'cause I
1281 * don't feel like figuring out how to break them. */
1282 pscav(addr+1, 2, constant);
1287 /* We have to handle fdefn objects specially, so we
1288 * can fix up the raw function address. */
1289 count = pscav_fdefn((struct fdefn *)addr);
1298 /* It's a fixnum. */
1310 purify(lispobj static_roots, lispobj read_only_roots)
1314 struct later *laters, *next;
1317 printf("[doing purification:");
1321 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
1322 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
1323 * its error simply by a. printing a string b. to stdout instead
1325 printf(" Ack! Can't purify interrupt contexts. ");
1330 #if defined(__i386__)
1331 dynamic_space_free_pointer =
1332 (lispobj*)SymbolValue(ALLOCATION_POINTER);
1335 read_only_end = read_only_free =
1336 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1337 static_end = static_free =
1338 (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
1346 gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1));
1347 setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END);
1350 pscav(&static_roots, 1, 0);
1351 pscav(&read_only_roots, 1, 1);
1354 printf(" handlers");
1357 pscav((lispobj *) interrupt_handlers,
1358 sizeof(interrupt_handlers) / sizeof(lispobj),
1366 pscav((lispobj *)CONTROL_STACK_START,
1367 current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
1376 printf(" bindings");
1379 #if !defined(__i386__)
1380 pscav( (lispobj *)BINDING_STACK_START,
1381 (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
1384 pscav( (lispobj *)BINDING_STACK_START,
1385 (lispobj *)SymbolValue(BINDING_STACK_POINTER) -
1386 (lispobj *)BINDING_STACK_START,
1390 /* The original CMU CL code had scavenge-read-only-space code
1391 * controlled by the Lisp-level variable
1392 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
1393 * wasn't documented under what circumstances it was useful or
1394 * safe to turn it on, so it's been turned off in SBCL. If you
1395 * want/need this functionality, and can test and document it,
1396 * please submit a patch. */
1398 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
1399 && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1400 unsigned read_only_space_size =
1401 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1402 (lispobj *)READ_ONLY_SPACE_START;
1404 "scavenging read only space: %d bytes\n",
1405 read_only_space_size * sizeof(lispobj));
1406 pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
1414 clean = (lispobj *)STATIC_SPACE_START;
1416 while (clean != static_free)
1417 clean = pscav(clean, static_free - clean, 0);
1418 laters = later_blocks;
1419 count = later_count;
1420 later_blocks = NULL;
1422 while (laters != NULL) {
1423 for (i = 0; i < count; i++) {
1424 if (laters->u[i].count == 0) {
1426 } else if (laters->u[i].count <= LATERMAXCOUNT) {
1427 pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
1430 pscav(laters->u[i].ptr, 1, 1);
1433 next = laters->next;
1436 count = LATERBLOCKSIZE;
1438 } while (clean != static_free || later_blocks != NULL);
1445 os_zero((os_vm_address_t) current_dynamic_space,
1446 (os_vm_size_t) DYNAMIC_SPACE_SIZE);
1448 /* Zero the stack. Note that the stack is also zeroed by SUB-GC
1449 * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
1451 os_zero((os_vm_address_t) current_control_stack_pointer,
1452 (os_vm_size_t) (CONTROL_STACK_SIZE -
1453 ((current_control_stack_pointer -
1454 (lispobj *)CONTROL_STACK_START) *
1458 /* It helps to update the heap free pointers so that free_heap can
1459 * verify after it's done. */
1460 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
1461 SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
1463 #if !defined(__i386__)
1464 dynamic_space_free_pointer = current_dynamic_space;
1469 #error unsupported case /* in CMU CL, was "ibmrt using GC" */