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/gc-tables.h"
34 #include "genesis/primitive-objects.h"
35 #include "genesis/static-symbols.h"
36 #include "genesis/layout.h"
37 #include "genesis/defstruct-description.h"
38 #include "genesis/hash-table.h"
41 /* We don't ever do purification with GENCGC as of 1.0.5.*. There was
42 * a lot of hairy and fragile ifdeffage in here to support purify on
43 * x86oids, which has now been removed. So this code can't even be
44 * compiled with GENCGC any more. -- JES, 2007-04-30.
46 #ifndef LISP_FEATURE_GENCGC
50 static lispobj
*dynamic_space_purify_pointer
;
53 /* These hold the original end of the read_only and static spaces so
54 * we can tell what are forwarding pointers. */
56 static lispobj
*read_only_end
, *static_end
;
58 /* These are private to purify, not to be confused with the external symbols
59 * named 'read_only_space_free_pointer', respectively 'static_space' */
60 static lispobj
*read_only_free
, *static_free
;
62 static lispobj
*pscav(lispobj
*addr
, long nwords
, boolean constant
);
64 #define LATERBLOCKSIZE 1020
65 #define LATERMAXCOUNT 10
74 } *later_blocks
= NULL
;
75 static long later_count
= 0;
79 forwarding_pointer_p(lispobj obj
)
81 lispobj
*ptr
= native_pointer(obj
);
83 return ((static_end
<= ptr
&& ptr
<= static_free
) ||
84 (read_only_end
<= ptr
&& ptr
<= read_only_free
));
88 dynamic_pointer_p(lispobj ptr
)
90 return (ptr
>= (lispobj
)current_dynamic_space
92 ptr
< (lispobj
)dynamic_space_purify_pointer
);
95 static inline lispobj
*
96 newspace_alloc(long nwords
, int constantp
)
99 gc_assert((nwords
& 1) == 0);
101 if(read_only_free
+ nwords
>= (lispobj
*)READ_ONLY_SPACE_END
) {
102 lose("Ran out of read-only space while purifying!\n");
105 read_only_free
+=nwords
;
107 if(static_free
+ nwords
>= (lispobj
*)STATIC_SPACE_END
) {
108 lose("Ran out of static space while purifying!\n");
118 pscav_later(lispobj
*where
, long count
)
122 if (count
> LATERMAXCOUNT
) {
123 while (count
> LATERMAXCOUNT
) {
124 pscav_later(where
, LATERMAXCOUNT
);
125 count
-= LATERMAXCOUNT
;
126 where
+= LATERMAXCOUNT
;
130 if (later_blocks
== NULL
|| later_count
== LATERBLOCKSIZE
||
131 (later_count
== LATERBLOCKSIZE
-1 && count
> 1)) {
132 new = (struct later
*)malloc(sizeof(struct later
));
133 new->next
= later_blocks
;
134 if (later_blocks
&& later_count
< LATERBLOCKSIZE
)
135 later_blocks
->u
[later_count
].ptr
= NULL
;
141 later_blocks
->u
[later_count
++].count
= count
;
142 later_blocks
->u
[later_count
++].ptr
= where
;
147 ptrans_boxed(lispobj thing
, lispobj header
, boolean constant
)
150 lispobj
*old
= native_pointer(thing
);
151 long nwords
= sizetab
[widetag_of(header
)](old
);
152 lispobj
*new = newspace_alloc(nwords
,constant
);
155 bcopy(old
, new, nwords
* sizeof(lispobj
));
157 /* Deposit forwarding pointer. */
158 lispobj result
= make_lispobj(new, lowtag_of(thing
));
162 pscav(new, nwords
, constant
);
167 /* We need to look at the layout to see whether it is a pure structure
168 * class, and only then can we transport as constant. If it is pure,
169 * we can ALWAYS transport as a constant. */
171 ptrans_instance(lispobj thing
, lispobj header
, boolean
/* ignored */ constant
)
174 lispobj info
= LAYOUT(instance_layout(native_pointer(thing
)))->info
;
176 lispobj pure
= ((struct defstruct_description
*)native_pointer(info
))->pure
;
177 if (pure
!= NIL
&& pure
!= T
) {
179 return NIL
; /* dummy value: return something ... */
181 constant
= (pure
== T
);
183 return ptrans_boxed(thing
, header
, constant
);
187 ptrans_fdefn(lispobj thing
, lispobj header
)
190 lispobj
*old
= native_pointer(thing
);
191 long nwords
= sizetab
[widetag_of(header
)](old
);
192 lispobj
*new = newspace_alloc(nwords
, 0); /* inconstant */
195 bcopy(old
, new, nwords
* sizeof(lispobj
));
197 /* Deposit forwarding pointer. */
198 lispobj result
= make_lispobj(new, lowtag_of(thing
));
201 /* Scavenge the function. */
202 struct fdefn
*fdefn
= (struct fdefn
*)new;
203 lispobj oldfn
= fdefn
->fun
;
204 pscav(&fdefn
->fun
, 1, 0);
205 if ((char *)oldfn
+ FUN_RAW_ADDR_OFFSET
== fdefn
->raw_addr
)
206 fdefn
->raw_addr
= (char *)fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
;
212 ptrans_unboxed(lispobj thing
, lispobj header
)
215 lispobj
*old
= native_pointer(thing
);
216 long nwords
= sizetab
[widetag_of(header
)](old
);
217 lispobj
*new = newspace_alloc(nwords
, 1); /* always constant */
220 bcopy(old
, new, nwords
* sizeof(lispobj
));
222 /* Deposit forwarding pointer. */
223 lispobj result
= make_lispobj(new, lowtag_of(thing
));
230 ptrans_vector(lispobj thing
, boolean boxed
, boolean constant
)
232 struct vector
*vector
= VECTOR(thing
);
233 long nwords
= sizetab
[widetag_of(vector
->header
)]((lispobj
*)vector
);
235 lispobj
*new = newspace_alloc(nwords
, (constant
|| !boxed
));
236 bcopy(vector
, new, nwords
* sizeof(lispobj
));
238 lispobj result
= make_lispobj(new, lowtag_of(thing
));
239 vector
->header
= result
;
242 pscav(new, nwords
, constant
);
248 ptrans_code(lispobj thing
)
250 struct code
*code
= (struct code
*)native_pointer(thing
);
251 long nwords
= code_header_words(code
->header
)
252 + code_instruction_words(code
->code_size
);
254 struct code
*new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
256 bcopy(code
, new, nwords
* sizeof(lispobj
));
258 lispobj result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
260 /* Put in forwarding pointers for all the functions. */
261 uword_t displacement
= result
- thing
;
262 for_each_simple_fun(i
, newfunc
, new, 1, {
263 lispobj
* old
= (lispobj
*)LOW_WORD((char*)newfunc
- displacement
);
264 *old
= make_lispobj(newfunc
, FUN_POINTER_LOWTAG
);
267 /* Stick in a forwarding pointer for the code object. */
268 /* This smashes the header, so do it only after reading n_funs */
269 *(lispobj
*)code
= result
;
271 /* Arrange to scavenge the debug info later. */
272 pscav_later(&new->debug_info
, 1);
274 /* Scavenge the constants. */
275 pscav(new->constants
,
276 code_header_words(new->header
) - (offsetof(struct code
, constants
) >> WORD_SHIFT
),
279 /* Scavenge all the functions. */
280 for_each_simple_fun(i
, func
, new, 1, {
281 gc_assert(!dynamic_pointer_p((lispobj
)func
));
282 pscav(&func
->self
, 1, 1);
283 pscav_later(&func
->name
, 4);
290 ptrans_func(lispobj thing
, lispobj header
)
292 /* Thing can either be a function header,
293 * a closure, or a funcallable-instance. If it's a closure
294 * or a funcallable-instance, we do the same as ptrans_boxed.
295 * Otherwise we have to do something strange, 'cause it is buried
296 * inside a code object. */
298 if (widetag_of(header
) == SIMPLE_FUN_WIDETAG
) {
300 /* We can only end up here if the code object has not been
301 * scavenged, because if it had been scavenged, forwarding pointers
302 * would have been left behind for all the entry points. */
304 struct simple_fun
*function
= (struct simple_fun
*)native_pointer(thing
);
305 lispobj code
= make_lispobj(native_pointer(thing
) - HeaderValue(function
->header
),
306 OTHER_POINTER_LOWTAG
);
308 /* This will cause the function's header to be replaced with a
309 * forwarding pointer. */
313 /* So we can just return that. */
314 return function
->header
;
316 /* It's some kind of closure-like thing. */
317 lispobj
*old
= native_pointer(thing
);
318 long nwords
= sizetab
[widetag_of(header
)](old
);
320 /* Allocate the new one. FINs *must* not go in read_only
321 * space. Closures can; they never change */
323 lispobj
*new = newspace_alloc
324 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_WIDETAG
));
327 bcopy(old
, new, nwords
* sizeof(lispobj
));
329 /* Deposit forwarding pointer. */
330 lispobj result
= make_lispobj(new, lowtag_of(thing
));
334 pscav(new, nwords
, 0);
341 ptrans_returnpc(lispobj thing
, lispobj header
)
343 /* Find the corresponding code object. */
344 lispobj code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
346 /* Make sure it's been transported. */
347 lispobj
new = *native_pointer(code
);
348 if (!forwarding_pointer_p(new))
349 new = ptrans_code(code
);
351 /* Maintain the offset: */
352 return new + (thing
- code
);
355 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
358 ptrans_list(lispobj thing
, boolean constant
)
360 struct cons
*old
, *new, *orig
;
363 orig
= (struct cons
*) newspace_alloc(0,constant
);
367 /* Allocate a new cons cell. */
368 old
= (struct cons
*)native_pointer(thing
);
369 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
371 /* Copy the cons cell and keep a pointer to the cdr. */
373 thing
= new->cdr
= old
->cdr
;
375 /* Set up the forwarding pointer. */
376 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
378 /* And count this cell. */
380 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
381 dynamic_pointer_p(thing
) &&
382 !(forwarding_pointer_p(*native_pointer(thing
))));
384 /* Scavenge the list we just copied. */
385 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
387 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
391 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
393 int widetag
= widetag_of(header
);
395 /* FIXME: this needs a reindent */
397 case SINGLE_FLOAT_WIDETAG
:
398 case DOUBLE_FLOAT_WIDETAG
:
399 #ifdef LONG_FLOAT_WIDETAG
400 case LONG_FLOAT_WIDETAG
:
402 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
403 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
405 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
406 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
408 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
409 case COMPLEX_LONG_FLOAT_WIDETAG
:
412 return ptrans_unboxed(thing
, header
);
414 case COMPLEX_WIDETAG
:
415 case SIMPLE_ARRAY_WIDETAG
:
416 case COMPLEX_BASE_STRING_WIDETAG
:
417 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
418 case COMPLEX_CHARACTER_STRING_WIDETAG
:
420 case COMPLEX_BIT_VECTOR_WIDETAG
:
421 case COMPLEX_VECTOR_NIL_WIDETAG
:
422 case COMPLEX_VECTOR_WIDETAG
:
423 case COMPLEX_ARRAY_WIDETAG
:
424 return ptrans_boxed(thing
, header
, constant
);
426 case VALUE_CELL_WIDETAG
:
427 case WEAK_POINTER_WIDETAG
:
428 return ptrans_boxed(thing
, header
, 0);
431 return ptrans_boxed(thing
, header
, 0);
433 case SIMPLE_VECTOR_WIDETAG
:
434 return ptrans_vector(thing
, 1, constant
);
436 case CODE_HEADER_WIDETAG
:
437 return ptrans_code(thing
);
439 case RETURN_PC_WIDETAG
:
440 return ptrans_returnpc(thing
, header
);
443 return ptrans_fdefn(thing
, header
);
446 if (other_immediate_lowtag_p(widetag
) &&
447 specialized_vector_widetag_p(widetag
))
448 return ptrans_vector(thing
, 0, constant
);
449 fprintf(stderr
, "Invalid widetag: %d\n", widetag_of(header
));
450 /* Should only come across other pointers to the above stuff. */
457 pscav_fdefn(struct fdefn
*fdefn
)
461 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
462 pscav(&fdefn
->name
, 1, 1);
463 pscav(&fdefn
->fun
, 1, 0);
465 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
466 return sizeof(struct fdefn
) / sizeof(lispobj
);
470 pscav(lispobj
*addr
, long nwords
, boolean constant
)
472 lispobj thing
, *thingp
, header
;
473 long count
= 0; /* (0 = dummy init value to stop GCC warning) */
477 int widetag
= widetag_of(thing
);
478 if (is_lisp_pointer(thing
)) {
479 /* It's a pointer. Is it something we might have to move? */
480 if (dynamic_pointer_p(thing
)) {
481 /* Maybe. Have we already moved it? */
482 thingp
= native_pointer(thing
);
484 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
485 /* Yep, so just copy the forwarding pointer. */
488 /* Nope, copy the object. */
489 switch (lowtag_of(thing
)) {
490 case FUN_POINTER_LOWTAG
:
491 thing
= ptrans_func(thing
, header
);
494 case LIST_POINTER_LOWTAG
:
495 thing
= ptrans_list(thing
, constant
);
498 case INSTANCE_POINTER_LOWTAG
:
499 thing
= ptrans_instance(thing
, header
, constant
);
502 case OTHER_POINTER_LOWTAG
:
503 thing
= ptrans_otherptr(thing
, header
, constant
);
507 /* It was a pointer, but not one of them? */
515 #if N_WORD_BITS == 64
516 else if (widetag
== SINGLE_FLOAT_WIDETAG
) {
520 else if (thing
& FIXNUM_TAG_MASK
) {
521 /* It's an other immediate. Maybe the header for an unboxed */
525 case SINGLE_FLOAT_WIDETAG
:
526 case DOUBLE_FLOAT_WIDETAG
:
527 #ifdef LONG_FLOAT_WIDETAG
528 case LONG_FLOAT_WIDETAG
:
531 /* It's an unboxed simple object. */
532 count
= CEILING(HeaderValue(thing
)+1, 2);
535 case SIMPLE_VECTOR_WIDETAG
:
536 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
537 struct hash_table
*hash_table
=
538 (struct hash_table
*)native_pointer(addr
[2]);
539 hash_table
->needs_rehash_p
= T
;
544 case CODE_HEADER_WIDETAG
:
545 gc_abort(); /* no code headers in static space */
548 case SIMPLE_FUN_WIDETAG
:
549 case RETURN_PC_WIDETAG
:
550 /* We should never hit any of these, 'cause they occur
551 * buried in the middle of code objects. */
555 case WEAK_POINTER_WIDETAG
:
556 /* Weak pointers get preserved during purify, 'cause I
557 * don't feel like figuring out how to break them. */
558 pscav(addr
+1, 2, constant
);
559 count
= WEAK_POINTER_NWORDS
;
563 /* We have to handle fdefn objects specially, so we
564 * can fix up the raw function address. */
565 count
= pscav_fdefn((struct fdefn
*)addr
);
568 case INSTANCE_WIDETAG
:
570 lispobj lbitmap
= LAYOUT(instance_layout(addr
))->bitmap
;
571 lispobj
* slots
= addr
+ 1;
572 long nslots
= instance_length(*addr
) | 1;
574 if (fixnump(lbitmap
)) {
575 sword_t bitmap
= (sword_t
)lbitmap
>> N_FIXNUM_TAG_BITS
;
576 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
578 pscav(slots
+ index
, 1, constant
);
580 struct bignum
* bitmap
;
581 bitmap
= (struct bignum
*)native_pointer(lbitmap
);
582 for (index
= 0; index
< nslots
; index
++)
583 if (positive_bignum_logbitp(index
, bitmap
))
584 pscav(slots
+ index
, 1, constant
);
591 if (other_immediate_lowtag_p(widetag
) &&
592 specialized_vector_widetag_p(widetag
))
593 count
= sizetab
[widetag_of(thing
)](addr
);
612 purify(lispobj static_roots
, lispobj read_only_roots
)
616 struct later
*laters
, *next
;
617 struct thread
*thread
;
619 if(all_threads
->next
) {
620 /* FIXME: there should be _some_ sensible error reporting
621 * convention. See following comment too */
622 fprintf(stderr
,"Can't purify when more than one thread exists\n");
628 printf("[doing purification:");
632 for_each_thread(thread
)
633 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
634 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
635 * its error simply by a. printing a string b. to stdout instead
637 printf(" Ack! Can't purify interrupt contexts. ");
642 dynamic_space_purify_pointer
= dynamic_space_free_pointer
;
644 read_only_end
= read_only_free
= read_only_space_free_pointer
;
645 static_end
= static_free
= static_space_free_pointer
;
652 pscav(&static_roots
, 1, 0);
653 pscav(&read_only_roots
, 1, 1);
659 pscav((lispobj
*) interrupt_handlers
,
660 sizeof(interrupt_handlers
) / sizeof(lispobj
),
667 pscav((lispobj
*)all_threads
->control_stack_start
,
668 access_control_stack_pointer(all_threads
) -
669 all_threads
->control_stack_start
,
677 pscav( (lispobj
*)all_threads
->binding_stack_start
,
678 (lispobj
*)get_binding_stack_pointer(all_threads
) -
679 all_threads
->binding_stack_start
,
682 /* The original CMU CL code had scavenge-read-only-space code
683 * controlled by the Lisp-level variable
684 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
685 * wasn't documented under what circumstances it was useful or
686 * safe to turn it on, so it's been turned off in SBCL. If you
687 * want/need this functionality, and can test and document it,
688 * please submit a patch. */
690 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
691 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
692 unsigned read_only_space_size
=
693 read_only_space_free_pointer
- (lispobj
*)READ_ONLY_SPACE_START
;
695 "scavenging read only space: %d bytes\n",
696 read_only_space_size
* sizeof(lispobj
));
697 pscav( (lispobj
*)READ_ONLY_SPACE_START
, read_only_space_size
, 0);
705 clean
= (lispobj
*)STATIC_SPACE_START
;
707 while (clean
!= static_free
)
708 clean
= pscav(clean
, static_free
- clean
, 0);
709 laters
= later_blocks
;
713 while (laters
!= NULL
) {
714 for (i
= 0; i
< count
; i
++) {
715 if (laters
->u
[i
].count
== 0) {
717 } else if (laters
->u
[i
].count
<= LATERMAXCOUNT
) {
718 pscav(laters
->u
[i
+1].ptr
, laters
->u
[i
].count
, 1);
721 pscav(laters
->u
[i
].ptr
, 1, 1);
727 count
= LATERBLOCKSIZE
;
729 } while (clean
!= static_free
|| later_blocks
!= NULL
);
735 #ifdef LISP_FEATURE_HPUX
736 clear_auto_gc_trigger(); /* restore mmap as it was given by os */
739 os_zero((os_vm_address_t
) current_dynamic_space
, dynamic_space_size
);
741 /* Zero the stack. */
742 os_zero((os_vm_address_t
) access_control_stack_pointer(all_threads
),
744 ((all_threads
->control_stack_end
-
745 access_control_stack_pointer(all_threads
)) * sizeof(lispobj
)));
747 /* It helps to update the heap free pointers so that free_heap can
748 * verify after it's done. */
749 read_only_space_free_pointer
= read_only_free
;
750 static_space_free_pointer
= static_free
;
752 dynamic_space_free_pointer
= current_dynamic_space
;
753 set_auto_gc_trigger(bytes_consed_between_gcs
);
755 /* Blast away instruction cache */
756 os_flush_icache((os_vm_address_t
)READ_ONLY_SPACE_START
, READ_ONLY_SPACE_SIZE
);
757 os_flush_icache((os_vm_address_t
)STATIC_SPACE_START
, STATIC_SPACE_SIZE
);
765 #else /* LISP_FEATURE_GENCGC */
767 purify(lispobj static_roots
, lispobj read_only_roots
)
769 lose("purify called for GENCGC. This should not happen.");
771 #endif /* LISP_FEATURE_GENCGC */