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;
75 forwarding_pointer_p(lispobj obj
)
77 lispobj
*ptr
= native_pointer(obj
);
79 return ((static_end
<= ptr
&& ptr
<= static_free
) ||
80 (read_only_end
<= ptr
&& ptr
<= read_only_free
));
84 dynamic_pointer_p(lispobj ptr
)
86 return (ptr
>= (lispobj
)current_dynamic_space
88 ptr
< (lispobj
)dynamic_space_purify_pointer
);
91 static inline lispobj
*
92 newspace_alloc(long nwords
, int constantp
)
95 gc_assert((nwords
& 1) == 0);
97 if(read_only_free
+ nwords
>= (lispobj
*)READ_ONLY_SPACE_END
) {
98 lose("Ran out of read-only space while purifying!\n");
101 read_only_free
+=nwords
;
103 if(static_free
+ nwords
>= (lispobj
*)STATIC_SPACE_END
) {
104 lose("Ran out of static space while purifying!\n");
114 pscav_later(lispobj
*where
, long count
)
118 if (count
> LATERMAXCOUNT
) {
119 while (count
> LATERMAXCOUNT
) {
120 pscav_later(where
, LATERMAXCOUNT
);
121 count
-= LATERMAXCOUNT
;
122 where
+= LATERMAXCOUNT
;
126 if (later_blocks
== NULL
|| later_count
== LATERBLOCKSIZE
||
127 (later_count
== LATERBLOCKSIZE
-1 && count
> 1)) {
128 new = (struct later
*)malloc(sizeof(struct later
));
129 new->next
= later_blocks
;
130 if (later_blocks
&& later_count
< LATERBLOCKSIZE
)
131 later_blocks
->u
[later_count
].ptr
= NULL
;
137 later_blocks
->u
[later_count
++].count
= count
;
138 later_blocks
->u
[later_count
++].ptr
= where
;
143 ptrans_boxed(lispobj thing
, lispobj header
, boolean constant
)
146 lispobj
*old
= native_pointer(thing
);
147 long nwords
= sizetab
[widetag_of(header
)](old
);
148 lispobj
*new = newspace_alloc(nwords
,constant
);
151 bcopy(old
, new, nwords
* sizeof(lispobj
));
153 /* Deposit forwarding pointer. */
154 lispobj result
= make_lispobj(new, lowtag_of(thing
));
158 pscav(new, nwords
, constant
);
163 /* We need to look at the layout to see whether it is a pure structure
164 * class, and only then can we transport as constant. If it is pure,
165 * we can ALWAYS transport as a constant. */
167 ptrans_instance(lispobj thing
, lispobj header
, boolean
/* ignored */ constant
)
169 struct layout
*layout
=
170 (struct layout
*) native_pointer(((struct instance
*)native_pointer(thing
))->slots
[0]);
171 lispobj pure
= layout
->pure
;
175 return (ptrans_boxed(thing
, header
, 1));
177 return (ptrans_boxed(thing
, header
, 0));
180 return NIL
; /* dummy value: return something ... */
185 ptrans_fdefn(lispobj thing
, lispobj header
)
188 lispobj
*old
= native_pointer(thing
);
189 long nwords
= sizetab
[widetag_of(header
)](old
);
190 lispobj
*new = newspace_alloc(nwords
, 0); /* inconstant */
193 bcopy(old
, new, nwords
* sizeof(lispobj
));
195 /* Deposit forwarding pointer. */
196 lispobj result
= make_lispobj(new, lowtag_of(thing
));
199 /* Scavenge the function. */
200 struct fdefn
*fdefn
= (struct fdefn
*)new;
201 lispobj oldfn
= fdefn
->fun
;
202 pscav(&fdefn
->fun
, 1, 0);
203 if ((char *)oldfn
+ FUN_RAW_ADDR_OFFSET
== fdefn
->raw_addr
)
204 fdefn
->raw_addr
= (char *)fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
;
210 ptrans_unboxed(lispobj thing
, lispobj header
)
213 lispobj
*old
= native_pointer(thing
);
214 long nwords
= sizetab
[widetag_of(header
)](old
);
215 lispobj
*new = newspace_alloc(nwords
, 1); /* always constant */
218 bcopy(old
, new, nwords
* sizeof(lispobj
));
220 /* Deposit forwarding pointer. */
221 lispobj result
= make_lispobj(new, lowtag_of(thing
));
228 ptrans_vector(lispobj thing
, boolean boxed
, boolean constant
)
230 struct vector
*vector
= (struct vector
*)native_pointer(thing
);
231 long nwords
= sizetab
[widetag_of(vector
->header
)]((lispobj
*)vector
);
233 lispobj
*new = newspace_alloc(nwords
, (constant
|| !boxed
));
234 bcopy(vector
, new, nwords
* sizeof(lispobj
));
236 lispobj result
= make_lispobj(new, lowtag_of(thing
));
237 vector
->header
= result
;
240 pscav(new, nwords
, constant
);
246 ptrans_code(lispobj thing
)
248 struct code
*code
= (struct code
*)native_pointer(thing
);
249 long nwords
= code_header_words(code
->header
)
250 + code_instruction_words(code
->code_size
);
252 struct code
*new = (struct code
*)newspace_alloc(nwords
,1); /* constant */
254 bcopy(code
, new, nwords
* sizeof(lispobj
));
256 lispobj result
= make_lispobj(new, OTHER_POINTER_LOWTAG
);
258 /* Put in forwarding pointers for all the functions. */
259 uword_t displacement
= result
- thing
;
260 for_each_simple_fun(i
, newfunc
, new, 1, {
261 lispobj
* old
= (lispobj
*)LOW_WORD((char*)newfunc
- displacement
);
262 *old
= make_lispobj(newfunc
, FUN_POINTER_LOWTAG
);
265 /* Stick in a forwarding pointer for the code object. */
266 /* This smashes the header, so do it only after reading n_funs */
267 *(lispobj
*)code
= result
;
269 /* Arrange to scavenge the debug info later. */
270 pscav_later(&new->debug_info
, 1);
272 /* Scavenge the constants. */
273 pscav(new->constants
,
274 code_header_words(new->header
) - (offsetof(struct code
, constants
) >> WORD_SHIFT
),
277 /* Scavenge all the functions. */
278 for_each_simple_fun(i
, func
, new, 1, {
279 gc_assert(!dynamic_pointer_p((lispobj
)func
));
280 pscav(&func
->self
, 1, 1);
281 pscav_later(&func
->name
, 4);
288 ptrans_func(lispobj thing
, lispobj header
)
290 /* Thing can either be a function header,
291 * a closure, or a funcallable-instance. If it's a closure
292 * or a funcallable-instance, we do the same as ptrans_boxed.
293 * Otherwise we have to do something strange, 'cause it is buried
294 * inside a code object. */
296 if (widetag_of(header
) == SIMPLE_FUN_HEADER_WIDETAG
) {
298 /* We can only end up here if the code object has not been
299 * scavenged, because if it had been scavenged, forwarding pointers
300 * would have been left behind for all the entry points. */
302 struct simple_fun
*function
= (struct simple_fun
*)native_pointer(thing
);
303 lispobj code
= make_lispobj(native_pointer(thing
) - HeaderValue(function
->header
),
304 OTHER_POINTER_LOWTAG
);
306 /* This will cause the function's header to be replaced with a
307 * forwarding pointer. */
311 /* So we can just return that. */
312 return function
->header
;
314 /* It's some kind of closure-like thing. */
315 lispobj
*old
= native_pointer(thing
);
316 long nwords
= sizetab
[widetag_of(header
)](old
);
318 /* Allocate the new one. FINs *must* not go in read_only
319 * space. Closures can; they never change */
321 lispobj
*new = newspace_alloc
322 (nwords
,(widetag_of(header
)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG
));
325 bcopy(old
, new, nwords
* sizeof(lispobj
));
327 /* Deposit forwarding pointer. */
328 lispobj result
= make_lispobj(new, lowtag_of(thing
));
332 pscav(new, nwords
, 0);
339 ptrans_returnpc(lispobj thing
, lispobj header
)
341 /* Find the corresponding code object. */
342 lispobj code
= thing
- HeaderValue(header
)*sizeof(lispobj
);
344 /* Make sure it's been transported. */
345 lispobj
new = *native_pointer(code
);
346 if (!forwarding_pointer_p(new))
347 new = ptrans_code(code
);
349 /* Maintain the offset: */
350 return new + (thing
- code
);
353 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
356 ptrans_list(lispobj thing
, boolean constant
)
358 struct cons
*old
, *new, *orig
;
361 orig
= (struct cons
*) newspace_alloc(0,constant
);
365 /* Allocate a new cons cell. */
366 old
= (struct cons
*)native_pointer(thing
);
367 new = (struct cons
*) newspace_alloc(WORDS_PER_CONS
,constant
);
369 /* Copy the cons cell and keep a pointer to the cdr. */
371 thing
= new->cdr
= old
->cdr
;
373 /* Set up the forwarding pointer. */
374 *(lispobj
*)old
= make_lispobj(new, LIST_POINTER_LOWTAG
);
376 /* And count this cell. */
378 } while (lowtag_of(thing
) == LIST_POINTER_LOWTAG
&&
379 dynamic_pointer_p(thing
) &&
380 !(forwarding_pointer_p(*native_pointer(thing
))));
382 /* Scavenge the list we just copied. */
383 pscav((lispobj
*)orig
, length
* WORDS_PER_CONS
, constant
);
385 return make_lispobj(orig
, LIST_POINTER_LOWTAG
);
389 ptrans_otherptr(lispobj thing
, lispobj header
, boolean constant
)
391 switch (widetag_of(header
)) {
392 /* FIXME: this needs a reindent */
394 case SINGLE_FLOAT_WIDETAG
:
395 case DOUBLE_FLOAT_WIDETAG
:
396 #ifdef LONG_FLOAT_WIDETAG
397 case LONG_FLOAT_WIDETAG
:
399 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
400 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
402 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
403 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
405 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
406 case COMPLEX_LONG_FLOAT_WIDETAG
:
409 return ptrans_unboxed(thing
, header
);
411 case COMPLEX_WIDETAG
:
412 case SIMPLE_ARRAY_WIDETAG
:
413 case COMPLEX_BASE_STRING_WIDETAG
:
414 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
415 case COMPLEX_CHARACTER_STRING_WIDETAG
:
417 case COMPLEX_BIT_VECTOR_WIDETAG
:
418 case COMPLEX_VECTOR_NIL_WIDETAG
:
419 case COMPLEX_VECTOR_WIDETAG
:
420 case COMPLEX_ARRAY_WIDETAG
:
421 return ptrans_boxed(thing
, header
, constant
);
423 case VALUE_CELL_HEADER_WIDETAG
:
424 case WEAK_POINTER_WIDETAG
:
425 return ptrans_boxed(thing
, header
, 0);
427 case SYMBOL_HEADER_WIDETAG
:
428 return ptrans_boxed(thing
, header
, 0);
430 #include "genesis/specialized-vectors.inc"
431 return ptrans_vector(thing
, 0, constant
);
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_HEADER_WIDETAG
:
440 return ptrans_returnpc(thing
, header
);
443 return ptrans_fdefn(thing
, header
);
446 fprintf(stderr
, "Invalid widetag: %d\n", widetag_of(header
));
447 /* Should only come across other pointers to the above stuff. */
454 pscav_fdefn(struct fdefn
*fdefn
)
458 fix_func
= ((char *)(fdefn
->fun
+FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
);
459 pscav(&fdefn
->name
, 1, 1);
460 pscav(&fdefn
->fun
, 1, 0);
462 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
463 return sizeof(struct fdefn
) / sizeof(lispobj
);
467 pscav(lispobj
*addr
, long nwords
, boolean constant
)
469 lispobj thing
, *thingp
, header
;
470 long count
= 0; /* (0 = dummy init value to stop GCC warning) */
474 if (is_lisp_pointer(thing
)) {
475 /* It's a pointer. Is it something we might have to move? */
476 if (dynamic_pointer_p(thing
)) {
477 /* Maybe. Have we already moved it? */
478 thingp
= native_pointer(thing
);
480 if (is_lisp_pointer(header
) && forwarding_pointer_p(header
))
481 /* Yep, so just copy the forwarding pointer. */
484 /* Nope, copy the object. */
485 switch (lowtag_of(thing
)) {
486 case FUN_POINTER_LOWTAG
:
487 thing
= ptrans_func(thing
, header
);
490 case LIST_POINTER_LOWTAG
:
491 thing
= ptrans_list(thing
, constant
);
494 case INSTANCE_POINTER_LOWTAG
:
495 thing
= ptrans_instance(thing
, header
, constant
);
498 case OTHER_POINTER_LOWTAG
:
499 thing
= ptrans_otherptr(thing
, header
, constant
);
503 /* It was a pointer, but not one of them? */
511 #if N_WORD_BITS == 64
512 else if (widetag_of(thing
) == SINGLE_FLOAT_WIDETAG
) {
516 else if (thing
& FIXNUM_TAG_MASK
) {
517 /* It's an other immediate. Maybe the header for an unboxed */
519 switch (widetag_of(thing
)) {
521 case SINGLE_FLOAT_WIDETAG
:
522 case DOUBLE_FLOAT_WIDETAG
:
523 #ifdef LONG_FLOAT_WIDETAG
524 case LONG_FLOAT_WIDETAG
:
527 /* It's an unboxed simple object. */
528 count
= CEILING(HeaderValue(thing
)+1, 2);
531 case SIMPLE_VECTOR_WIDETAG
:
532 if (HeaderValue(thing
) == subtype_VectorValidHashing
) {
533 struct hash_table
*hash_table
=
534 (struct hash_table
*)native_pointer(addr
[2]);
535 hash_table
->needs_rehash_p
= T
;
540 #include "genesis/specialized-vectors.inc"
541 count
= sizetab
[widetag_of(thing
)](addr
);
544 case CODE_HEADER_WIDETAG
:
545 gc_abort(); /* no code headers in static space */
548 case SIMPLE_FUN_HEADER_WIDETAG
:
549 case RETURN_PC_HEADER_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_HEADER_WIDETAG
:
570 struct layout
*layout
571 = (struct layout
*)native_pointer(instance_layout(addr
));
572 lispobj
* slots
= addr
+ 1;
573 long nslots
= instance_length(*addr
) | 1;
575 if (fixnump(layout
->bitmap
)) {
576 sword_t bitmap
= (sword_t
)layout
->bitmap
>> N_FIXNUM_TAG_BITS
;
577 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
579 pscav(slots
+ index
, 1, constant
);
581 struct bignum
* bitmap
;
582 bitmap
= (struct bignum
*)native_pointer(layout
->bitmap
);
583 for (index
= 0; index
< nslots
; index
++)
584 if (positive_bignum_logbitp(index
, bitmap
))
585 pscav(slots
+ index
, 1, constant
);
609 purify(lispobj static_roots
, lispobj read_only_roots
)
613 struct later
*laters
, *next
;
614 struct thread
*thread
;
616 if(all_threads
->next
) {
617 /* FIXME: there should be _some_ sensible error reporting
618 * convention. See following comment too */
619 fprintf(stderr
,"Can't purify when more than one thread exists\n");
625 printf("[doing purification:");
629 for_each_thread(thread
)
630 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
)) != 0) {
631 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
632 * its error simply by a. printing a string b. to stdout instead
634 printf(" Ack! Can't purify interrupt contexts. ");
639 dynamic_space_purify_pointer
= dynamic_space_free_pointer
;
641 read_only_end
= read_only_free
=
642 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
,0);
643 static_end
= static_free
=
644 (lispobj
*)SymbolValue(STATIC_SPACE_FREE_POINTER
,0);
651 pscav(&static_roots
, 1, 0);
652 pscav(&read_only_roots
, 1, 1);
658 pscav((lispobj
*) interrupt_handlers
,
659 sizeof(interrupt_handlers
) / sizeof(lispobj
),
666 pscav((lispobj
*)all_threads
->control_stack_start
,
667 access_control_stack_pointer(all_threads
) -
668 all_threads
->control_stack_start
,
676 pscav( (lispobj
*)all_threads
->binding_stack_start
,
677 (lispobj
*)get_binding_stack_pointer(all_threads
) -
678 all_threads
->binding_stack_start
,
681 /* The original CMU CL code had scavenge-read-only-space code
682 * controlled by the Lisp-level variable
683 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
684 * wasn't documented under what circumstances it was useful or
685 * safe to turn it on, so it's been turned off in SBCL. If you
686 * want/need this functionality, and can test and document it,
687 * please submit a patch. */
689 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != UNBOUND_MARKER_WIDETAG
690 && SymbolValue(SCAVENGE_READ_ONLY_SPACE
) != NIL
) {
691 unsigned read_only_space_size
=
692 (lispobj
*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER
) -
693 (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 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER
, (lispobj
)read_only_free
,0);
750 SetSymbolValue(STATIC_SPACE_FREE_POINTER
, (lispobj
)static_free
,0);
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 */