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>
27 #include "interrupt.h"
31 #include "gc-internal.h"
33 #include "genesis/primitive-objects.h"
34 #include "genesis/static-symbols.h"
38 #if defined(LISP_FEATURE_X86)
39 /* again, what's so special about the x86 that this is differently
40 * visible there than on other platforms? -dan 20010125
42 static lispobj
*dynamic_space_free_pointer
;
44 extern unsigned long bytes_consed_between_gcs
;
47 lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
50 #define gc_assert(ex) do { \
51 if (!(ex)) gc_abort(); \
58 /* These hold the original end of the read_only and static spaces so
59 * we can tell what are forwarding pointers. */
61 static lispobj
*read_only_end
, *static_end
;
63 static lispobj
*read_only_free
, *static_free
;
65 static lispobj
*pscav(lispobj
*addr
, int nwords
, boolean constant
);
67 #define LATERBLOCKSIZE 1020
68 #define LATERMAXCOUNT 10
77 } *later_blocks
= NULL
;
78 static int later_count
= 0;
80 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
81 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
83 /* FIXME: Shouldn't this be defined in sbcl.h? See also notes in
87 #define FUN_RAW_ADDR_OFFSET 0
89 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
93 forwarding_pointer_p(lispobj obj
)
95 lispobj
*ptr
= native_pointer(obj
);
97 return ((static_end
<= ptr
&& ptr
<= static_free
) ||
98 (read_only_end
<= ptr
&& ptr
<= read_only_free
));
102 dynamic_pointer_p(lispobj ptr
)
104 #ifndef LISP_FEATURE_GENCGC
105 return (ptr
>= (lispobj
)current_dynamic_space
107 ptr
< (lispobj
)dynamic_space_free_pointer
);
109 /* Be more conservative, and remember, this is a maybe. */
110 return (ptr
>= (lispobj
)DYNAMIC_SPACE_START
112 ptr
< (lispobj
)dynamic_space_free_pointer
);
116 static inline newspace_alloc(int nwords
, int constantp
)
119 nwords
=CEILING(nwords
,2);
122 read_only_free
+=nwords
;
132 #ifdef LISP_FEATURE_X86
134 #ifdef LISP_FEATURE_GENCGC
136 * enhanced x86/GENCGC stack scavenging by Douglas Crosher
138 * Scavenging the stack on the i386 is problematic due to conservative
139 * roots and raw return addresses. Here it is handled in two passes:
140 * the first pass runs before any objects are moved and tries to
141 * identify valid pointers and return address on the stack, the second
142 * pass scavenges these.
145 static unsigned pointer_filter_verbose
= 0;
147 /* FIXME: This is substantially the same code as
148 * possibly_valid_dynamic_space_pointer in gencgc.c. The only
149 * relevant difference seems to be that the gencgc code also checks
150 * for raw pointers into Code objects, whereas in purify these are
151 * checked separately in setup_i386_stack_scav - they go onto
152 * valid_stack_ra_locations instead of just valid_stack_locations */
155 valid_dynamic_space_pointer(lispobj
*pointer
, lispobj
*start_addr
)
157 /* If it's not a return address then it needs to be a valid Lisp
159 if (!is_lisp_pointer((lispobj
)pointer
))
162 /* Check that the object pointed to is consistent with the pointer
164 switch (lowtag_of((lispobj
)pointer
)) {
165 case FUN_POINTER_LOWTAG
:
166 /* Start_addr should be the enclosing code object, or a closure
168 switch (widetag_of(*start_addr
)) {
169 case CODE_HEADER_WIDETAG
:
170 /* This case is probably caught above. */
172 case CLOSURE_HEADER_WIDETAG
:
173 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
174 if ((int)pointer
!= ((int)start_addr
+FUN_POINTER_LOWTAG
)) {
175 if (pointer_filter_verbose
) {
176 fprintf(stderr
,"*Wf2: %x %x %x\n", (unsigned int) pointer
,
177 (unsigned int) start_addr
, *start_addr
);
183 if (pointer_filter_verbose
) {
184 fprintf(stderr
,"*Wf3: %x %x %x\n", (unsigned int) pointer
,
185 (unsigned int) start_addr
, *start_addr
);
190 case LIST_POINTER_LOWTAG
:
191 if ((int)pointer
!= ((int)start_addr
+LIST_POINTER_LOWTAG
)) {
192 if (pointer_filter_verbose
)
193 fprintf(stderr
,"*Wl1: %x %x %x\n", (unsigned int) pointer
,
194 (unsigned int) start_addr
, *start_addr
);
197 /* Is it plausible cons? */
198 if ((is_lisp_pointer(start_addr
[0])
199 || ((start_addr
[0] & 3) == 0) /* fixnum */
200 || (widetag_of(start_addr
[0]) == BASE_CHAR_WIDETAG
)
201 || (widetag_of(start_addr
[0]) == UNBOUND_MARKER_WIDETAG
))
202 && (is_lisp_pointer(start_addr
[1])
203 || ((start_addr
[1] & 3) == 0) /* fixnum */
204 || (widetag_of(start_addr
[1]) == BASE_CHAR_WIDETAG
)
205 || (widetag_of(start_addr
[1]) == UNBOUND_MARKER_WIDETAG
))) {
208 if (pointer_filter_verbose
) {
209 fprintf(stderr
,"*Wl2: %x %x %x\n", (unsigned int) pointer
,
210 (unsigned int) start_addr
, *start_addr
);
214 case INSTANCE_POINTER_LOWTAG
:
215 if ((int)pointer
!= ((int)start_addr
+INSTANCE_POINTER_LOWTAG
)) {
216 if (pointer_filter_verbose
) {
217 fprintf(stderr
,"*Wi1: %x %x %x\n", (unsigned int) pointer
,
218 (unsigned int) start_addr
, *start_addr
);
222 if (widetag_of(start_addr
[0]) != INSTANCE_HEADER_WIDETAG
) {
223 if (pointer_filter_verbose
) {
224 fprintf(stderr
,"*Wi2: %x %x %x\n", (unsigned int) pointer
,
225 (unsigned int) start_addr
, *start_addr
);
230 case OTHER_POINTER_LOWTAG
:
231 if ((int)pointer
!= ((int)start_addr
+OTHER_POINTER_LOWTAG
)) {
232 if (pointer_filter_verbose
) {
233 fprintf(stderr
,"*Wo1: %x %x %x\n", (unsigned int) pointer
,
234 (unsigned int) start_addr
, *start_addr
);
238 /* Is it plausible? Not a cons. XXX should check the headers. */
239 if (is_lisp_pointer(start_addr
[0]) || ((start_addr
[0] & 3) == 0)) {
240 if (pointer_filter_verbose
) {
241 fprintf(stderr
,"*Wo2: %x %x %x\n", (unsigned int) pointer
,
242 (unsigned int) start_addr
, *start_addr
);
246 switch (widetag_of(start_addr
[0])) {
247 case UNBOUND_MARKER_WIDETAG
:
248 case BASE_CHAR_WIDETAG
:
249 if (pointer_filter_verbose
) {
250 fprintf(stderr
,"*Wo3: %x %x %x\n", (unsigned int) pointer
,
251 (unsigned int) start_addr
, *start_addr
);
255 /* only pointed to by function pointers? */
256 case CLOSURE_HEADER_WIDETAG
:
257 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
258 if (pointer_filter_verbose
) {
259 fprintf(stderr
,"*Wo4: %x %x %x\n", (unsigned int) pointer
,
260 (unsigned int) start_addr
, *start_addr
);
264 case INSTANCE_HEADER_WIDETAG
:
265 if (pointer_filter_verbose
) {
266 fprintf(stderr
,"*Wo5: %x %x %x\n", (unsigned int) pointer
,
267 (unsigned int) start_addr
, *start_addr
);
271 /* the valid other immediate pointer objects */
272 case SIMPLE_VECTOR_WIDETAG
:
274 case COMPLEX_WIDETAG
:
275 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
276 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
278 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
279 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
281 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
282 case COMPLEX_LONG_FLOAT_WIDETAG
:
284 case SIMPLE_ARRAY_WIDETAG
:
285 case COMPLEX_BASE_STRING_WIDETAG
:
286 case COMPLEX_VECTOR_NIL_WIDETAG
:
287 case COMPLEX_BIT_VECTOR_WIDETAG
:
288 case COMPLEX_VECTOR_WIDETAG
:
289 case COMPLEX_ARRAY_WIDETAG
:
290 case VALUE_CELL_HEADER_WIDETAG
:
291 case SYMBOL_HEADER_WIDETAG
:
293 case CODE_HEADER_WIDETAG
:
295 case SINGLE_FLOAT_WIDETAG
:
296 case DOUBLE_FLOAT_WIDETAG
:
297 #ifdef LONG_FLOAT_WIDETAG
298 case LONG_FLOAT_WIDETAG
:
300 case SIMPLE_ARRAY_NIL_WIDETAG
:
301 case SIMPLE_BASE_STRING_WIDETAG
:
302 case SIMPLE_BIT_VECTOR_WIDETAG
:
303 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
304 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
305 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
306 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
307 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
308 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
309 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
310 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
311 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
312 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
313 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
315 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
316 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
318 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
319 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
321 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
322 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
324 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
325 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
326 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
327 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
329 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
330 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
332 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
333 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
335 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
336 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
339 case WEAK_POINTER_WIDETAG
:
343 if (pointer_filter_verbose
) {
344 fprintf(stderr
,"*Wo6: %x %x %x\n", (unsigned int) pointer
,
345 (unsigned int) start_addr
, *start_addr
);
351 if (pointer_filter_verbose
) {
352 fprintf(stderr
,"*W?: %x %x %x\n", (unsigned int) pointer
,
353 (unsigned int) start_addr
, *start_addr
);
362 #define MAX_STACK_POINTERS 256
363 lispobj
*valid_stack_locations
[MAX_STACK_POINTERS
];
364 unsigned int num_valid_stack_locations
;
366 #define MAX_STACK_RETURN_ADDRESSES 128
367 lispobj
*valid_stack_ra_locations
[MAX_STACK_RETURN_ADDRESSES
];
368 lispobj
*valid_stack_ra_code_objects
[MAX_STACK_RETURN_ADDRESSES
];
369 unsigned int num_valid_stack_ra_locations
;
371 /* Identify valid stack slots. */
373 setup_i386_stack_scav(lispobj
*lowaddr
, lispobj
*base
)
375 lispobj
*sp
= lowaddr
;
376 num_valid_stack_locations
= 0;
377 num_valid_stack_ra_locations
= 0;
378 for (sp
= lowaddr
; sp
< base
; sp
++) {
380 /* Find the object start address */
381 lispobj
*start_addr
= search_dynamic_space((void *)thing
);
383 /* We need to allow raw pointers into Code objects for
384 * return addresses. This will also pick up pointers to
385 * functions in code objects. */
386 if (widetag_of(*start_addr
) == CODE_HEADER_WIDETAG
) {
387 /* FIXME asserting here is a really dumb thing to do.
388 * If we've overflowed some arbitrary static limit, we
389 * should just refuse to purify, instead of killing
390 * the whole lisp session
392 gc_assert(num_valid_stack_ra_locations
<
393 MAX_STACK_RETURN_ADDRESSES
);
394 valid_stack_ra_locations
[num_valid_stack_ra_locations
] = sp
;
395 valid_stack_ra_code_objects
[num_valid_stack_ra_locations
++] =
396 (lispobj
*)((int)start_addr
+ OTHER_POINTER_LOWTAG
);
398 if (valid_dynamic_space_pointer((void *)thing
, start_addr
)) {
399 gc_assert(num_valid_stack_locations
< MAX_STACK_POINTERS
);
400 valid_stack_locations
[num_valid_stack_locations
++] = sp
;
405 if (pointer_filter_verbose
) {
406 fprintf(stderr
, "number of valid stack pointers = %d\n",
407 num_valid_stack_locations
);
408 fprintf(stderr
, "number of stack return addresses = %d\n",
409 num_valid_stack_ra_locations
);
414 pscav_i386_stack(void)
418 for (i
= 0; i
< num_valid_stack_locations
; i
++)
419 pscav(valid_stack_locations
[i
], 1, 0);
421 for (i
= 0; i
< num_valid_stack_ra_locations
; i
++) {
422 lispobj code_obj
= (lispobj
)valid_stack_ra_code_objects
[i
];
423 pscav(&code_obj
, 1, 0);
424 if (pointer_filter_verbose
) {
425 fprintf(stderr
,"*C moved RA %x to %x; for code object %x to %x\n",
426 *valid_stack_ra_locations
[i
],
427 (int)(*valid_stack_ra_locations
[i
])
428 - ((int)valid_stack_ra_code_objects
[i
] - (int)code_obj
),
429 (unsigned int) valid_stack_ra_code_objects
[i
], code_obj
);
431 *valid_stack_ra_locations
[i
] =
432 ((int)(*valid_stack_ra_locations
[i
])
433 - ((int)valid_stack_ra_code_objects
[i
] - (int)code_obj
));
441 pscav_later(lispobj
*where
, int count
)
445 if (count
> LATERMAXCOUNT
) {
446 while (count
> LATERMAXCOUNT
) {
447 pscav_later(where
, LATERMAXCOUNT
);
448 count
-= LATERMAXCOUNT
;
449 where
+= LATERMAXCOUNT
;
453 if (later_blocks
== NULL
|| later_count
== LATERBLOCKSIZE
||
454 (later_count
== LATERBLOCKSIZE
-1 && count
> 1)) {
455 new = (struct later
*)malloc(sizeof(struct later
));
456 new->next
= later_blocks
;
457 if (later_blocks
&& later_count
< LATERBLOCKSIZE
)
458 later_blocks
->u
[later_count
].ptr
= NULL
;
464 later_blocks
->u
[later_count
++].count
= count
;
465 later_blocks
->u
[later_count
++].ptr
= where
;
470 ptrans_boxed(lispobj thing
, lispobj header
, boolean constant
)
473 lispobj result
, *new, *old
;
475 nwords
= 1 + HeaderValue(header
);
478 old
= (lispobj
*)native_pointer(thing
);
479 new = newspace_alloc(nwords
,constant
);
482 bcopy(old
, new, nwords
* sizeof(lispobj
));
484 /* Deposit forwarding pointer. */
485 result
= make_lispobj(new, lowtag_of(thing
));
489 pscav(new, nwords
, constant
);
494 /* We need to look at the layout to see whether it is a pure structure
495 * class, and only then can we transport as constant. If it is pure,
496 * we can ALWAYS transport as a constant. */
498 ptrans_instance(lispobj thing
, lispobj header
, boolean
/* ignored */ constant
)
500 lispobj layout
= ((struct instance
*)native_pointer(thing
))->slots
[0];
501 lispobj pure
= ((struct instance
*)native_pointer(layout
))->slots
[15];
505 return (ptrans_boxed(thing
, header
, 1));
507 return (ptrans_boxed(thing
, header
, 0));
510 /* Substructure: special case for the COMPACT-INFO-ENVs,
511 * where the instance may have a point to the dynamic
512 * space placed into it (e.g. the cache-name slot), but
513 * the lists and arrays at the time of a purify can be
514 * moved to the RO space. */
516 lispobj result
, *new, *old
;
518 nwords
= 1 + HeaderValue(header
);
521 old
= (lispobj
*)native_pointer(thing
);
522 new = newspace_alloc(nwords
, 0); /* inconstant */
525 bcopy(old
, new, nwords
* sizeof(lispobj
));
527 /* Deposit forwarding pointer. */
528 result
= make_lispobj(new, lowtag_of(thing
));
532 pscav(new, nwords
, 1);
538 return NIL
; /* dummy value: return something ... */
543 ptrans_fdefn(lispobj thing
, lispobj header
)
546 lispobj result
, *new, *old
, oldfn
;
549 nwords
= 1 + HeaderValue(header
);
552 old
= (lispobj
*)native_pointer(thing
);
553 new = newspace_alloc(nwords
, 0); /* inconstant */
556 bcopy(old
, new, nwords
* sizeof(lispobj
));
558 /* Deposit forwarding pointer. */
559 result
= make_lispobj(new, lowtag_of(thing
));
562 /* Scavenge the function. */
563 fdefn
= (struct fdefn
*)new;
565 pscav(&fdefn
->fun
, 1, 0);
566 if ((char *)oldfn
+ FUN_RAW_ADDR_OFFSET
== fdefn
->raw_addr
)
567 fdefn
->raw_addr
= (char *)fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
;
573 ptrans_unboxed(lispobj thing
, lispobj header
)
576 lispobj result
, *new, *old
;
578 nwords
= 1 + HeaderValue(header
);
581 old
= (lispobj
*)native_pointer(thing
);
582 new = newspace_alloc(nwords
,1); /* always constant */
585 bcopy(old
, new, nwords
* sizeof(lispobj
));
587 /* Deposit forwarding pointer. */
588 result
= make_lispobj(new , lowtag_of(thing
));
595 ptrans_vector(lispobj thing
, int bits
, int extra
,
596 boolean boxed
, boolean constant
)
598 struct vector
*vector
;
600 lispobj result
, *new;
602 vector
= (struct vector
*)native_pointer(thing
);
603 nwords
= 2 + (CEILING((fixnum_value(vector
->length
)+extra
)*bits
,32)>>5);
605 new=newspace_alloc(nwords
, (constant
|| !boxed
));
606 bcopy(vector
, new, nwords
* sizeof(lispobj
));
608 result
= make_lispobj(new, lowtag_of(thing
));
609 vector
->header
= result
;
612 pscav(new, nwords
, constant
);
617 #ifdef LISP_FEATURE_X86
619 apply_code_fixups_during_purify(struct code
*old_code
, struct code
*new_code
)
621 int nheader_words
, ncode_words
, nwords
;
622 void *constants_start_addr
, *constants_end_addr
;
623 void *code_start_addr
, *code_end_addr
;
624 lispobj fixups
= NIL
;
625 unsigned displacement
= (unsigned)new_code
- (unsigned)old_code
;
626 struct vector
*fixups_vector
;
628 ncode_words
= fixnum_value(new_code
->code_size
);
629 nheader_words
= HeaderValue(*(lispobj
*)new_code
);
630 nwords
= ncode_words
+ nheader_words
;
632 constants_start_addr
= (void *)new_code
+ 5*4;
633 constants_end_addr
= (void *)new_code
+ nheader_words
*4;
634 code_start_addr
= (void *)new_code
+ nheader_words
*4;
635 code_end_addr
= (void *)new_code
+ nwords
*4;
637 /* The first constant should be a pointer to the fixups for this
638 * code objects. Check. */
639 fixups
= new_code
->constants
[0];
641 /* It will be 0 or the unbound-marker if there are no fixups, and
642 * will be an other-pointer to a vector if it is valid. */
644 (fixups
==UNBOUND_MARKER_WIDETAG
) ||
645 !is_lisp_pointer(fixups
)) {
646 #ifdef LISP_FEATURE_GENCGC
647 /* Check for a possible errors. */
648 sniff_code_object(new_code
,displacement
);
653 fixups_vector
= (struct vector
*)native_pointer(fixups
);
655 /* Could be pointing to a forwarding pointer. */
656 if (is_lisp_pointer(fixups
) && (dynamic_pointer_p(fixups
))
657 && forwarding_pointer_p(*(lispobj
*)fixups_vector
)) {
658 /* If so then follow it. */
660 (struct vector
*)native_pointer(*(lispobj
*)fixups_vector
);
663 if (widetag_of(fixups_vector
->header
) ==
664 SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
) {
665 /* We got the fixups for the code block. Now work through the
666 * vector, 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. */
673 *(unsigned *)((unsigned)code_start_addr
+ offset
);
675 /* If it's within the old_code object then it must be an
676 * absolute fixup (relative ones are not saved) */
677 if ((old_value
>=(unsigned)old_code
)
678 && (old_value
<((unsigned)old_code
+ nwords
*4)))
679 /* So add the dispacement. */
680 *(unsigned *)((unsigned)code_start_addr
+ offset
) = old_value
683 /* It is outside the old code object so it must be a relative
684 * fixup (absolute fixups are not saved). So subtract the
686 *(unsigned *)((unsigned)code_start_addr
+ offset
) = old_value
691 /* No longer need the fixups. */
692 new_code
->constants
[0] = 0;
694 #ifdef LISP_FEATURE_GENCGC
695 /* Check for possible errors. */
696 sniff_code_object(new_code
,displacement
);
702 ptrans_code(lispobj thing
)
704 struct code
*code
, *new;
706 lispobj func
, result
;
708 code
= (struct code
*)native_pointer(thing
);
709 nwords
= HeaderValue(code
->header
) + fixnum_value(code
->code_size
);
711 new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
713 bcopy(code
, new, nwords
* sizeof(lispobj
));
715 #ifdef LISP_FEATURE_X86
716 apply_code_fixups_during_purify(code
,new);
719 result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
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 simple_fun
*)native_pointer(func
))->next
) {
729 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
731 *(lispobj
*)native_pointer(func
) = result
+ (func
- thing
);
734 /* Arrange to scavenge the debug info later. */
735 pscav_later(&new->debug_info
, 1);
737 /* FIXME: why would this be a fixnum? */
738 if (!(new->trace_table_offset
& (EVEN_FIXNUM_LOWTAG
|ODD_FIXNUM_LOWTAG
)))
740 pscav(&new->trace_table_offset
, 1, 0);
742 new->trace_table_offset
= NIL
; /* limit lifetime */
745 /* Scavenge the constants. */
746 pscav(new->constants
, HeaderValue(new->header
)-5, 1);
748 /* Scavenge all the functions. */
749 pscav(&new->entry_points
, 1, 1);
750 for (func
= new->entry_points
;
752 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
753 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
754 gc_assert(!dynamic_pointer_p(func
));
756 #ifdef LISP_FEATURE_X86
757 /* Temporarily convert the self pointer to a real function pointer. */
758 ((struct simple_fun
*)native_pointer(func
))->self
759 -= FUN_RAW_ADDR_OFFSET
;
761 pscav(&((struct simple_fun
*)native_pointer(func
))->self
, 2, 1);
762 #ifdef LISP_FEATURE_X86
763 ((struct simple_fun
*)native_pointer(func
))->self
764 += FUN_RAW_ADDR_OFFSET
;
766 pscav_later(&((struct simple_fun
*)native_pointer(func
))->name
, 3);
773 ptrans_func(lispobj thing
, lispobj header
)
776 lispobj code
, *new, *old
, result
;
777 struct simple_fun
*function
;
779 /* Thing can either be a function header, a closure function
780 * header, a closure, or a funcallable-instance. If it's a closure
781 * or a funcallable-instance, we do the same as ptrans_boxed.
782 * Otherwise we have to do something strange, 'cause it is buried
783 * inside a code object. */
785 if (widetag_of(header
) == SIMPLE_FUN_HEADER_WIDETAG
) {
787 /* We can only end up here if the code object has not been
788 * scavenged, because if it had been scavenged, forwarding pointers
789 * would have been left behind for all the entry points. */
791 function
= (struct simple_fun
*)native_pointer(thing
);
794 ((native_pointer(thing
) -
795 (HeaderValue(function
->header
))), OTHER_POINTER_LOWTAG
);
797 /* This will cause the function's header to be replaced with a
798 * forwarding pointer. */
802 /* So we can just return that. */
803 return function
->header
;
806 /* It's some kind of closure-like thing. */
807 nwords
= 1 + HeaderValue(header
);
808 old
= (lispobj
*)native_pointer(thing
);
810 /* Allocate the new one. FINs *must* not go in read_only
811 * space. Closures can; they never change */
814 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG
));
817 bcopy(old
, new, nwords
* sizeof(lispobj
));
819 /* Deposit forwarding pointer. */
820 result
= make_lispobj(new, lowtag_of(thing
));
824 pscav(new, nwords
, 0);
831 ptrans_returnpc(lispobj thing
, lispobj header
)
835 /* Find the corresponding code object. */
836 code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
838 /* Make sure it's been transported. */
839 new = *(lispobj
*)native_pointer(code
);
840 if (!forwarding_pointer_p(new))
841 new = ptrans_code(code
);
843 /* Maintain the offset: */
844 return new + (thing
- code
);
847 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
850 ptrans_list(lispobj thing
, boolean constant
)
852 struct cons
*old
, *new, *orig
;
855 orig
= newspace_alloc(0,constant
);
859 /* Allocate a new cons cell. */
860 old
= (struct cons
*)native_pointer(thing
);
861 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
863 /* Copy the cons cell and keep a pointer to the cdr. */
865 thing
= new->cdr
= old
->cdr
;
867 /* Set up the forwarding pointer. */
868 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
870 /* And count this cell. */
872 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
873 dynamic_pointer_p(thing
) &&
874 !(forwarding_pointer_p(*(lispobj
*)native_pointer(thing
))));
876 /* Scavenge the list we just copied. */
877 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
879 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
883 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
885 switch (widetag_of(header
)) {
886 /* FIXME: this needs a reindent */
888 case SINGLE_FLOAT_WIDETAG
:
889 case DOUBLE_FLOAT_WIDETAG
:
890 #ifdef LONG_FLOAT_WIDETAG
891 case LONG_FLOAT_WIDETAG
:
893 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
894 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
896 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
897 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
899 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
900 case COMPLEX_LONG_FLOAT_WIDETAG
:
903 return ptrans_unboxed(thing
, header
);
906 case COMPLEX_WIDETAG
:
907 case SIMPLE_ARRAY_WIDETAG
:
908 case COMPLEX_BASE_STRING_WIDETAG
:
909 case COMPLEX_BIT_VECTOR_WIDETAG
:
910 case COMPLEX_VECTOR_NIL_WIDETAG
:
911 case COMPLEX_VECTOR_WIDETAG
:
912 case COMPLEX_ARRAY_WIDETAG
:
913 return ptrans_boxed(thing
, header
, constant
);
915 case VALUE_CELL_HEADER_WIDETAG
:
916 case WEAK_POINTER_WIDETAG
:
917 return ptrans_boxed(thing
, header
, 0);
919 case SYMBOL_HEADER_WIDETAG
:
920 return ptrans_boxed(thing
, header
, 0);
922 case SIMPLE_ARRAY_NIL_WIDETAG
:
923 return ptrans_vector(thing
, 0, 0, 0, constant
);
925 case SIMPLE_BASE_STRING_WIDETAG
:
926 return ptrans_vector(thing
, 8, 1, 0, constant
);
928 case SIMPLE_BIT_VECTOR_WIDETAG
:
929 return ptrans_vector(thing
, 1, 0, 0, constant
);
931 case SIMPLE_VECTOR_WIDETAG
:
932 return ptrans_vector(thing
, 32, 0, 1, constant
);
934 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
935 return ptrans_vector(thing
, 2, 0, 0, constant
);
937 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
938 return ptrans_vector(thing
, 4, 0, 0, constant
);
940 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
941 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
942 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
943 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
945 return ptrans_vector(thing
, 8, 0, 0, constant
);
947 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
948 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
949 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
950 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
952 return ptrans_vector(thing
, 16, 0, 0, constant
);
954 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
955 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
956 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
957 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
959 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
960 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
961 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
963 return ptrans_vector(thing
, 32, 0, 0, constant
);
965 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
966 return ptrans_vector(thing
, 32, 0, 0, constant
);
968 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
969 return ptrans_vector(thing
, 64, 0, 0, constant
);
971 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
972 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
973 #ifdef LISP_FEATURE_X86
974 return ptrans_vector(thing
, 96, 0, 0, constant
);
977 return ptrans_vector(thing
, 128, 0, 0, constant
);
981 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
982 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
983 return ptrans_vector(thing
, 64, 0, 0, constant
);
986 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
987 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
988 return ptrans_vector(thing
, 128, 0, 0, constant
);
991 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
992 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
993 #ifdef LISP_FEATURE_X86
994 return ptrans_vector(thing
, 192, 0, 0, constant
);
997 return ptrans_vector(thing
, 256, 0, 0, constant
);
1001 case CODE_HEADER_WIDETAG
:
1002 return ptrans_code(thing
);
1004 case RETURN_PC_HEADER_WIDETAG
:
1005 return ptrans_returnpc(thing
, header
);
1008 return ptrans_fdefn(thing
, header
);
1011 /* Should only come across other pointers to the above stuff. */
1018 pscav_fdefn(struct fdefn
*fdefn
)
1022 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
1023 pscav(&fdefn
->name
, 1, 1);
1024 pscav(&fdefn
->fun
, 1, 0);
1026 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
1027 return sizeof(struct fdefn
) / sizeof(lispobj
);
1030 #ifdef LISP_FEATURE_X86
1031 /* now putting code objects in static space */
1033 pscav_code(struct code
*code
)
1037 nwords
= HeaderValue(code
->header
) + fixnum_value(code
->code_size
);
1039 /* Arrange to scavenge the debug info later. */
1040 pscav_later(&code
->debug_info
, 1);
1042 /* Scavenge the constants. */
1043 pscav(code
->constants
, HeaderValue(code
->header
)-5, 1);
1045 /* Scavenge all the functions. */
1046 pscav(&code
->entry_points
, 1, 1);
1047 for (func
= code
->entry_points
;
1049 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
1050 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
1051 gc_assert(!dynamic_pointer_p(func
));
1053 #ifdef LISP_FEATURE_X86
1054 /* Temporarily convert the self pointer to a real function
1056 ((struct simple_fun
*)native_pointer(func
))->self
1057 -= FUN_RAW_ADDR_OFFSET
;
1059 pscav(&((struct simple_fun
*)native_pointer(func
))->self
, 2, 1);
1060 #ifdef LISP_FEATURE_X86
1061 ((struct simple_fun
*)native_pointer(func
))->self
1062 += FUN_RAW_ADDR_OFFSET
;
1064 pscav_later(&((struct simple_fun
*)native_pointer(func
))->name
, 3);
1067 return CEILING(nwords
,2);
1072 pscav(lispobj
*addr
, int nwords
, boolean constant
)
1074 lispobj thing
, *thingp
, header
;
1075 int count
= 0; /* (0 = dummy init value to stop GCC warning) */
1076 struct vector
*vector
;
1078 while (nwords
> 0) {
1080 if (is_lisp_pointer(thing
)) {
1081 /* It's a pointer. Is it something we might have to move? */
1082 if (dynamic_pointer_p(thing
)) {
1083 /* Maybe. Have we already moved it? */
1084 thingp
= (lispobj
*)native_pointer(thing
);
1086 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
1087 /* Yep, so just copy the forwarding pointer. */
1090 /* Nope, copy the object. */
1091 switch (lowtag_of(thing
)) {
1092 case FUN_POINTER_LOWTAG
:
1093 thing
= ptrans_func(thing
, header
);
1096 case LIST_POINTER_LOWTAG
:
1097 thing
= ptrans_list(thing
, constant
);
1100 case INSTANCE_POINTER_LOWTAG
:
1101 thing
= ptrans_instance(thing
, header
, constant
);
1104 case OTHER_POINTER_LOWTAG
:
1105 thing
= ptrans_otherptr(thing
, header
, constant
);
1109 /* It was a pointer, but not one of them? */
1117 else if (thing
& 3) { /* FIXME: 3? not 2? */
1118 /* It's an other immediate. Maybe the header for an unboxed */
1120 switch (widetag_of(thing
)) {
1121 case BIGNUM_WIDETAG
:
1122 case SINGLE_FLOAT_WIDETAG
:
1123 case DOUBLE_FLOAT_WIDETAG
:
1124 #ifdef LONG_FLOAT_WIDETAG
1125 case LONG_FLOAT_WIDETAG
:
1128 /* It's an unboxed simple object. */
1129 count
= HeaderValue(thing
)+1;
1132 case SIMPLE_VECTOR_WIDETAG
:
1133 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
1134 *addr
= (subtype_VectorMustRehash
<< N_WIDETAG_BITS
) |
1135 SIMPLE_VECTOR_WIDETAG
;
1140 case SIMPLE_ARRAY_NIL_WIDETAG
:
1144 case SIMPLE_BASE_STRING_WIDETAG
:
1145 vector
= (struct vector
*)addr
;
1146 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,4)+2,2);
1149 case SIMPLE_BIT_VECTOR_WIDETAG
:
1150 vector
= (struct vector
*)addr
;
1151 count
= CEILING(NWORDS(fixnum_value(vector
->length
),32)+2,2);
1154 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
1155 vector
= (struct vector
*)addr
;
1156 count
= CEILING(NWORDS(fixnum_value(vector
->length
),16)+2,2);
1159 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
1160 vector
= (struct vector
*)addr
;
1161 count
= CEILING(NWORDS(fixnum_value(vector
->length
),8)+2,2);
1164 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
1165 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1166 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
1167 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
1169 vector
= (struct vector
*)addr
;
1170 count
= CEILING(NWORDS(fixnum_value(vector
->length
),4)+2,2);
1173 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
1174 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1175 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
1176 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
1178 vector
= (struct vector
*)addr
;
1179 count
= CEILING(NWORDS(fixnum_value(vector
->length
),2)+2,2);
1182 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
1183 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1184 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
1185 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
1187 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1188 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
1189 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
1191 vector
= (struct vector
*)addr
;
1192 count
= CEILING(fixnum_value(vector
->length
)+2,2);
1195 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
1196 vector
= (struct vector
*)addr
;
1197 count
= CEILING(fixnum_value(vector
->length
)+2,2);
1200 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
1201 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1202 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
1204 vector
= (struct vector
*)addr
;
1205 count
= fixnum_value(vector
->length
)*2+2;
1208 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1209 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
1210 vector
= (struct vector
*)addr
;
1211 #ifdef LISP_FEATURE_X86
1212 count
= fixnum_value(vector
->length
)*3+2;
1215 count
= fixnum_value(vector
->length
)*4+2;
1220 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1221 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
1222 vector
= (struct vector
*)addr
;
1223 count
= fixnum_value(vector
->length
)*4+2;
1227 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1228 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
1229 vector
= (struct vector
*)addr
;
1230 #ifdef LISP_FEATURE_X86
1231 count
= fixnum_value(vector
->length
)*6+2;
1234 count
= fixnum_value(vector
->length
)*8+2;
1239 case CODE_HEADER_WIDETAG
:
1240 #ifndef LISP_FEATURE_X86
1241 gc_abort(); /* no code headers in static space */
1243 count
= pscav_code((struct code
*)addr
);
1247 case SIMPLE_FUN_HEADER_WIDETAG
:
1248 case RETURN_PC_HEADER_WIDETAG
:
1249 /* We should never hit any of these, 'cause they occur
1250 * buried in the middle of code objects. */
1254 #ifdef LISP_FEATURE_X86
1255 case CLOSURE_HEADER_WIDETAG
:
1256 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
1257 /* The function self pointer needs special care on the
1258 * x86 because it is the real entry point. */
1260 lispobj fun
= ((struct closure
*)addr
)->fun
1261 - FUN_RAW_ADDR_OFFSET
;
1262 pscav(&fun
, 1, constant
);
1263 ((struct closure
*)addr
)->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
1269 case WEAK_POINTER_WIDETAG
:
1270 /* Weak pointers get preserved during purify, 'cause I
1271 * don't feel like figuring out how to break them. */
1272 pscav(addr
+1, 2, constant
);
1277 /* We have to handle fdefn objects specially, so we
1278 * can fix up the raw function address. */
1279 count
= pscav_fdefn((struct fdefn
*)addr
);
1288 /* It's a fixnum. */
1300 purify(lispobj static_roots
, lispobj read_only_roots
)
1304 struct later
*laters
, *next
;
1305 struct thread
*thread
;
1307 if(all_threads
->next
) {
1308 /* FIXME: there should be _some_ sensible error reporting
1309 * convention. See following comment too */
1310 fprintf(stderr
,"Can't purify when more than one thread exists\n");
1316 printf("[doing purification:");
1319 #ifdef LISP_FEATURE_GENCGC
1320 gc_alloc_update_all_page_tables();
1322 for_each_thread(thread
)
1323 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
1324 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
1325 * its error simply by a. printing a string b. to stdout instead
1327 printf(" Ack! Can't purify interrupt contexts. ");
1332 #if defined(LISP_FEATURE_X86)
1333 dynamic_space_free_pointer
=
1334 (lispobj
*)SymbolValue(ALLOCATION_POINTER
,0);
1337 read_only_end
= read_only_free
=
1338 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
,0);
1339 static_end
= static_free
=
1340 (lispobj
*)SymbolValue(STATIC_SPACE_FREE_POINTER
,0);
1347 #if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
1348 /* note this expects only one thread to be active. We'd have to
1349 * stop all the others in the same way as GC does if we wanted
1350 * PURIFY to work when >1 thread exists */
1351 setup_i386_stack_scav(((&static_roots
)-2),
1352 ((void *)all_threads
->control_stack_end
));
1355 pscav(&static_roots
, 1, 0);
1356 pscav(&read_only_roots
, 1, 1);
1359 printf(" handlers");
1362 pscav((lispobj
*) all_threads
->interrupt_data
->interrupt_handlers
,
1363 sizeof(all_threads
->interrupt_data
->interrupt_handlers
)
1371 #ifndef LISP_FEATURE_X86
1372 pscav((lispobj
*)all_threads
->control_stack_start
,
1373 current_control_stack_pointer
-
1374 all_threads
->control_stack_start
,
1377 #ifdef LISP_FEATURE_GENCGC
1383 printf(" bindings");
1386 #if !defined(LISP_FEATURE_X86)
1387 pscav( (lispobj
*)all_threads
->binding_stack_start
,
1388 (lispobj
*)current_binding_stack_pointer
-
1389 all_threads
->binding_stack_start
,
1392 for_each_thread(thread
) {
1393 pscav( (lispobj
*)thread
->binding_stack_start
,
1394 (lispobj
*)SymbolValue(BINDING_STACK_POINTER
,thread
) -
1395 (lispobj
*)thread
->binding_stack_start
,
1397 pscav( (lispobj
*) (thread
+1),
1398 fixnum_value(SymbolValue(FREE_TLS_INDEX
,0)) -
1399 (sizeof (struct thread
))/(sizeof (lispobj
)),
1406 /* The original CMU CL code had scavenge-read-only-space code
1407 * controlled by the Lisp-level variable
1408 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
1409 * wasn't documented under what circumstances it was useful or
1410 * safe to turn it on, so it's been turned off in SBCL. If you
1411 * want/need this functionality, and can test and document it,
1412 * please submit a patch. */
1414 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
1415 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
1416 unsigned read_only_space_size
=
1417 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
) -
1418 (lispobj
*)READ_ONLY_SPACE_START
;
1420 "scavenging read only space: %d bytes\n",
1421 read_only_space_size
* sizeof(lispobj
));
1422 pscav( (lispobj
*)READ_ONLY_SPACE_START
, read_only_space_size
, 0);
1430 clean
= (lispobj
*)STATIC_SPACE_START
;
1432 while (clean
!= static_free
)
1433 clean
= pscav(clean
, static_free
- clean
, 0);
1434 laters
= later_blocks
;
1435 count
= later_count
;
1436 later_blocks
= NULL
;
1438 while (laters
!= NULL
) {
1439 for (i
= 0; i
< count
; i
++) {
1440 if (laters
->u
[i
].count
== 0) {
1442 } else if (laters
->u
[i
].count
<= LATERMAXCOUNT
) {
1443 pscav(laters
->u
[i
+1].ptr
, laters
->u
[i
].count
, 1);
1446 pscav(laters
->u
[i
].ptr
, 1, 1);
1449 next
= laters
->next
;
1452 count
= LATERBLOCKSIZE
;
1454 } while (clean
!= static_free
|| later_blocks
!= NULL
);
1461 os_zero((os_vm_address_t
) current_dynamic_space
,
1462 (os_vm_size_t
) DYNAMIC_SPACE_SIZE
);
1464 /* Zero the stack. Note that the stack is also zeroed by SUB-GC
1465 * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
1466 #ifndef LISP_FEATURE_X86
1467 os_zero((os_vm_address_t
) current_control_stack_pointer
,
1469 ((all_threads
->control_stack_end
-
1470 current_control_stack_pointer
) * sizeof(lispobj
)));
1473 /* It helps to update the heap free pointers so that free_heap can
1474 * verify after it's done. */
1475 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER
, (lispobj
)read_only_free
,0);
1476 SetSymbolValue(STATIC_SPACE_FREE_POINTER
, (lispobj
)static_free
,0);
1478 #if !defined(LISP_FEATURE_X86)
1479 dynamic_space_free_pointer
= current_dynamic_space
;
1480 set_auto_gc_trigger(bytes_consed_between_gcs
);
1482 #if defined LISP_FEATURE_GENCGC
1485 #error unsupported case /* in CMU CL, was "ibmrt using GC" */