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
, *new;
281 lispobj func
, result
;
283 code
= (struct code
*)native_pointer(thing
);
284 // FIXME: CEILING is likely redundant.
285 // - The header word count can't be odd
286 // - The instruction word count is rounded by the accessor macro
287 nwords
= CEILING(HeaderValue(code
->header
) + code_instruction_words(code
->code_size
),
290 new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
292 bcopy(code
, new, nwords
* sizeof(lispobj
));
294 result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
296 /* Stick in a forwarding pointer for the code object. */
297 *(lispobj
*)code
= result
;
299 /* Put in forwarding pointers for all the functions. */
300 for (func
= code
->entry_points
;
302 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
304 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
306 *(lispobj
*)native_pointer(func
) = result
+ (func
- thing
);
309 /* Arrange to scavenge the debug info later. */
310 pscav_later(&new->debug_info
, 1);
312 /* Scavenge the constants. */
313 pscav(new->constants
,
314 HeaderValue(new->header
) - (offsetof(struct code
, constants
) >> WORD_SHIFT
),
317 /* Scavenge all the functions. */
318 pscav(&new->entry_points
, 1, 1);
319 for (func
= new->entry_points
;
321 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
322 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
323 gc_assert(!dynamic_pointer_p(func
));
325 pscav(&((struct simple_fun
*)native_pointer(func
))->self
, 2, 1);
326 pscav_later(&((struct simple_fun
*)native_pointer(func
))->name
, 4);
333 ptrans_func(lispobj thing
, lispobj header
)
336 lispobj code
, *new, *old
, result
;
337 struct simple_fun
*function
;
339 /* Thing can either be a function header, a closure function
340 * header, a closure, or a funcallable-instance. If it's a closure
341 * or a funcallable-instance, we do the same as ptrans_boxed.
342 * Otherwise we have to do something strange, 'cause it is buried
343 * inside a code object. */
345 if (widetag_of(header
) == SIMPLE_FUN_HEADER_WIDETAG
) {
347 /* We can only end up here if the code object has not been
348 * scavenged, because if it had been scavenged, forwarding pointers
349 * would have been left behind for all the entry points. */
351 function
= (struct simple_fun
*)native_pointer(thing
);
354 ((native_pointer(thing
) -
355 (HeaderValue(function
->header
))), OTHER_POINTER_LOWTAG
);
357 /* This will cause the function's header to be replaced with a
358 * forwarding pointer. */
362 /* So we can just return that. */
363 return function
->header
;
366 /* It's some kind of closure-like thing. */
367 nwords
= CEILING(1 + HeaderValue(header
), 2);
368 old
= (lispobj
*)native_pointer(thing
);
370 /* Allocate the new one. FINs *must* not go in read_only
371 * space. Closures can; they never change */
374 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG
));
377 bcopy(old
, new, nwords
* sizeof(lispobj
));
379 /* Deposit forwarding pointer. */
380 result
= make_lispobj(new, lowtag_of(thing
));
384 pscav(new, nwords
, 0);
391 ptrans_returnpc(lispobj thing
, lispobj header
)
395 /* Find the corresponding code object. */
396 code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
398 /* Make sure it's been transported. */
399 new = *(lispobj
*)native_pointer(code
);
400 if (!forwarding_pointer_p(new))
401 new = ptrans_code(code
);
403 /* Maintain the offset: */
404 return new + (thing
- code
);
407 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
410 ptrans_list(lispobj thing
, boolean constant
)
412 struct cons
*old
, *new, *orig
;
415 orig
= (struct cons
*) newspace_alloc(0,constant
);
419 /* Allocate a new cons cell. */
420 old
= (struct cons
*)native_pointer(thing
);
421 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
423 /* Copy the cons cell and keep a pointer to the cdr. */
425 thing
= new->cdr
= old
->cdr
;
427 /* Set up the forwarding pointer. */
428 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
430 /* And count this cell. */
432 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
433 dynamic_pointer_p(thing
) &&
434 !(forwarding_pointer_p(*(lispobj
*)native_pointer(thing
))));
436 /* Scavenge the list we just copied. */
437 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
439 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
443 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
445 switch (widetag_of(header
)) {
446 /* FIXME: this needs a reindent */
448 case SINGLE_FLOAT_WIDETAG
:
449 case DOUBLE_FLOAT_WIDETAG
:
450 #ifdef LONG_FLOAT_WIDETAG
451 case LONG_FLOAT_WIDETAG
:
453 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
454 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
456 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
457 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
459 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
460 case COMPLEX_LONG_FLOAT_WIDETAG
:
463 return ptrans_unboxed(thing
, header
);
465 case COMPLEX_WIDETAG
:
466 case SIMPLE_ARRAY_WIDETAG
:
467 case COMPLEX_BASE_STRING_WIDETAG
:
468 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
469 case COMPLEX_CHARACTER_STRING_WIDETAG
:
471 case COMPLEX_BIT_VECTOR_WIDETAG
:
472 case COMPLEX_VECTOR_NIL_WIDETAG
:
473 case COMPLEX_VECTOR_WIDETAG
:
474 case COMPLEX_ARRAY_WIDETAG
:
475 return ptrans_boxed(thing
, header
, constant
);
477 case VALUE_CELL_HEADER_WIDETAG
:
478 case WEAK_POINTER_WIDETAG
:
479 return ptrans_boxed(thing
, header
, 0);
481 case SYMBOL_HEADER_WIDETAG
:
482 return ptrans_boxed(thing
, header
, 0);
484 case SIMPLE_ARRAY_NIL_WIDETAG
:
485 return ptrans_vector(thing
, 0, 0, 0, constant
);
487 case SIMPLE_BASE_STRING_WIDETAG
:
488 return ptrans_vector(thing
, 8, 1, 0, constant
);
490 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
491 case SIMPLE_CHARACTER_STRING_WIDETAG
:
492 return ptrans_vector(thing
, 32, 1, 0, constant
);
495 case SIMPLE_BIT_VECTOR_WIDETAG
:
496 return ptrans_vector(thing
, 1, 0, 0, constant
);
498 case SIMPLE_VECTOR_WIDETAG
:
499 return ptrans_vector(thing
, N_WORD_BITS
, 0, 1, constant
);
501 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
502 return ptrans_vector(thing
, 2, 0, 0, constant
);
504 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
505 return ptrans_vector(thing
, 4, 0, 0, constant
);
507 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
508 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
509 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
510 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
512 return ptrans_vector(thing
, 8, 0, 0, constant
);
514 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
515 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
516 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
517 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
519 return ptrans_vector(thing
, 16, 0, 0, constant
);
521 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
522 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
523 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
524 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
525 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
526 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
528 return ptrans_vector(thing
, 32, 0, 0, constant
);
530 #if N_WORD_BITS == 64
531 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
532 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
534 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
535 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
537 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
538 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
540 return ptrans_vector(thing
, 64, 0, 0, constant
);
543 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
544 return ptrans_vector(thing
, 32, 0, 0, constant
);
546 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
547 return ptrans_vector(thing
, 64, 0, 0, constant
);
549 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
550 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
551 #ifdef LISP_FEATURE_SPARC
552 return ptrans_vector(thing
, 128, 0, 0, constant
);
556 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
557 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
558 return ptrans_vector(thing
, 64, 0, 0, constant
);
561 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
562 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
563 return ptrans_vector(thing
, 128, 0, 0, constant
);
566 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
567 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
568 #ifdef LISP_FEATURE_SPARC
569 return ptrans_vector(thing
, 256, 0, 0, constant
);
573 case CODE_HEADER_WIDETAG
:
574 return ptrans_code(thing
);
576 case RETURN_PC_HEADER_WIDETAG
:
577 return ptrans_returnpc(thing
, header
);
580 return ptrans_fdefn(thing
, header
);
583 fprintf(stderr
, "Invalid widetag: %d\n", widetag_of(header
));
584 /* Should only come across other pointers to the above stuff. */
591 pscav_fdefn(struct fdefn
*fdefn
)
595 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
596 pscav(&fdefn
->name
, 1, 1);
597 pscav(&fdefn
->fun
, 1, 0);
599 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
600 return sizeof(struct fdefn
) / sizeof(lispobj
);
604 pscav(lispobj
*addr
, long nwords
, boolean constant
)
606 lispobj thing
, *thingp
, header
;
607 long count
= 0; /* (0 = dummy init value to stop GCC warning) */
608 struct vector
*vector
;
612 if (is_lisp_pointer(thing
)) {
613 /* It's a pointer. Is it something we might have to move? */
614 if (dynamic_pointer_p(thing
)) {
615 /* Maybe. Have we already moved it? */
616 thingp
= (lispobj
*)native_pointer(thing
);
618 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
619 /* Yep, so just copy the forwarding pointer. */
622 /* Nope, copy the object. */
623 switch (lowtag_of(thing
)) {
624 case FUN_POINTER_LOWTAG
:
625 thing
= ptrans_func(thing
, header
);
628 case LIST_POINTER_LOWTAG
:
629 thing
= ptrans_list(thing
, constant
);
632 case INSTANCE_POINTER_LOWTAG
:
633 thing
= ptrans_instance(thing
, header
, constant
);
636 case OTHER_POINTER_LOWTAG
:
637 thing
= ptrans_otherptr(thing
, header
, constant
);
641 /* It was a pointer, but not one of them? */
649 #if N_WORD_BITS == 64
650 else if (widetag_of(thing
) == SINGLE_FLOAT_WIDETAG
) {
654 else if (thing
& FIXNUM_TAG_MASK
) {
655 /* It's an other immediate. Maybe the header for an unboxed */
657 switch (widetag_of(thing
)) {
659 case SINGLE_FLOAT_WIDETAG
:
660 case DOUBLE_FLOAT_WIDETAG
:
661 #ifdef LONG_FLOAT_WIDETAG
662 case LONG_FLOAT_WIDETAG
:
665 /* It's an unboxed simple object. */
666 count
= CEILING(HeaderValue(thing
)+1, 2);
669 case SIMPLE_VECTOR_WIDETAG
:
670 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
671 struct hash_table
*hash_table
=
672 (struct hash_table
*)native_pointer(addr
[2]);
673 hash_table
->needs_rehash_p
= T
;
678 case SIMPLE_ARRAY_NIL_WIDETAG
:
682 case SIMPLE_BASE_STRING_WIDETAG
:
683 vector
= (struct vector
*)addr
;
684 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,8)+2,2);
687 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
688 case SIMPLE_CHARACTER_STRING_WIDETAG
:
689 vector
= (struct vector
*)addr
;
690 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,32)+2,2);
694 case SIMPLE_BIT_VECTOR_WIDETAG
:
695 vector
= (struct vector
*)addr
;
696 count
= CEILING(NWORDS(fixnum_value(vector
->length
),1)+2,2);
699 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
700 vector
= (struct vector
*)addr
;
701 count
= CEILING(NWORDS(fixnum_value(vector
->length
),2)+2,2);
704 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
705 vector
= (struct vector
*)addr
;
706 count
= CEILING(NWORDS(fixnum_value(vector
->length
),4)+2,2);
709 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
710 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
711 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
712 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
714 vector
= (struct vector
*)addr
;
715 count
= CEILING(NWORDS(fixnum_value(vector
->length
),8)+2,2);
718 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
719 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
720 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
721 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
723 vector
= (struct vector
*)addr
;
724 count
= CEILING(NWORDS(fixnum_value(vector
->length
),16)+2,2);
727 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
729 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
730 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
732 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
733 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
734 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
736 vector
= (struct vector
*)addr
;
737 count
= CEILING(NWORDS(fixnum_value(vector
->length
),32)+2,2);
740 #if N_WORD_BITS == 64
741 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
742 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
743 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
744 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
746 vector
= (struct vector
*)addr
;
747 count
= CEILING(NWORDS(fixnum_value(vector
->length
),64)+2,2);
751 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
752 vector
= (struct vector
*)addr
;
753 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 32) + 2,
757 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
758 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
759 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
761 vector
= (struct vector
*)addr
;
762 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 64) + 2,
766 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
767 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
768 vector
= (struct vector
*)addr
;
769 #ifdef LISP_FEATURE_SPARC
770 count
= fixnum_value(vector
->length
)*4+2;
775 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
776 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
777 vector
= (struct vector
*)addr
;
778 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 128) + 2,
783 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
784 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
785 vector
= (struct vector
*)addr
;
786 #ifdef LISP_FEATURE_SPARC
787 count
= fixnum_value(vector
->length
)*8+2;
792 case CODE_HEADER_WIDETAG
:
793 gc_abort(); /* no code headers in static space */
796 case SIMPLE_FUN_HEADER_WIDETAG
:
797 case RETURN_PC_HEADER_WIDETAG
:
798 /* We should never hit any of these, 'cause they occur
799 * buried in the middle of code objects. */
803 case WEAK_POINTER_WIDETAG
:
804 /* Weak pointers get preserved during purify, 'cause I
805 * don't feel like figuring out how to break them. */
806 pscav(addr
+1, 2, constant
);
811 /* We have to handle fdefn objects specially, so we
812 * can fix up the raw function address. */
813 count
= pscav_fdefn((struct fdefn
*)addr
);
816 case INSTANCE_HEADER_WIDETAG
:
818 struct instance
*instance
= (struct instance
*) addr
;
819 struct layout
*layout
820 = (struct layout
*) native_pointer(instance
->slots
[0]);
821 long nslots
= HeaderValue(*addr
);
823 if (fixnump(layout
->bitmap
)) {
824 sword_t bitmap
= (sword_t
)layout
->bitmap
>> N_FIXNUM_TAG_BITS
;
825 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
827 pscav(addr
+ 1 + index
, 1, constant
);
829 struct bignum
* bitmap
;
830 bitmap
= (struct bignum
*)native_pointer(layout
->bitmap
);
831 for (index
= 0; index
< nslots
; index
++)
832 if (positive_bignum_logbitp(index
, bitmap
))
833 pscav(addr
+ 1 + index
, 1, constant
);
835 count
= CEILING(1 + nslots
, 2);
857 purify(lispobj static_roots
, lispobj read_only_roots
)
861 struct later
*laters
, *next
;
862 struct thread
*thread
;
864 if(all_threads
->next
) {
865 /* FIXME: there should be _some_ sensible error reporting
866 * convention. See following comment too */
867 fprintf(stderr
,"Can't purify when more than one thread exists\n");
873 printf("[doing purification:");
877 for_each_thread(thread
)
878 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
879 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
880 * its error simply by a. printing a string b. to stdout instead
882 printf(" Ack! Can't purify interrupt contexts. ");
887 dynamic_space_purify_pointer
= dynamic_space_free_pointer
;
889 read_only_end
= read_only_free
=
890 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
,0);
891 static_end
= static_free
=
892 (lispobj
*)SymbolValue(STATIC_SPACE_FREE_POINTER
,0);
899 pscav(&static_roots
, 1, 0);
900 pscav(&read_only_roots
, 1, 1);
906 pscav((lispobj
*) interrupt_handlers
,
907 sizeof(interrupt_handlers
) / sizeof(lispobj
),
914 pscav((lispobj
*)all_threads
->control_stack_start
,
915 access_control_stack_pointer(all_threads
) -
916 all_threads
->control_stack_start
,
924 pscav( (lispobj
*)all_threads
->binding_stack_start
,
925 (lispobj
*)get_binding_stack_pointer(all_threads
) -
926 all_threads
->binding_stack_start
,
929 /* The original CMU CL code had scavenge-read-only-space code
930 * controlled by the Lisp-level variable
931 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
932 * wasn't documented under what circumstances it was useful or
933 * safe to turn it on, so it's been turned off in SBCL. If you
934 * want/need this functionality, and can test and document it,
935 * please submit a patch. */
937 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
938 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
939 unsigned read_only_space_size
=
940 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
) -
941 (lispobj
*)READ_ONLY_SPACE_START
;
943 "scavenging read only space: %d bytes\n",
944 read_only_space_size
* sizeof(lispobj
));
945 pscav( (lispobj
*)READ_ONLY_SPACE_START
, read_only_space_size
, 0);
953 clean
= (lispobj
*)STATIC_SPACE_START
;
955 while (clean
!= static_free
)
956 clean
= pscav(clean
, static_free
- clean
, 0);
957 laters
= later_blocks
;
961 while (laters
!= NULL
) {
962 for (i
= 0; i
< count
; i
++) {
963 if (laters
->u
[i
].count
== 0) {
965 } else if (laters
->u
[i
].count
<= LATERMAXCOUNT
) {
966 pscav(laters
->u
[i
+1].ptr
, laters
->u
[i
].count
, 1);
969 pscav(laters
->u
[i
].ptr
, 1, 1);
975 count
= LATERBLOCKSIZE
;
977 } while (clean
!= static_free
|| later_blocks
!= NULL
);
983 #ifdef LISP_FEATURE_HPUX
984 clear_auto_gc_trigger(); /* restore mmap as it was given by os */
987 os_zero((os_vm_address_t
) current_dynamic_space
, dynamic_space_size
);
989 /* Zero the stack. */
990 os_zero((os_vm_address_t
) access_control_stack_pointer(all_threads
),
992 ((all_threads
->control_stack_end
-
993 access_control_stack_pointer(all_threads
)) * sizeof(lispobj
)));
995 /* It helps to update the heap free pointers so that free_heap can
996 * verify after it's done. */
997 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER
, (lispobj
)read_only_free
,0);
998 SetSymbolValue(STATIC_SPACE_FREE_POINTER
, (lispobj
)static_free
,0);
1000 dynamic_space_free_pointer
= current_dynamic_space
;
1001 set_auto_gc_trigger(bytes_consed_between_gcs
);
1003 /* Blast away instruction cache */
1004 os_flush_icache((os_vm_address_t
)READ_ONLY_SPACE_START
, READ_ONLY_SPACE_SIZE
);
1005 os_flush_icache((os_vm_address_t
)STATIC_SPACE_START
, STATIC_SPACE_SIZE
);
1013 #else /* LISP_FEATURE_GENCGC */
1015 purify(lispobj static_roots
, lispobj read_only_roots
)
1017 lose("purify called for GENCGC. This should not happen.");
1019 #endif /* LISP_FEATURE_GENCGC */