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"
35 #include "genesis/layout.h"
36 #include "genesis/hash-table.h"
39 /* We don't ever do purification with GENCGC as of 1.0.5.*. There was
40 * a lot of hairy and fragile ifdeffage in here to support purify on
41 * x86oids, which has now been removed. So this code can't even be
42 * compiled with GENCGC any more. -- JES, 2007-04-30.
44 #ifndef LISP_FEATURE_GENCGC
48 static lispobj
*dynamic_space_purify_pointer
;
51 /* These hold the original end of the read_only and static spaces so
52 * we can tell what are forwarding pointers. */
54 static lispobj
*read_only_end
, *static_end
;
56 static lispobj
*read_only_free
, *static_free
;
58 static lispobj
*pscav(lispobj
*addr
, long nwords
, boolean constant
);
60 #define LATERBLOCKSIZE 1020
61 #define LATERMAXCOUNT 10
70 } *later_blocks
= NULL
;
71 static long later_count
= 0;
74 #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
75 #elif N_WORD_BITS == 64
76 #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
81 forwarding_pointer_p(lispobj obj
)
83 lispobj
*ptr
= native_pointer(obj
);
85 return ((static_end
<= ptr
&& ptr
<= static_free
) ||
86 (read_only_end
<= ptr
&& ptr
<= read_only_free
));
90 dynamic_pointer_p(lispobj ptr
)
92 return (ptr
>= (lispobj
)current_dynamic_space
94 ptr
< (lispobj
)dynamic_space_purify_pointer
);
97 static inline lispobj
*
98 newspace_alloc(long nwords
, int constantp
)
101 nwords
=CEILING(nwords
,2);
103 if(read_only_free
+ nwords
>= (lispobj
*)READ_ONLY_SPACE_END
) {
104 lose("Ran out of read-only space while purifying!\n");
107 read_only_free
+=nwords
;
109 if(static_free
+ nwords
>= (lispobj
*)STATIC_SPACE_END
) {
110 lose("Ran out of static space while purifying!\n");
120 pscav_later(lispobj
*where
, long count
)
124 if (count
> LATERMAXCOUNT
) {
125 while (count
> LATERMAXCOUNT
) {
126 pscav_later(where
, LATERMAXCOUNT
);
127 count
-= LATERMAXCOUNT
;
128 where
+= LATERMAXCOUNT
;
132 if (later_blocks
== NULL
|| later_count
== LATERBLOCKSIZE
||
133 (later_count
== LATERBLOCKSIZE
-1 && count
> 1)) {
134 new = (struct later
*)malloc(sizeof(struct later
));
135 new->next
= later_blocks
;
136 if (later_blocks
&& later_count
< LATERBLOCKSIZE
)
137 later_blocks
->u
[later_count
].ptr
= NULL
;
143 later_blocks
->u
[later_count
++].count
= count
;
144 later_blocks
->u
[later_count
++].ptr
= where
;
149 ptrans_boxed(lispobj thing
, lispobj header
, boolean constant
)
152 lispobj result
, *new, *old
;
154 nwords
= CEILING(1 + HeaderValue(header
), 2);
157 old
= (lispobj
*)native_pointer(thing
);
158 new = newspace_alloc(nwords
,constant
);
161 bcopy(old
, new, nwords
* sizeof(lispobj
));
163 /* Deposit forwarding pointer. */
164 result
= make_lispobj(new, lowtag_of(thing
));
168 pscav(new, nwords
, constant
);
173 /* We need to look at the layout to see whether it is a pure structure
174 * class, and only then can we transport as constant. If it is pure,
175 * we can ALWAYS transport as a constant. */
177 ptrans_instance(lispobj thing
, lispobj header
, boolean
/* ignored */ constant
)
179 struct layout
*layout
=
180 (struct layout
*) native_pointer(((struct instance
*)native_pointer(thing
))->slots
[0]);
181 lispobj pure
= layout
->pure
;
185 return (ptrans_boxed(thing
, header
, 1));
187 return (ptrans_boxed(thing
, header
, 0));
190 return NIL
; /* dummy value: return something ... */
195 ptrans_fdefn(lispobj thing
, lispobj header
)
198 lispobj result
, *new, *old
, oldfn
;
201 nwords
= CEILING(1 + HeaderValue(header
), 2);
204 old
= (lispobj
*)native_pointer(thing
);
205 new = newspace_alloc(nwords
, 0); /* inconstant */
208 bcopy(old
, new, nwords
* sizeof(lispobj
));
210 /* Deposit forwarding pointer. */
211 result
= make_lispobj(new, lowtag_of(thing
));
214 /* Scavenge the function. */
215 fdefn
= (struct fdefn
*)new;
217 pscav(&fdefn
->fun
, 1, 0);
218 if ((char *)oldfn
+ FUN_RAW_ADDR_OFFSET
== fdefn
->raw_addr
)
219 fdefn
->raw_addr
= (char *)fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
;
225 ptrans_unboxed(lispobj thing
, lispobj header
)
228 lispobj result
, *new, *old
;
230 nwords
= CEILING(1 + HeaderValue(header
), 2);
233 old
= (lispobj
*)native_pointer(thing
);
234 new = newspace_alloc(nwords
,1); /* always constant */
237 bcopy(old
, new, nwords
* sizeof(lispobj
));
239 /* Deposit forwarding pointer. */
240 result
= make_lispobj(new , lowtag_of(thing
));
247 ptrans_vector(lispobj thing
, long bits
, long extra
,
248 boolean boxed
, boolean constant
)
250 struct vector
*vector
;
252 lispobj result
, *new;
255 vector
= (struct vector
*)native_pointer(thing
);
256 length
= fixnum_value(vector
->length
)+extra
;
257 // Argh, handle simple-vector-nil separately.
261 nwords
= CEILING(NWORDS(length
, bits
) + 2, 2);
264 new=newspace_alloc(nwords
, (constant
|| !boxed
));
265 bcopy(vector
, new, nwords
* sizeof(lispobj
));
267 result
= make_lispobj(new, lowtag_of(thing
));
268 vector
->header
= result
;
271 pscav(new, nwords
, constant
);
277 ptrans_code(lispobj thing
)
279 struct code
*code
= (struct code
*)native_pointer(thing
);
280 long nwords
= code_header_words(code
->header
)
281 + code_instruction_words(code
->code_size
);
283 struct code
*new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
285 bcopy(code
, new, nwords
* sizeof(lispobj
));
287 lispobj result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
289 /* Put in forwarding pointers for all the functions. */
290 for_each_simple_fun(func
, code
,
291 *func
= make_lispobj(code_fun_addr(new, index
), FUN_POINTER_LOWTAG
));
293 /* Stick in a forwarding pointer for the code object. */
294 /* This smashes the header, so do it only after reading n_funs */
295 *(lispobj
*)code
= result
;
297 /* Arrange to scavenge the debug info later. */
298 pscav_later(&new->debug_info
, 1);
300 /* Scavenge the constants. */
301 pscav(new->constants
,
302 code_header_words(new->header
) - (offsetof(struct code
, constants
) >> WORD_SHIFT
),
305 /* Scavenge all the functions. */
306 for_each_simple_fun(func
, new, {
307 gc_assert(!dynamic_pointer_p((lispobj
)func
));
308 pscav(&func
->self
, 1, 1);
309 pscav_later(&func
->name
, 4);
316 ptrans_func(lispobj thing
, lispobj header
)
319 lispobj code
, *new, *old
, result
;
320 struct simple_fun
*function
;
322 /* Thing can either be a function header, a closure function
323 * header, a closure, or a funcallable-instance. If it's a closure
324 * or a funcallable-instance, we do the same as ptrans_boxed.
325 * Otherwise we have to do something strange, 'cause it is buried
326 * inside a code object. */
328 if (widetag_of(header
) == SIMPLE_FUN_HEADER_WIDETAG
) {
330 /* We can only end up here if the code object has not been
331 * scavenged, because if it had been scavenged, forwarding pointers
332 * would have been left behind for all the entry points. */
334 function
= (struct simple_fun
*)native_pointer(thing
);
337 ((native_pointer(thing
) -
338 (HeaderValue(function
->header
))), OTHER_POINTER_LOWTAG
);
340 /* This will cause the function's header to be replaced with a
341 * forwarding pointer. */
345 /* So we can just return that. */
346 return function
->header
;
349 /* It's some kind of closure-like thing. */
350 nwords
= CEILING(1 + HeaderValue(header
), 2);
351 old
= (lispobj
*)native_pointer(thing
);
353 /* Allocate the new one. FINs *must* not go in read_only
354 * space. Closures can; they never change */
357 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG
));
360 bcopy(old
, new, nwords
* sizeof(lispobj
));
362 /* Deposit forwarding pointer. */
363 result
= make_lispobj(new, lowtag_of(thing
));
367 pscav(new, nwords
, 0);
374 ptrans_returnpc(lispobj thing
, lispobj header
)
378 /* Find the corresponding code object. */
379 code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
381 /* Make sure it's been transported. */
382 new = *(lispobj
*)native_pointer(code
);
383 if (!forwarding_pointer_p(new))
384 new = ptrans_code(code
);
386 /* Maintain the offset: */
387 return new + (thing
- code
);
390 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
393 ptrans_list(lispobj thing
, boolean constant
)
395 struct cons
*old
, *new, *orig
;
398 orig
= (struct cons
*) newspace_alloc(0,constant
);
402 /* Allocate a new cons cell. */
403 old
= (struct cons
*)native_pointer(thing
);
404 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
406 /* Copy the cons cell and keep a pointer to the cdr. */
408 thing
= new->cdr
= old
->cdr
;
410 /* Set up the forwarding pointer. */
411 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
413 /* And count this cell. */
415 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
416 dynamic_pointer_p(thing
) &&
417 !(forwarding_pointer_p(*(lispobj
*)native_pointer(thing
))));
419 /* Scavenge the list we just copied. */
420 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
422 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
426 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
428 switch (widetag_of(header
)) {
429 /* FIXME: this needs a reindent */
431 case SINGLE_FLOAT_WIDETAG
:
432 case DOUBLE_FLOAT_WIDETAG
:
433 #ifdef LONG_FLOAT_WIDETAG
434 case LONG_FLOAT_WIDETAG
:
436 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
437 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
439 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
440 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
442 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
443 case COMPLEX_LONG_FLOAT_WIDETAG
:
446 return ptrans_unboxed(thing
, header
);
448 case COMPLEX_WIDETAG
:
449 case SIMPLE_ARRAY_WIDETAG
:
450 case COMPLEX_BASE_STRING_WIDETAG
:
451 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
452 case COMPLEX_CHARACTER_STRING_WIDETAG
:
454 case COMPLEX_BIT_VECTOR_WIDETAG
:
455 case COMPLEX_VECTOR_NIL_WIDETAG
:
456 case COMPLEX_VECTOR_WIDETAG
:
457 case COMPLEX_ARRAY_WIDETAG
:
458 return ptrans_boxed(thing
, header
, constant
);
460 case VALUE_CELL_HEADER_WIDETAG
:
461 case WEAK_POINTER_WIDETAG
:
462 return ptrans_boxed(thing
, header
, 0);
464 case SYMBOL_HEADER_WIDETAG
:
465 return ptrans_boxed(thing
, header
, 0);
467 case SIMPLE_ARRAY_NIL_WIDETAG
:
468 return ptrans_vector(thing
, 0, 0, 0, constant
);
470 case SIMPLE_BASE_STRING_WIDETAG
:
471 return ptrans_vector(thing
, 8, 1, 0, constant
);
473 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
474 case SIMPLE_CHARACTER_STRING_WIDETAG
:
475 return ptrans_vector(thing
, 32, 1, 0, constant
);
478 case SIMPLE_BIT_VECTOR_WIDETAG
:
479 return ptrans_vector(thing
, 1, 0, 0, constant
);
481 case SIMPLE_VECTOR_WIDETAG
:
482 return ptrans_vector(thing
, N_WORD_BITS
, 0, 1, constant
);
484 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
485 return ptrans_vector(thing
, 2, 0, 0, constant
);
487 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
488 return ptrans_vector(thing
, 4, 0, 0, constant
);
490 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
491 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
492 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
493 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
495 return ptrans_vector(thing
, 8, 0, 0, constant
);
497 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
498 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
499 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
500 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
502 return ptrans_vector(thing
, 16, 0, 0, constant
);
504 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
505 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
506 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
507 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
508 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
509 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
511 return ptrans_vector(thing
, 32, 0, 0, constant
);
513 #if N_WORD_BITS == 64
514 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
515 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
517 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
518 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
520 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
521 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
523 return ptrans_vector(thing
, 64, 0, 0, constant
);
526 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
527 return ptrans_vector(thing
, 32, 0, 0, constant
);
529 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
530 return ptrans_vector(thing
, 64, 0, 0, constant
);
532 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
533 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
534 #ifdef LISP_FEATURE_SPARC
535 return ptrans_vector(thing
, 128, 0, 0, constant
);
539 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
540 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
541 return ptrans_vector(thing
, 64, 0, 0, constant
);
544 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
545 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
546 return ptrans_vector(thing
, 128, 0, 0, constant
);
549 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
550 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
551 #ifdef LISP_FEATURE_SPARC
552 return ptrans_vector(thing
, 256, 0, 0, constant
);
556 case CODE_HEADER_WIDETAG
:
557 return ptrans_code(thing
);
559 case RETURN_PC_HEADER_WIDETAG
:
560 return ptrans_returnpc(thing
, header
);
563 return ptrans_fdefn(thing
, header
);
566 fprintf(stderr
, "Invalid widetag: %d\n", widetag_of(header
));
567 /* Should only come across other pointers to the above stuff. */
574 pscav_fdefn(struct fdefn
*fdefn
)
578 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
579 pscav(&fdefn
->name
, 1, 1);
580 pscav(&fdefn
->fun
, 1, 0);
582 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
583 return sizeof(struct fdefn
) / sizeof(lispobj
);
587 pscav(lispobj
*addr
, long nwords
, boolean constant
)
589 lispobj thing
, *thingp
, header
;
590 long count
= 0; /* (0 = dummy init value to stop GCC warning) */
591 struct vector
*vector
;
595 if (is_lisp_pointer(thing
)) {
596 /* It's a pointer. Is it something we might have to move? */
597 if (dynamic_pointer_p(thing
)) {
598 /* Maybe. Have we already moved it? */
599 thingp
= (lispobj
*)native_pointer(thing
);
601 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
602 /* Yep, so just copy the forwarding pointer. */
605 /* Nope, copy the object. */
606 switch (lowtag_of(thing
)) {
607 case FUN_POINTER_LOWTAG
:
608 thing
= ptrans_func(thing
, header
);
611 case LIST_POINTER_LOWTAG
:
612 thing
= ptrans_list(thing
, constant
);
615 case INSTANCE_POINTER_LOWTAG
:
616 thing
= ptrans_instance(thing
, header
, constant
);
619 case OTHER_POINTER_LOWTAG
:
620 thing
= ptrans_otherptr(thing
, header
, constant
);
624 /* It was a pointer, but not one of them? */
632 #if N_WORD_BITS == 64
633 else if (widetag_of(thing
) == SINGLE_FLOAT_WIDETAG
) {
637 else if (thing
& FIXNUM_TAG_MASK
) {
638 /* It's an other immediate. Maybe the header for an unboxed */
640 switch (widetag_of(thing
)) {
642 case SINGLE_FLOAT_WIDETAG
:
643 case DOUBLE_FLOAT_WIDETAG
:
644 #ifdef LONG_FLOAT_WIDETAG
645 case LONG_FLOAT_WIDETAG
:
648 /* It's an unboxed simple object. */
649 count
= CEILING(HeaderValue(thing
)+1, 2);
652 case SIMPLE_VECTOR_WIDETAG
:
653 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
654 struct hash_table
*hash_table
=
655 (struct hash_table
*)native_pointer(addr
[2]);
656 hash_table
->needs_rehash_p
= T
;
661 case SIMPLE_ARRAY_NIL_WIDETAG
:
665 case SIMPLE_BASE_STRING_WIDETAG
:
666 vector
= (struct vector
*)addr
;
667 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,8)+2,2);
670 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
671 case SIMPLE_CHARACTER_STRING_WIDETAG
:
672 vector
= (struct vector
*)addr
;
673 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,32)+2,2);
677 case SIMPLE_BIT_VECTOR_WIDETAG
:
678 vector
= (struct vector
*)addr
;
679 count
= CEILING(NWORDS(fixnum_value(vector
->length
),1)+2,2);
682 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
683 vector
= (struct vector
*)addr
;
684 count
= CEILING(NWORDS(fixnum_value(vector
->length
),2)+2,2);
687 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
688 vector
= (struct vector
*)addr
;
689 count
= CEILING(NWORDS(fixnum_value(vector
->length
),4)+2,2);
692 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
693 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
694 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
695 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
697 vector
= (struct vector
*)addr
;
698 count
= CEILING(NWORDS(fixnum_value(vector
->length
),8)+2,2);
701 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
702 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
703 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
704 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
706 vector
= (struct vector
*)addr
;
707 count
= CEILING(NWORDS(fixnum_value(vector
->length
),16)+2,2);
710 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
712 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
713 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
715 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
716 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
717 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
719 vector
= (struct vector
*)addr
;
720 count
= CEILING(NWORDS(fixnum_value(vector
->length
),32)+2,2);
723 #if N_WORD_BITS == 64
724 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
725 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
726 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
727 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
729 vector
= (struct vector
*)addr
;
730 count
= CEILING(NWORDS(fixnum_value(vector
->length
),64)+2,2);
734 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
735 vector
= (struct vector
*)addr
;
736 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 32) + 2,
740 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
741 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
742 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
744 vector
= (struct vector
*)addr
;
745 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 64) + 2,
749 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
750 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
751 vector
= (struct vector
*)addr
;
752 #ifdef LISP_FEATURE_SPARC
753 count
= fixnum_value(vector
->length
)*4+2;
758 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
759 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
760 vector
= (struct vector
*)addr
;
761 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 128) + 2,
766 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
767 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
768 vector
= (struct vector
*)addr
;
769 #ifdef LISP_FEATURE_SPARC
770 count
= fixnum_value(vector
->length
)*8+2;
775 case CODE_HEADER_WIDETAG
:
776 gc_abort(); /* no code headers in static space */
779 case SIMPLE_FUN_HEADER_WIDETAG
:
780 case RETURN_PC_HEADER_WIDETAG
:
781 /* We should never hit any of these, 'cause they occur
782 * buried in the middle of code objects. */
786 case WEAK_POINTER_WIDETAG
:
787 /* Weak pointers get preserved during purify, 'cause I
788 * don't feel like figuring out how to break them. */
789 pscav(addr
+1, 2, constant
);
794 /* We have to handle fdefn objects specially, so we
795 * can fix up the raw function address. */
796 count
= pscav_fdefn((struct fdefn
*)addr
);
799 case INSTANCE_HEADER_WIDETAG
:
801 struct instance
*instance
= (struct instance
*) addr
;
802 struct layout
*layout
803 = (struct layout
*) native_pointer(instance
->slots
[0]);
804 long nslots
= HeaderValue(*addr
);
806 if (fixnump(layout
->bitmap
)) {
807 sword_t bitmap
= (sword_t
)layout
->bitmap
>> N_FIXNUM_TAG_BITS
;
808 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
810 pscav(addr
+ 1 + index
, 1, constant
);
812 struct bignum
* bitmap
;
813 bitmap
= (struct bignum
*)native_pointer(layout
->bitmap
);
814 for (index
= 0; index
< nslots
; index
++)
815 if (positive_bignum_logbitp(index
, bitmap
))
816 pscav(addr
+ 1 + index
, 1, constant
);
818 count
= CEILING(1 + nslots
, 2);
840 purify(lispobj static_roots
, lispobj read_only_roots
)
844 struct later
*laters
, *next
;
845 struct thread
*thread
;
847 if(all_threads
->next
) {
848 /* FIXME: there should be _some_ sensible error reporting
849 * convention. See following comment too */
850 fprintf(stderr
,"Can't purify when more than one thread exists\n");
856 printf("[doing purification:");
860 for_each_thread(thread
)
861 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
862 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
863 * its error simply by a. printing a string b. to stdout instead
865 printf(" Ack! Can't purify interrupt contexts. ");
870 dynamic_space_purify_pointer
= dynamic_space_free_pointer
;
872 read_only_end
= read_only_free
=
873 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
,0);
874 static_end
= static_free
=
875 (lispobj
*)SymbolValue(STATIC_SPACE_FREE_POINTER
,0);
882 pscav(&static_roots
, 1, 0);
883 pscav(&read_only_roots
, 1, 1);
889 pscav((lispobj
*) interrupt_handlers
,
890 sizeof(interrupt_handlers
) / sizeof(lispobj
),
897 pscav((lispobj
*)all_threads
->control_stack_start
,
898 access_control_stack_pointer(all_threads
) -
899 all_threads
->control_stack_start
,
907 pscav( (lispobj
*)all_threads
->binding_stack_start
,
908 (lispobj
*)get_binding_stack_pointer(all_threads
) -
909 all_threads
->binding_stack_start
,
912 /* The original CMU CL code had scavenge-read-only-space code
913 * controlled by the Lisp-level variable
914 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
915 * wasn't documented under what circumstances it was useful or
916 * safe to turn it on, so it's been turned off in SBCL. If you
917 * want/need this functionality, and can test and document it,
918 * please submit a patch. */
920 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
921 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
922 unsigned read_only_space_size
=
923 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
) -
924 (lispobj
*)READ_ONLY_SPACE_START
;
926 "scavenging read only space: %d bytes\n",
927 read_only_space_size
* sizeof(lispobj
));
928 pscav( (lispobj
*)READ_ONLY_SPACE_START
, read_only_space_size
, 0);
936 clean
= (lispobj
*)STATIC_SPACE_START
;
938 while (clean
!= static_free
)
939 clean
= pscav(clean
, static_free
- clean
, 0);
940 laters
= later_blocks
;
944 while (laters
!= NULL
) {
945 for (i
= 0; i
< count
; i
++) {
946 if (laters
->u
[i
].count
== 0) {
948 } else if (laters
->u
[i
].count
<= LATERMAXCOUNT
) {
949 pscav(laters
->u
[i
+1].ptr
, laters
->u
[i
].count
, 1);
952 pscav(laters
->u
[i
].ptr
, 1, 1);
958 count
= LATERBLOCKSIZE
;
960 } while (clean
!= static_free
|| later_blocks
!= NULL
);
966 #ifdef LISP_FEATURE_HPUX
967 clear_auto_gc_trigger(); /* restore mmap as it was given by os */
970 os_zero((os_vm_address_t
) current_dynamic_space
, dynamic_space_size
);
972 /* Zero the stack. */
973 os_zero((os_vm_address_t
) access_control_stack_pointer(all_threads
),
975 ((all_threads
->control_stack_end
-
976 access_control_stack_pointer(all_threads
)) * sizeof(lispobj
)));
978 /* It helps to update the heap free pointers so that free_heap can
979 * verify after it's done. */
980 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER
, (lispobj
)read_only_free
,0);
981 SetSymbolValue(STATIC_SPACE_FREE_POINTER
, (lispobj
)static_free
,0);
983 dynamic_space_free_pointer
= current_dynamic_space
;
984 set_auto_gc_trigger(bytes_consed_between_gcs
);
986 /* Blast away instruction cache */
987 os_flush_icache((os_vm_address_t
)READ_ONLY_SPACE_START
, READ_ONLY_SPACE_SIZE
);
988 os_flush_icache((os_vm_address_t
)STATIC_SPACE_START
, STATIC_SPACE_SIZE
);
996 #else /* LISP_FEATURE_GENCGC */
998 purify(lispobj static_roots
, lispobj read_only_roots
)
1000 lose("purify called for GENCGC. This should not happen.");
1002 #endif /* LISP_FEATURE_GENCGC */