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 /* Substructure: special case for the COMPACT-INFO-ENVs,
191 * where the instance may have a point to the dynamic
192 * space placed into it (e.g. the cache-name slot), but
193 * the lists and arrays at the time of a purify can be
194 * moved to the RO space. */
196 lispobj result
, *new, *old
;
198 nwords
= CEILING(1 + HeaderValue(header
), 2);
201 old
= (lispobj
*)native_pointer(thing
);
202 new = newspace_alloc(nwords
, 0); /* inconstant */
205 bcopy(old
, new, nwords
* sizeof(lispobj
));
207 /* Deposit forwarding pointer. */
208 result
= make_lispobj(new, lowtag_of(thing
));
212 pscav(new, nwords
, 1);
218 return NIL
; /* dummy value: return something ... */
223 ptrans_fdefn(lispobj thing
, lispobj header
)
226 lispobj result
, *new, *old
, oldfn
;
229 nwords
= CEILING(1 + HeaderValue(header
), 2);
232 old
= (lispobj
*)native_pointer(thing
);
233 new = newspace_alloc(nwords
, 0); /* inconstant */
236 bcopy(old
, new, nwords
* sizeof(lispobj
));
238 /* Deposit forwarding pointer. */
239 result
= make_lispobj(new, lowtag_of(thing
));
242 /* Scavenge the function. */
243 fdefn
= (struct fdefn
*)new;
245 pscav(&fdefn
->fun
, 1, 0);
246 if ((char *)oldfn
+ FUN_RAW_ADDR_OFFSET
== fdefn
->raw_addr
)
247 fdefn
->raw_addr
= (char *)fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
;
253 ptrans_unboxed(lispobj thing
, lispobj header
)
256 lispobj result
, *new, *old
;
258 nwords
= CEILING(1 + HeaderValue(header
), 2);
261 old
= (lispobj
*)native_pointer(thing
);
262 new = newspace_alloc(nwords
,1); /* always constant */
265 bcopy(old
, new, nwords
* sizeof(lispobj
));
267 /* Deposit forwarding pointer. */
268 result
= make_lispobj(new , lowtag_of(thing
));
275 ptrans_vector(lispobj thing
, long bits
, long extra
,
276 boolean boxed
, boolean constant
)
278 struct vector
*vector
;
280 lispobj result
, *new;
283 vector
= (struct vector
*)native_pointer(thing
);
284 length
= fixnum_value(vector
->length
)+extra
;
285 // Argh, handle simple-vector-nil separately.
289 nwords
= CEILING(NWORDS(length
, bits
) + 2, 2);
292 new=newspace_alloc(nwords
, (constant
|| !boxed
));
293 bcopy(vector
, new, nwords
* sizeof(lispobj
));
295 result
= make_lispobj(new, lowtag_of(thing
));
296 vector
->header
= result
;
299 pscav(new, nwords
, constant
);
305 ptrans_code(lispobj thing
)
307 struct code
*code
, *new;
309 lispobj func
, result
;
311 code
= (struct code
*)native_pointer(thing
);
312 nwords
= CEILING(HeaderValue(code
->header
) + fixnum_value(code
->code_size
),
315 new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
317 bcopy(code
, new, nwords
* sizeof(lispobj
));
319 result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
321 /* Stick in a forwarding pointer for the code object. */
322 *(lispobj
*)code
= result
;
324 /* Put in forwarding pointers for all the functions. */
325 for (func
= code
->entry_points
;
327 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
329 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
331 *(lispobj
*)native_pointer(func
) = result
+ (func
- thing
);
334 /* Arrange to scavenge the debug info later. */
335 pscav_later(&new->debug_info
, 1);
337 /* FIXME: why would this be a fixnum? */
338 /* "why" is a hard word, but apparently for compiled functions the
339 trace_table_offset contains the length of the instructions, as
340 a fixnum. See CODE-INST-AREA-LENGTH in
341 src/compiler/target-disassem.lisp. -- CSR, 2004-01-08 */
342 if (!(fixnump(new->trace_table_offset
)))
344 pscav(&new->trace_table_offset
, 1, 0);
346 new->trace_table_offset
= NIL
; /* limit lifetime */
349 /* Scavenge the constants. */
350 pscav(new->constants
, HeaderValue(new->header
)-5, 1);
352 /* Scavenge all the functions. */
353 pscav(&new->entry_points
, 1, 1);
354 for (func
= new->entry_points
;
356 func
= ((struct simple_fun
*)native_pointer(func
))->next
) {
357 gc_assert(lowtag_of(func
) == FUN_POINTER_LOWTAG
);
358 gc_assert(!dynamic_pointer_p(func
));
360 pscav(&((struct simple_fun
*)native_pointer(func
))->self
, 2, 1);
361 pscav_later(&((struct simple_fun
*)native_pointer(func
))->name
, 4);
368 ptrans_func(lispobj thing
, lispobj header
)
371 lispobj code
, *new, *old
, result
;
372 struct simple_fun
*function
;
374 /* Thing can either be a function header, a closure function
375 * header, a closure, or a funcallable-instance. If it's a closure
376 * or a funcallable-instance, we do the same as ptrans_boxed.
377 * Otherwise we have to do something strange, 'cause it is buried
378 * inside a code object. */
380 if (widetag_of(header
) == SIMPLE_FUN_HEADER_WIDETAG
) {
382 /* We can only end up here if the code object has not been
383 * scavenged, because if it had been scavenged, forwarding pointers
384 * would have been left behind for all the entry points. */
386 function
= (struct simple_fun
*)native_pointer(thing
);
389 ((native_pointer(thing
) -
390 (HeaderValue(function
->header
))), OTHER_POINTER_LOWTAG
);
392 /* This will cause the function's header to be replaced with a
393 * forwarding pointer. */
397 /* So we can just return that. */
398 return function
->header
;
401 /* It's some kind of closure-like thing. */
402 nwords
= CEILING(1 + HeaderValue(header
), 2);
403 old
= (lispobj
*)native_pointer(thing
);
405 /* Allocate the new one. FINs *must* not go in read_only
406 * space. Closures can; they never change */
409 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG
));
412 bcopy(old
, new, nwords
* sizeof(lispobj
));
414 /* Deposit forwarding pointer. */
415 result
= make_lispobj(new, lowtag_of(thing
));
419 pscav(new, nwords
, 0);
426 ptrans_returnpc(lispobj thing
, lispobj header
)
430 /* Find the corresponding code object. */
431 code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
433 /* Make sure it's been transported. */
434 new = *(lispobj
*)native_pointer(code
);
435 if (!forwarding_pointer_p(new))
436 new = ptrans_code(code
);
438 /* Maintain the offset: */
439 return new + (thing
- code
);
442 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
445 ptrans_list(lispobj thing
, boolean constant
)
447 struct cons
*old
, *new, *orig
;
450 orig
= (struct cons
*) newspace_alloc(0,constant
);
454 /* Allocate a new cons cell. */
455 old
= (struct cons
*)native_pointer(thing
);
456 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
458 /* Copy the cons cell and keep a pointer to the cdr. */
460 thing
= new->cdr
= old
->cdr
;
462 /* Set up the forwarding pointer. */
463 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
465 /* And count this cell. */
467 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
468 dynamic_pointer_p(thing
) &&
469 !(forwarding_pointer_p(*(lispobj
*)native_pointer(thing
))));
471 /* Scavenge the list we just copied. */
472 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
474 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
478 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
480 switch (widetag_of(header
)) {
481 /* FIXME: this needs a reindent */
483 case SINGLE_FLOAT_WIDETAG
:
484 case DOUBLE_FLOAT_WIDETAG
:
485 #ifdef LONG_FLOAT_WIDETAG
486 case LONG_FLOAT_WIDETAG
:
488 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
489 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
491 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
492 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
494 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
495 case COMPLEX_LONG_FLOAT_WIDETAG
:
498 return ptrans_unboxed(thing
, header
);
501 gencgc_unregister_lutex((struct lutex
*) native_pointer(thing
));
502 return ptrans_unboxed(thing
, header
);
506 case COMPLEX_WIDETAG
:
507 case SIMPLE_ARRAY_WIDETAG
:
508 case COMPLEX_BASE_STRING_WIDETAG
:
509 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
510 case COMPLEX_CHARACTER_STRING_WIDETAG
:
512 case COMPLEX_BIT_VECTOR_WIDETAG
:
513 case COMPLEX_VECTOR_NIL_WIDETAG
:
514 case COMPLEX_VECTOR_WIDETAG
:
515 case COMPLEX_ARRAY_WIDETAG
:
516 return ptrans_boxed(thing
, header
, constant
);
518 case VALUE_CELL_HEADER_WIDETAG
:
519 case WEAK_POINTER_WIDETAG
:
520 return ptrans_boxed(thing
, header
, 0);
522 case SYMBOL_HEADER_WIDETAG
:
523 return ptrans_boxed(thing
, header
, 0);
525 case SIMPLE_ARRAY_NIL_WIDETAG
:
526 return ptrans_vector(thing
, 0, 0, 0, constant
);
528 case SIMPLE_BASE_STRING_WIDETAG
:
529 return ptrans_vector(thing
, 8, 1, 0, constant
);
531 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
532 case SIMPLE_CHARACTER_STRING_WIDETAG
:
533 return ptrans_vector(thing
, 32, 1, 0, constant
);
536 case SIMPLE_BIT_VECTOR_WIDETAG
:
537 return ptrans_vector(thing
, 1, 0, 0, constant
);
539 case SIMPLE_VECTOR_WIDETAG
:
540 return ptrans_vector(thing
, N_WORD_BITS
, 0, 1, constant
);
542 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
543 return ptrans_vector(thing
, 2, 0, 0, constant
);
545 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
546 return ptrans_vector(thing
, 4, 0, 0, constant
);
548 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
549 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
550 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
551 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
553 return ptrans_vector(thing
, 8, 0, 0, constant
);
555 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
556 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
557 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
558 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
560 return ptrans_vector(thing
, 16, 0, 0, constant
);
562 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
563 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
564 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
565 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
567 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
568 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
569 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
571 return ptrans_vector(thing
, 32, 0, 0, constant
);
573 #if N_WORD_BITS == 64
574 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
575 case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
:
577 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
578 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
580 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
581 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
583 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
584 case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
:
586 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
587 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
589 return ptrans_vector(thing
, 64, 0, 0, constant
);
592 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
593 return ptrans_vector(thing
, 32, 0, 0, constant
);
595 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
596 return ptrans_vector(thing
, 64, 0, 0, constant
);
598 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
599 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
600 #ifdef LISP_FEATURE_SPARC
601 return ptrans_vector(thing
, 128, 0, 0, constant
);
605 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
606 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
607 return ptrans_vector(thing
, 64, 0, 0, constant
);
610 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
611 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
612 return ptrans_vector(thing
, 128, 0, 0, constant
);
615 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
616 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
617 #ifdef LISP_FEATURE_SPARC
618 return ptrans_vector(thing
, 256, 0, 0, constant
);
622 case CODE_HEADER_WIDETAG
:
623 return ptrans_code(thing
);
625 case RETURN_PC_HEADER_WIDETAG
:
626 return ptrans_returnpc(thing
, header
);
629 return ptrans_fdefn(thing
, header
);
632 fprintf(stderr
, "Invalid widetag: %d\n", widetag_of(header
));
633 /* Should only come across other pointers to the above stuff. */
640 pscav_fdefn(struct fdefn
*fdefn
)
644 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
645 pscav(&fdefn
->name
, 1, 1);
646 pscav(&fdefn
->fun
, 1, 0);
648 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
649 return sizeof(struct fdefn
) / sizeof(lispobj
);
653 pscav(lispobj
*addr
, long nwords
, boolean constant
)
655 lispobj thing
, *thingp
, header
;
656 long count
= 0; /* (0 = dummy init value to stop GCC warning) */
657 struct vector
*vector
;
661 if (is_lisp_pointer(thing
)) {
662 /* It's a pointer. Is it something we might have to move? */
663 if (dynamic_pointer_p(thing
)) {
664 /* Maybe. Have we already moved it? */
665 thingp
= (lispobj
*)native_pointer(thing
);
667 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
668 /* Yep, so just copy the forwarding pointer. */
671 /* Nope, copy the object. */
672 switch (lowtag_of(thing
)) {
673 case FUN_POINTER_LOWTAG
:
674 thing
= ptrans_func(thing
, header
);
677 case LIST_POINTER_LOWTAG
:
678 thing
= ptrans_list(thing
, constant
);
681 case INSTANCE_POINTER_LOWTAG
:
682 thing
= ptrans_instance(thing
, header
, constant
);
685 case OTHER_POINTER_LOWTAG
:
686 thing
= ptrans_otherptr(thing
, header
, constant
);
690 /* It was a pointer, but not one of them? */
698 #if N_WORD_BITS == 64
699 else if (widetag_of(thing
) == SINGLE_FLOAT_WIDETAG
) {
703 else if (thing
& FIXNUM_TAG_MASK
) {
704 /* It's an other immediate. Maybe the header for an unboxed */
706 switch (widetag_of(thing
)) {
708 case SINGLE_FLOAT_WIDETAG
:
709 case DOUBLE_FLOAT_WIDETAG
:
710 #ifdef LONG_FLOAT_WIDETAG
711 case LONG_FLOAT_WIDETAG
:
714 /* It's an unboxed simple object. */
715 count
= CEILING(HeaderValue(thing
)+1, 2);
718 case SIMPLE_VECTOR_WIDETAG
:
719 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
720 struct hash_table
*hash_table
=
721 (struct hash_table
*)native_pointer(addr
[2]);
722 hash_table
->needs_rehash_p
= T
;
727 case SIMPLE_ARRAY_NIL_WIDETAG
:
731 case SIMPLE_BASE_STRING_WIDETAG
:
732 vector
= (struct vector
*)addr
;
733 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,8)+2,2);
736 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
737 case SIMPLE_CHARACTER_STRING_WIDETAG
:
738 vector
= (struct vector
*)addr
;
739 count
= CEILING(NWORDS(fixnum_value(vector
->length
)+1,32)+2,2);
743 case SIMPLE_BIT_VECTOR_WIDETAG
:
744 vector
= (struct vector
*)addr
;
745 count
= CEILING(NWORDS(fixnum_value(vector
->length
),1)+2,2);
748 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
749 vector
= (struct vector
*)addr
;
750 count
= CEILING(NWORDS(fixnum_value(vector
->length
),2)+2,2);
753 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
754 vector
= (struct vector
*)addr
;
755 count
= CEILING(NWORDS(fixnum_value(vector
->length
),4)+2,2);
758 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
759 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
760 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
761 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
763 vector
= (struct vector
*)addr
;
764 count
= CEILING(NWORDS(fixnum_value(vector
->length
),8)+2,2);
767 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
768 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
769 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
770 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
772 vector
= (struct vector
*)addr
;
773 count
= CEILING(NWORDS(fixnum_value(vector
->length
),16)+2,2);
776 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
777 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
778 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
779 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
781 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
782 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
783 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
785 vector
= (struct vector
*)addr
;
786 count
= CEILING(NWORDS(fixnum_value(vector
->length
),32)+2,2);
789 #if N_WORD_BITS == 64
790 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
791 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
792 case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
:
793 case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
:
795 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
796 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
797 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
799 vector
= (struct vector
*)addr
;
800 count
= CEILING(NWORDS(fixnum_value(vector
->length
),64)+2,2);
804 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
805 vector
= (struct vector
*)addr
;
806 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 32) + 2,
810 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
811 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
812 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
814 vector
= (struct vector
*)addr
;
815 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 64) + 2,
819 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
820 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
821 vector
= (struct vector
*)addr
;
822 #ifdef LISP_FEATURE_SPARC
823 count
= fixnum_value(vector
->length
)*4+2;
828 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
829 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
830 vector
= (struct vector
*)addr
;
831 count
= CEILING(NWORDS(fixnum_value(vector
->length
), 128) + 2,
836 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
837 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
838 vector
= (struct vector
*)addr
;
839 #ifdef LISP_FEATURE_SPARC
840 count
= fixnum_value(vector
->length
)*8+2;
845 case CODE_HEADER_WIDETAG
:
846 gc_abort(); /* no code headers in static space */
849 case SIMPLE_FUN_HEADER_WIDETAG
:
850 case RETURN_PC_HEADER_WIDETAG
:
851 /* We should never hit any of these, 'cause they occur
852 * buried in the middle of code objects. */
856 case WEAK_POINTER_WIDETAG
:
857 /* Weak pointers get preserved during purify, 'cause I
858 * don't feel like figuring out how to break them. */
859 pscav(addr
+1, 2, constant
);
864 /* We have to handle fdefn objects specially, so we
865 * can fix up the raw function address. */
866 count
= pscav_fdefn((struct fdefn
*)addr
);
869 case INSTANCE_HEADER_WIDETAG
:
871 struct instance
*instance
= (struct instance
*) addr
;
872 struct layout
*layout
873 = (struct layout
*) native_pointer(instance
->slots
[0]);
874 long nuntagged
= fixnum_value(layout
->n_untagged_slots
);
875 long nslots
= HeaderValue(*addr
);
876 pscav(addr
+ 1, nslots
- nuntagged
, constant
);
877 count
= CEILING(1 + nslots
, 2);
899 purify(lispobj static_roots
, lispobj read_only_roots
)
903 struct later
*laters
, *next
;
904 struct thread
*thread
;
906 if(all_threads
->next
) {
907 /* FIXME: there should be _some_ sensible error reporting
908 * convention. See following comment too */
909 fprintf(stderr
,"Can't purify when more than one thread exists\n");
915 printf("[doing purification:");
919 for_each_thread(thread
)
920 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
921 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
922 * its error simply by a. printing a string b. to stdout instead
924 printf(" Ack! Can't purify interrupt contexts. ");
929 dynamic_space_purify_pointer
= dynamic_space_free_pointer
;
931 read_only_end
= read_only_free
=
932 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
,0);
933 static_end
= static_free
=
934 (lispobj
*)SymbolValue(STATIC_SPACE_FREE_POINTER
,0);
941 pscav(&static_roots
, 1, 0);
942 pscav(&read_only_roots
, 1, 1);
948 pscav((lispobj
*) interrupt_handlers
,
949 sizeof(interrupt_handlers
) / sizeof(lispobj
),
956 pscav((lispobj
*)all_threads
->control_stack_start
,
957 current_control_stack_pointer
-
958 all_threads
->control_stack_start
,
966 pscav( (lispobj
*)all_threads
->binding_stack_start
,
967 (lispobj
*)current_binding_stack_pointer
-
968 all_threads
->binding_stack_start
,
971 /* The original CMU CL code had scavenge-read-only-space code
972 * controlled by the Lisp-level variable
973 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
974 * wasn't documented under what circumstances it was useful or
975 * safe to turn it on, so it's been turned off in SBCL. If you
976 * want/need this functionality, and can test and document it,
977 * please submit a patch. */
979 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
980 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
981 unsigned read_only_space_size
=
982 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
) -
983 (lispobj
*)READ_ONLY_SPACE_START
;
985 "scavenging read only space: %d bytes\n",
986 read_only_space_size
* sizeof(lispobj
));
987 pscav( (lispobj
*)READ_ONLY_SPACE_START
, read_only_space_size
, 0);
995 clean
= (lispobj
*)STATIC_SPACE_START
;
997 while (clean
!= static_free
)
998 clean
= pscav(clean
, static_free
- clean
, 0);
999 laters
= later_blocks
;
1000 count
= later_count
;
1001 later_blocks
= NULL
;
1003 while (laters
!= NULL
) {
1004 for (i
= 0; i
< count
; i
++) {
1005 if (laters
->u
[i
].count
== 0) {
1007 } else if (laters
->u
[i
].count
<= LATERMAXCOUNT
) {
1008 pscav(laters
->u
[i
+1].ptr
, laters
->u
[i
].count
, 1);
1011 pscav(laters
->u
[i
].ptr
, 1, 1);
1014 next
= laters
->next
;
1017 count
= LATERBLOCKSIZE
;
1019 } while (clean
!= static_free
|| later_blocks
!= NULL
);
1025 #ifdef LISP_FEATURE_HPUX
1026 clear_auto_gc_trigger(); /* restore mmap as it was given by os */
1029 os_zero((os_vm_address_t
) current_dynamic_space
,
1030 (os_vm_size_t
) dynamic_space_size
);
1032 /* Zero the stack. */
1033 os_zero((os_vm_address_t
) current_control_stack_pointer
,
1035 ((all_threads
->control_stack_end
-
1036 current_control_stack_pointer
) * sizeof(lispobj
)));
1038 /* It helps to update the heap free pointers so that free_heap can
1039 * verify after it's done. */
1040 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER
, (lispobj
)read_only_free
,0);
1041 SetSymbolValue(STATIC_SPACE_FREE_POINTER
, (lispobj
)static_free
,0);
1043 dynamic_space_free_pointer
= current_dynamic_space
;
1044 set_auto_gc_trigger(bytes_consed_between_gcs
);
1046 /* Blast away instruction cache */
1047 os_flush_icache((os_vm_address_t
)READ_ONLY_SPACE_START
, READ_ONLY_SPACE_SIZE
);
1048 os_flush_icache((os_vm_address_t
)STATIC_SPACE_START
, STATIC_SPACE_SIZE
);
1056 #else /* LISP_FEATURE_GENCGC */
1058 purify(lispobj static_roots
, lispobj read_only_roots
)
1060 lose("purify called for GENCGC. This should not happen.");
1062 #endif /* LISP_FEATURE_GENCGC */