2 * Garbage Collection common functions for scavenging, moving and sizing
3 * objects. These are for use with both GC (stop & copy GC) and GENCGC
7 * This software is part of the SBCL system. See the README file for
10 * This software is derived from the CMU CL system, which was
11 * written at Carnegie Mellon University and released into the
12 * public domain. The software is in the public domain and is
13 * provided with absolutely no warranty. See the COPYING and CREDITS
14 * files for more information.
18 * For a review of garbage collection techniques (e.g. generational
19 * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
20 * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
21 * had been accepted for _ACM Computing Surveys_ and was available
22 * as a PostScript preprint through
23 * <http://www.cs.utexas.edu/users/oops/papers.html>
25 * <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
28 #define _GNU_SOURCE /* for ffsl(3) from string.h */
38 #include "interrupt.h"
43 #include "genesis/primitive-objects.h"
44 #include "genesis/static-symbols.h"
45 #include "genesis/layout.h"
46 #include "genesis/hash-table.h"
47 #include "gc-internal.h"
48 #include "forwarding-ptr.h"
51 #ifdef LISP_FEATURE_SPARC
52 #define LONG_FLOAT_SIZE 4
53 #elif defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
54 #define LONG_FLOAT_SIZE 3
57 os_vm_size_t dynamic_space_size
= DEFAULT_DYNAMIC_SPACE_SIZE
;
58 os_vm_size_t thread_control_stack_size
= DEFAULT_CONTROL_STACK_SIZE
;
60 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
61 lispobj (*transother
[256])(lispobj object
);
62 sword_t (*sizetab
[256])(lispobj
*where
);
63 struct weak_pointer
*weak_pointers
;
65 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
71 /* gc_general_copy_object is inline from gc-internal.h */
73 /* to copy a boxed object */
75 copy_object(lispobj object
, sword_t nwords
)
77 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
81 copy_code_object(lispobj object
, sword_t nwords
)
83 return gc_general_copy_object(object
, nwords
, CODE_PAGE_FLAG
);
86 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
88 #ifdef LISP_FEATURE_IMMOBILE_SPACE
89 static const int n_dwords_in_card
= GENCGC_CARD_BYTES
/ N_WORD_BYTES
/ 2;
90 extern uword_t
*page_table_pinned_dwords
;
92 static inline boolean
__attribute__((unused
))
93 pinned_p(lispobj obj
, page_index_t page
)
95 if (!page_table
[page
].has_pin_map
) return 0;
96 int dword_num
= (obj
& (GENCGC_CARD_BYTES
-1)) >> (1+WORD_SHIFT
);
97 uword_t
*bits
= &page_table_pinned_dwords
[page
* (n_dwords_in_card
/N_WORD_BITS
)];
98 return (bits
[dword_num
/ N_WORD_BITS
] >> (dword_num
% N_WORD_BITS
)) & 1;
103 scavenge(lispobj
*start
, sword_t n_words
)
105 lispobj
*end
= start
+ n_words
;
109 // * With 32-bit words, is_lisp_pointer(object) returns true if object_ptr
110 // points to a forwarding pointer, so we need a sanity check inside the
111 // branch for is_lisp_pointer(). For maximum efficiency, check that only
112 // after from_space_p() returns false, so that valid pointers into
113 // from_space incur no extra test. This could be improved further by
114 // skipping the FP check if 'object' points within dynamic space, i.e.,
115 // when find_page_index() returns >= 0. That would entail injecting
116 // from_space_p() explicitly into the loop, so as to separate the
117 // "was a page found at all" condition from the page generation test.
119 // * With 64-bit words, is_lisp_pointer(object) is false when object_ptr
120 // points to a forwarding pointer, and the fixnump() test also returns
121 // false, so we'll indirect through scavtab[]. This will safely invoke
122 // scav_lose(), detecting corruption without any extra cost.
123 // The major difference between that and the explicit test is that you
124 // won't see 'start' and 'n_words', but if you need those, chances are
125 // you'll want to run under an external debugger in the first place.
126 // [And btw it sure would be nice to assert statically
127 // that is_lisp_pointer(0x01) is indeed false]
129 #define FIX_POINTER() { \
130 lispobj *ptr = native_pointer(object); \
131 if (forwarding_pointer_p(ptr)) \
132 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); \
133 else /* Scavenge that pointer. */ \
134 (void)scavtab[widetag_of(object)](object_ptr, object); \
137 for (object_ptr
= start
; object_ptr
< end
;) {
138 lispobj object
= *object_ptr
;
139 if (is_lisp_pointer(object
)) {
140 #ifdef LISP_FEATURE_IMMOBILE_SPACE
142 // It would be fine, though suboptimal, to use from_space_p() here.
143 // If it returns false, we don't want to call immobile_space_p()
144 // unless the pointer is *not* into dynamic space.
145 if ((page
= find_page_index((void*)object
)) >= 0) {
146 if (page_table
[page
].gen
== from_space
&& !pinned_p(object
, page
))
148 } else if (immobile_space_p(object
)) {
149 lispobj
*ptr
= native_pointer(object
);
150 if (immobile_obj_gen_bits(ptr
) == from_space
)
151 promote_immobile_obj(ptr
, 1);
154 if (from_space_p(object
)) {
157 #if (N_WORD_BITS == 32) && defined(LISP_FEATURE_GENCGC)
158 if (forwarding_pointer_p(object_ptr
))
159 lose("unexpected forwarding pointer in scavenge: %p, start=%p, n=%ld\n",
160 object_ptr
, start
, n_words
);
162 /* It points somewhere other than oldspace. Leave it
168 else if (fixnump(object
)) {
169 /* It's a fixnum: really easy.. */
172 /* It's some sort of header object or another. */
173 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
176 // This assertion is usually the one that fails when something
177 // is subtly wrong with the heap, so definitely always do it.
178 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
179 object_ptr
, start
, end
);
182 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
183 static lispobj
trans_short_boxed(lispobj object
);
186 scav_fun_pointer(lispobj
*where
, lispobj object
)
188 lispobj
*first_pointer
;
191 gc_dcheck(lowtag_of(object
) == FUN_POINTER_LOWTAG
);
193 /* Object is a pointer into from_space - not a FP. */
194 first_pointer
= native_pointer(object
);
196 /* must transport object -- object may point to either a function
197 * header, a closure function header, or to a closure header. */
199 switch (widetag_of(*first_pointer
)) {
200 case SIMPLE_FUN_HEADER_WIDETAG
:
201 copy
= trans_fun_header(object
);
204 copy
= trans_short_boxed(object
);
208 if (copy
!= object
) {
209 /* Set forwarding pointer */
210 set_forwarding_pointer(first_pointer
,copy
);
213 CHECK_COPY_POSTCONDITIONS(copy
, FUN_POINTER_LOWTAG
);
222 trans_code(struct code
*code
)
224 /* if object has already been transported, just return pointer */
225 if (forwarding_pointer_p((lispobj
*)code
)) {
227 printf("Was already transported\n");
229 return (struct code
*)native_pointer(forwarding_pointer_value((lispobj
*)code
));
232 gc_dcheck(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
234 /* prepare to transport the code vector */
235 lispobj l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
236 sword_t nheader_words
= code_header_words(code
->header
);
237 sword_t ncode_words
= code_instruction_words(code
->code_size
);
238 sword_t nwords
= nheader_words
+ ncode_words
;
239 lispobj l_new_code
= copy_code_object(l_code
, nwords
);
240 struct code
*new_code
= (struct code
*) native_pointer(l_new_code
);
242 #if defined(DEBUG_CODE_GC)
243 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
244 (uword_t
) code
, (uword_t
) new_code
);
245 printf("Code object is %d words long.\n", nwords
);
248 #ifdef LISP_FEATURE_GENCGC
249 if (new_code
== code
)
253 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
255 /* set forwarding pointers for all the function headers in the */
256 /* code object. also fix all self pointers */
257 /* Do this by scanning the new code, since the old header is unusable */
259 uword_t displacement
= l_new_code
- l_code
;
261 for_each_simple_fun(i
, nfheaderp
, new_code
, 1, {
262 /* Calculate the old raw function pointer */
263 struct simple_fun
* fheaderp
=
264 (struct simple_fun
*)LOW_WORD((char*)nfheaderp
- displacement
);
265 /* Calculate the new lispobj */
266 lispobj nfheaderl
= make_lispobj(nfheaderp
, FUN_POINTER_LOWTAG
);
269 printf("fheaderp->header (at %x) <- %x\n",
270 &(fheaderp
->header
) , nfheaderl
);
272 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
274 /* fix self pointer. */
276 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
277 FUN_RAW_ADDR_OFFSET
+
281 #ifdef LISP_FEATURE_GENCGC
282 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
283 spaces once when all copying is done. */
284 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
285 ncode_words
* sizeof(sword_t
));
289 #ifdef LISP_FEATURE_X86
290 gencgc_apply_code_fixups(code
, new_code
);
297 scav_code_header(lispobj
*where
, lispobj header
)
299 struct code
*code
= (struct code
*) where
;
300 sword_t n_header_words
= code_header_words(header
);
302 /* Scavenge the boxed section of the code data block. */
303 scavenge(where
+ 1, n_header_words
- 1);
305 /* Scavenge the boxed section of each function object in the
306 * code data block. */
307 for_each_simple_fun(i
, function_ptr
, code
, 1, {
308 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
309 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
312 return n_header_words
+ code_instruction_words(code
->code_size
);
316 trans_code_header(lispobj object
)
320 ncode
= trans_code((struct code
*) native_pointer(object
));
321 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
325 size_code_header(lispobj
*where
)
327 return code_header_words(((struct code
*)where
)->header
)
328 + code_instruction_words(((struct code
*)where
)->code_size
);
331 #ifdef RETURN_PC_HEADER_WIDETAG
333 scav_return_pc_header(lispobj
*where
, lispobj object
)
335 lose("attempted to scavenge a return PC header where=%p object=%#lx\n",
336 where
, (uword_t
) object
);
337 return 0; /* bogus return value to satisfy static type checking */
341 trans_return_pc_header(lispobj object
)
343 struct simple_fun
*return_pc
;
345 struct code
*code
, *ncode
;
347 return_pc
= (struct simple_fun
*) native_pointer(object
);
348 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
350 /* Transport the whole code object */
351 code
= (struct code
*) ((uword_t
) return_pc
- offset
);
352 ncode
= trans_code(code
);
354 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
356 #endif /* RETURN_PC_HEADER_WIDETAG */
358 /* On the 386, closures hold a pointer to the raw address instead of the
359 * function object, so we can use CALL [$FDEFN+const] to invoke
360 * the function without loading it into a register. Given that code
361 * objects don't move, we don't need to update anything, but we do
362 * have to figure out that the function is still live. */
364 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
366 scav_closure_header(lispobj
*where
, lispobj object
)
368 struct closure
*closure
;
371 closure
= (struct closure
*)where
;
372 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
374 #ifdef LISP_FEATURE_GENCGC
375 /* The function may have moved so update the raw address. But
376 * don't write unnecessarily. */
377 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
378 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
384 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
386 scav_fun_header(lispobj
*where
, lispobj object
)
388 lose("attempted to scavenge a function header where=%p object=%#lx\n",
389 where
, (uword_t
) object
);
390 return 0; /* bogus return value to satisfy static type checking */
392 #endif /* LISP_FEATURE_X86 */
395 trans_fun_header(lispobj object
)
397 struct simple_fun
*fheader
;
399 struct code
*code
, *ncode
;
401 fheader
= (struct simple_fun
*) native_pointer(object
);
402 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
404 /* Transport the whole code object */
405 code
= (struct code
*) ((uword_t
) fheader
- offset
);
406 ncode
= trans_code(code
);
408 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
417 trans_instance(lispobj object
)
419 gc_dcheck(lowtag_of(object
) == INSTANCE_POINTER_LOWTAG
);
420 lispobj header
= *(lispobj
*)(object
- INSTANCE_POINTER_LOWTAG
);
421 return copy_object(object
, 1 + (instance_length(header
)|1));
425 size_instance(lispobj
*where
)
427 return 1 + (instance_length(*where
)|1);
431 scav_instance_pointer(lispobj
*where
, lispobj object
)
433 lispobj copy
, *first_pointer
;
435 /* Object is a pointer into from space - not a FP. */
436 copy
= trans_instance(object
);
438 #ifdef LISP_FEATURE_GENCGC
439 gc_dcheck(copy
!= object
);
442 first_pointer
= native_pointer(object
);
443 set_forwarding_pointer(first_pointer
,copy
);
454 static lispobj
trans_list(lispobj object
);
457 scav_list_pointer(lispobj
*where
, lispobj object
)
460 gc_dcheck(lowtag_of(object
) == LIST_POINTER_LOWTAG
);
462 copy
= trans_list(object
);
463 gc_dcheck(copy
!= object
);
465 CHECK_COPY_POSTCONDITIONS(copy
, LIST_POINTER_LOWTAG
);
473 trans_list(lispobj object
)
476 struct cons
*copy
= (struct cons
*)
477 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
478 lispobj new_list_pointer
= make_lispobj(copy
, LIST_POINTER_LOWTAG
);
479 copy
->car
= CONS(object
)->car
;
480 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
481 lispobj cdr
= CONS(object
)->cdr
;
482 set_forwarding_pointer((lispobj
*)CONS(object
), new_list_pointer
);
484 /* Try to linearize the list in the cdr direction to help reduce
486 while (lowtag_of(cdr
) == LIST_POINTER_LOWTAG
&& from_space_p(cdr
)) {
487 lispobj
* native_cdr
= (lispobj
*)CONS(cdr
);
488 if (forwarding_pointer_p(native_cdr
)) { // Might as well fix now.
489 cdr
= forwarding_pointer_value(native_cdr
);
493 struct cons
*cdr_copy
= (struct cons
*)
494 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
495 cdr_copy
->car
= ((struct cons
*)native_cdr
)->car
;
496 /* Grab the cdr before it is clobbered. */
497 lispobj next
= ((struct cons
*)native_cdr
)->cdr
;
498 /* Set cdr of the predecessor, and store an FP. */
499 set_forwarding_pointer(native_cdr
,
500 copy
->cdr
= make_lispobj(cdr_copy
,
501 LIST_POINTER_LOWTAG
));
506 return new_list_pointer
;
511 * scavenging and transporting other pointers
515 scav_other_pointer(lispobj
*where
, lispobj object
)
517 lispobj copy
, *first_pointer
;
519 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
521 /* Object is a pointer into from space - not FP. */
522 first_pointer
= (lispobj
*)(object
- OTHER_POINTER_LOWTAG
);
523 copy
= (transother
[widetag_of(*first_pointer
)])(object
);
525 // If the object was large, then instead of transporting it,
526 // gencgc might simply promote the pages and return the same pointer.
527 // That decision is made in general_copy_large_object().
528 if (copy
!= object
) {
529 set_forwarding_pointer(first_pointer
, copy
);
530 #ifdef LISP_FEATURE_GENCGC
534 #ifndef LISP_FEATURE_GENCGC
537 CHECK_COPY_POSTCONDITIONS(copy
, OTHER_POINTER_LOWTAG
);
542 * immediate, boxed, and unboxed objects
546 size_pointer(lispobj
*where
)
552 scav_immediate(lispobj
*where
, lispobj object
)
558 trans_immediate(lispobj object
)
560 lose("trying to transport an immediate\n");
561 return NIL
; /* bogus return value to satisfy static type checking */
565 size_immediate(lispobj
*where
)
572 scav_boxed(lispobj
*where
, lispobj object
)
577 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
579 /* If the bignum in the layout has another pointer to it (besides the layout)
580 acting as a root, and which is scavenged first, then transporting the
581 bignum causes the layout to see a FP, as would copying an instance whose
582 layout that is. This is a nearly impossible scenario to create organically
583 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
584 except for a few things that would cause it to be pinned anyway,
585 such as it being kept in a local variable during structure manipulation.
586 See 'interleaved-raw.impure.lisp' for a way to trigger this */
587 if (forwarding_pointer_p((lispobj
*)bignum
)) {
588 lispobj forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
590 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
591 (void*)bignum
, (void*)forwarded
);
593 bignum
= (struct bignum
*)native_pointer(forwarded
);
596 int len
= HeaderValue(bignum
->header
);
597 int word_index
= index
/ N_WORD_BITS
;
598 int bit_index
= index
% N_WORD_BITS
;
599 if (word_index
>= len
) {
600 // just return 0 since the marking logic does not allow negative bignums
603 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
607 struct instance_scanner
{
609 void (*proc
)(lispobj
*, sword_t
);
612 // Helper function for helper function below, since lambda isn't a thing
613 static void instance_scan_range(void* arg
, int offset
, int nwords
)
615 struct instance_scanner
*scanner
= (struct instance_scanner
*)arg
;
616 scanner
->proc(scanner
->base
+ offset
, nwords
);
619 // Helper function for stepping through the tagged slots of an instance in
620 // scav_instance and verify_space.
622 instance_scan(void (*proc
)(lispobj
*, sword_t
),
623 lispobj
*instance_slots
,
625 lispobj layout_bitmap
)
629 /* This code might be made more efficient by run-length-encoding the ranges
630 of words to scan, but probably not by much */
632 if (fixnump(layout_bitmap
)) {
633 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
634 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
636 proc(instance_slots
+ index
, 1);
637 } else { /* huge bitmap */
638 struct bignum
* bitmap
;
639 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
640 if (forwarding_pointer_p((lispobj
*)bitmap
))
641 bitmap
= (struct bignum
*)
642 native_pointer(forwarding_pointer_value((lispobj
*)bitmap
));
643 struct instance_scanner scanner
;
644 scanner
.base
= instance_slots
;
646 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
647 instance_scan_range
, &scanner
);
651 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
652 void (*proc
)(void*, int, int), void* arg
)
654 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
655 int start_word_index
= 0;
657 in_use_marker_t word
;
659 flags
= flags
& BIT_SCAN_CLEAR
;
661 // Rather than bzero'ing we can just clear each nonzero word as it's read,
663 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
666 int skip_bits
, start_bit
, start_position
, run_length
;
668 if (++start_word_index
>= n_bitmap_words
) break;
669 BITMAP_REF(start_word_index
);
673 // On each loop iteration, the lowest 1 bit is a "relative"
674 // bit index, since the word was already shifted. This is 'skip_bits'.
675 // Adding back in the total shift amount gives 'start_bit',
676 // the true absolute index within the current word.
677 // 'start_position' is absolute within the entire bitmap.
678 skip_bits
= ffsl(word
) - 1;
679 start_bit
= skip_bits
+ shift
;
680 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
681 // Compute the number of consecutive 1s in the current word.
683 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
684 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
686 shift
+= skip_bits
+ run_length
;
688 int end_word_index
= ++start_word_index
;
690 if (end_word_index
>= n_bitmap_words
) {
692 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
695 BITMAP_REF(end_word_index
);
699 // end_word_index is the exclusive bound on contiguous
700 // words to include in the range. See if the low bits
701 // from the next word can extend the range.
702 shift
= ffsl(~word
) - 1;
704 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
709 start_word_index
= end_word_index
;
711 proc(arg
, start_position
, run_length
);
717 scav_instance(lispobj
*where
, lispobj header
)
719 lispobj
* layout
= (lispobj
*)instance_layout(where
);
722 layout
= native_pointer((lispobj
)layout
);
723 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
724 if (__immobile_obj_gen_bits(layout
) == from_space
)
725 promote_immobile_obj(layout
, 1);
727 if (forwarding_pointer_p(layout
))
728 layout
= native_pointer(forwarding_pointer_value(layout
));
731 sword_t nslots
= instance_length(header
) | 1;
732 lispobj bitmap
= ((struct layout
*)layout
)->bitmap
;
733 if (bitmap
== make_fixnum(-1))
734 scavenge(where
+1, nslots
);
736 instance_scan(scavenge
, where
+1, nslots
, bitmap
);
741 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
743 scav_funinstance(lispobj
*where
, lispobj header
)
745 // This works because the layout is in the header word of all instances,
746 // ordinary and funcallable, when compact headers are enabled.
747 // The trampoline slot in the funcallable-instance is raw, but can be
748 // scavenged, because it points to readonly space, never oldspace.
749 // (And for certain backends it looks like a fixnum, not a pointer)
750 return scav_instance(where
, header
);
754 static lispobj
trans_boxed(lispobj object
)
756 gc_dcheck(is_lisp_pointer(object
));
757 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
758 return copy_object(object
, CEILING(length
, 2));
761 static sword_t
size_boxed(lispobj
*where
)
763 sword_t length
= HeaderValue(*where
) + 1;
764 return CEILING(length
, 2);
767 static lispobj
trans_short_boxed(lispobj object
) // Payload count expressed in 15 bits
769 sword_t length
= (HeaderValue(*native_pointer(object
)) & SHORT_HEADER_MAX_WORDS
) + 1;
770 return copy_object(object
, CEILING(length
, 2));
773 static sword_t
size_short_boxed(lispobj
*where
)
775 sword_t length
= (HeaderValue(*where
) & SHORT_HEADER_MAX_WORDS
) + 1;
776 return CEILING(length
, 2);
779 static lispobj
trans_tiny_boxed(lispobj object
) // Payload count expressed in 8 bits
781 sword_t length
= (HeaderValue(*native_pointer(object
)) & 0xFF) + 1;
782 return copy_object(object
, CEILING(length
, 2));
785 static sword_t
size_tiny_boxed(lispobj
*where
)
787 sword_t length
= (HeaderValue(*where
) & 0xFF) + 1;
788 return CEILING(length
, 2);
791 /* Note: on the sparc we don't have to do anything special for fdefns, */
792 /* 'cause the raw-addr has a function lowtag. */
793 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
795 scav_fdefn(lispobj
*where
, lispobj object
)
799 fdefn
= (struct fdefn
*)where
;
801 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
802 fdefn->fun, fdefn->raw_addr)); */
804 scavenge(where
+ 1, 2); // 'name' and 'fun'
805 #ifndef LISP_FEATURE_IMMOBILE_CODE
806 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
807 if (raw_fun
> READ_ONLY_SPACE_END
) {
808 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
809 scavenge(&simple_fun
, 1);
810 /* Don't write unnecessarily. */
811 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
812 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
814 #elif defined(LISP_FEATURE_X86_64)
815 lispobj obj
= fdefn_raw_referent(fdefn
);
818 scavenge(&new, 1); // enliven
819 gc_dcheck(new == obj
); // must not move
822 # error "Need to implement scav_fdefn"
829 scav_unboxed(lispobj
*where
, lispobj object
)
831 sword_t length
= HeaderValue(object
) + 1;
832 return CEILING(length
, 2);
836 trans_unboxed(lispobj object
)
838 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
839 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
840 return copy_unboxed_object(object
, CEILING(length
, 2));
844 size_unboxed(lispobj
*where
)
846 sword_t length
= HeaderValue(*where
) + 1;
847 return CEILING(length
, 2);
851 /* vector-like objects */
853 trans_vector(lispobj object
)
855 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
858 fixnum_value(((struct vector
*)native_pointer(object
))->length
);
859 return copy_large_object(object
, CEILING(length
+ 2, 2));
863 size_vector(lispobj
*where
)
865 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
866 return CEILING(length
+ 2, 2);
869 #define DEF_SCAV_TRANS_SIZE_UB(nbits) \
870 DEF_SPECIALIZED_VECTOR(vector_unsigned_byte_##nbits, NWORDS(length, nbits))
871 #define DEF_SPECIALIZED_VECTOR(name, nwords) \
872 static sword_t __attribute__((unused)) scav_##name(lispobj *where, lispobj header) { \
873 sword_t length = fixnum_value(((struct vector*)where)->length); \
874 return CEILING(nwords + 2, 2); \
876 static lispobj __attribute__((unused)) trans_##name(lispobj object) { \
877 gc_dcheck(lowtag_of(object) == OTHER_POINTER_LOWTAG); \
878 sword_t length = fixnum_value(((struct vector*)(object-OTHER_POINTER_LOWTAG))->length); \
879 return copy_large_unboxed_object(object, CEILING(nwords + 2, 2)); \
881 static sword_t __attribute__((unused)) size_##name(lispobj *where) { \
882 sword_t length = fixnum_value(((struct vector*)where)->length); \
883 return CEILING(nwords + 2, 2); \
886 DEF_SPECIALIZED_VECTOR(vector_nil
, 0*length
)
887 DEF_SPECIALIZED_VECTOR(vector_bit
, NWORDS(length
,1))
888 /* NOTE: strings contain one more element of data (a terminating '\0'
889 * to help interface with C functions) than indicated by the length slot.
890 * This is true even for UCS4 strings, despite that C APIs are unlikely
891 * to have a convention that expects 4 zero bytes. */
892 DEF_SPECIALIZED_VECTOR(base_string
, NWORDS((length
+1), 8))
893 DEF_SPECIALIZED_VECTOR(character_string
, NWORDS((length
+1), 32))
894 DEF_SCAV_TRANS_SIZE_UB(2)
895 DEF_SCAV_TRANS_SIZE_UB(4)
896 DEF_SCAV_TRANS_SIZE_UB(8)
897 DEF_SCAV_TRANS_SIZE_UB(16)
898 DEF_SCAV_TRANS_SIZE_UB(32)
899 DEF_SCAV_TRANS_SIZE_UB(64)
900 DEF_SCAV_TRANS_SIZE_UB(128)
901 #ifdef LONG_FLOAT_SIZE
902 DEF_SPECIALIZED_VECTOR(vector_long_float
, length
* LONG_FLOAT_SIZE
)
903 DEF_SPECIALIZED_VECTOR(vector_complex_long_float
, length
* (2 * LONG_FLOAT_SIZE
))
907 trans_weak_pointer(lispobj object
)
910 #ifndef LISP_FEATURE_GENCGC
911 struct weak_pointer
*wp
;
913 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
915 #if defined(DEBUG_WEAK)
916 printf("Transporting weak pointer from 0x%08x\n", object
);
919 /* Need to remember where all the weak pointers are that have */
920 /* been transported so they can be fixed up in a post-GC pass. */
922 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
923 #ifndef LISP_FEATURE_GENCGC
924 wp
= (struct weak_pointer
*) native_pointer(copy
);
926 gc_dcheck(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
927 /* Push the weak pointer onto the list of weak pointers. */
928 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
935 size_weak_pointer(lispobj
*where
)
937 return WEAK_POINTER_NWORDS
;
941 void scan_weak_pointers(void)
943 struct weak_pointer
*wp
, *next_wp
;
944 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
945 lispobj value
= wp
->value
;
946 lispobj
*first_pointer
;
947 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
951 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
954 if (!is_lisp_pointer(value
))
957 /* Now, we need to check whether the object has been forwarded. If
958 * it has been, the weak pointer is still good and needs to be
959 * updated. Otherwise, the weak pointer needs to be nil'ed
962 if (from_space_p(value
)) {
963 first_pointer
= native_pointer(value
);
965 if (forwarding_pointer_p(first_pointer
)) {
966 wp
->value
= LOW_WORD(forwarding_pointer_value(first_pointer
));
973 #ifdef LISP_FEATURE_IMMOBILE_SPACE
974 else if (immobile_space_p(value
) &&
975 immobile_obj_gen_bits(native_pointer(value
)) == from_space
) {
986 #if N_WORD_BITS == 32
987 #define EQ_HASH_MASK 0x1fffffff
988 #elif N_WORD_BITS == 64
989 #define EQ_HASH_MASK 0x1fffffffffffffff
992 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
993 * target-hash-table.lisp. */
994 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
996 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
997 * slot. Set to NULL at the end of a collection.
999 * This is not optimal because, when a table is tenured, it won't be
1000 * processed automatically; only the yougest generation is GC'd by
1001 * default. On the other hand, all applications will need an
1002 * occasional full GC anyway, so it's not that bad either. */
1003 struct hash_table
*weak_hash_tables
= NULL
;
1005 /* Return true if OBJ has already survived the current GC. */
1007 survived_gc_yet (lispobj obj
)
1009 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1010 /* If an immobile object's generation# is that of 'from_space', but has been
1011 visited (i.e. is live), then it is conceptually not in 'from_space'.
1012 This can happen when and only when _not_ raising the generation number.
1013 Since the gen_bits() accessor returns the visited bit, the byte value
1014 is numerically unequal to 'from_space', which is what we want */
1015 return !is_lisp_pointer(obj
)
1016 || (immobile_space_p(obj
)
1017 ? immobile_obj_gen_bits(native_pointer(obj
)) != from_space
1018 : (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
))));
1020 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1021 forwarding_pointer_p(native_pointer(obj
)));
1025 static int survived_gc_yet_KEY(lispobj key
, lispobj value
) {
1026 return survived_gc_yet(key
);
1028 static int survived_gc_yet_VALUE(lispobj key
, lispobj value
) {
1029 return survived_gc_yet(value
);
1031 static int survived_gc_yet_AND(lispobj key
, lispobj value
) {
1032 return survived_gc_yet(key
) && survived_gc_yet(value
);
1034 static int survived_gc_yet_OR(lispobj key
, lispobj value
) {
1035 return survived_gc_yet(key
) || survived_gc_yet(value
);
1038 static int (*weak_hash_entry_alivep_fun(lispobj weakness
))(lispobj
,lispobj
)
1041 case KEY
: return survived_gc_yet_KEY
;
1042 case VALUE
: return survived_gc_yet_VALUE
;
1043 case KEY_OR_VALUE
: return survived_gc_yet_OR
;
1044 case KEY_AND_VALUE
: return survived_gc_yet_AND
;
1045 case NIL
: return NULL
;
1046 default: lose("Bad hash table weakness");
1050 /* Return the beginning of data in ARRAY (skipping the header and the
1051 * length) or NULL if it isn't an array of the specified widetag after
1053 static inline lispobj
*
1054 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1056 if (is_lisp_pointer(array
) && widetag_of(*native_pointer(array
)) == widetag
) {
1058 *length
= fixnum_value(native_pointer(array
)[1]);
1059 return native_pointer(array
) + 2;
1065 /* Only need to worry about scavenging the _real_ entries in the
1066 * table. Phantom entries such as the hash table itself at index 0 and
1067 * the empty marker at index 1 were scavenged by scav_vector that
1068 * either called this function directly or arranged for it to be
1069 * called later by pushing the hash table onto weak_hash_tables. */
1071 scav_hash_table_entries (struct hash_table
*hash_table
)
1075 lispobj
*index_vector
;
1077 lispobj
*next_vector
;
1078 uword_t next_vector_length
;
1079 lispobj
*hash_vector
;
1080 uword_t hash_vector_length
;
1081 lispobj empty_symbol
;
1082 lispobj weakness
= hash_table
->weakness
;
1085 kv_vector
= get_array_data(hash_table
->table
,
1086 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1087 if (kv_vector
== NULL
)
1088 lose("invalid kv_vector %x\n", hash_table
->table
);
1090 index_vector
= get_array_data(hash_table
->index_vector
,
1091 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1092 if (index_vector
== NULL
)
1093 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1095 next_vector
= get_array_data(hash_table
->next_vector
,
1096 SIMPLE_ARRAY_WORD_WIDETAG
,
1097 &next_vector_length
);
1098 if (next_vector
== NULL
)
1099 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1101 hash_vector
= get_array_data(hash_table
->hash_vector
,
1102 SIMPLE_ARRAY_WORD_WIDETAG
,
1103 &hash_vector_length
);
1104 if (hash_vector
!= NULL
)
1105 gc_assert(hash_vector_length
== next_vector_length
);
1107 /* These lengths could be different as the index_vector can be a
1108 * different length from the others, a larger index_vector could
1109 * help reduce collisions. */
1110 gc_assert(next_vector_length
*2 == kv_length
);
1112 empty_symbol
= kv_vector
[1];
1113 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1114 if (widetag_of(*native_pointer(empty_symbol
)) != SYMBOL_HEADER_WIDETAG
) {
1115 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1116 *native_pointer(empty_symbol
));
1119 /* Work through the KV vector. */
1120 int (*alivep_test
)(lispobj
,lispobj
) = weak_hash_entry_alivep_fun(weakness
);
1121 #define SCAV_ENTRIES(aliveness_predicate) \
1122 for (i = 1; i < next_vector_length; i++) { \
1123 lispobj old_key = kv_vector[2*i]; \
1124 lispobj __attribute__((unused)) value = kv_vector[2*i+1]; \
1125 if (aliveness_predicate) { \
1126 /* Scavenge the key and value. */ \
1127 scavenge(&kv_vector[2*i], 2); \
1128 /* If an EQ-based key has moved, mark the hash-table for rehash */ \
1129 if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) { \
1130 lispobj new_key = kv_vector[2*i]; \
1131 if (old_key != new_key && new_key != empty_symbol) \
1132 hash_table->needs_rehash_p = T; \
1135 SCAV_ENTRIES(alivep_test(old_key
, value
))
1141 scav_vector (lispobj
*where
, lispobj object
)
1144 struct hash_table
*hash_table
;
1146 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1147 * hash tables in the Lisp HASH-TABLE code to indicate need for
1148 * special GC support. */
1149 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
)
1152 kv_length
= fixnum_value(where
[1]);
1153 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1155 /* Scavenge element 0, which may be a hash-table structure. */
1156 scavenge(where
+2, 1);
1157 if (!is_lisp_pointer(where
[2])) {
1158 /* This'll happen when REHASH clears the header of old-kv-vector
1159 * and fills it with zero, but some other thread simulatenously
1160 * sets the header in %%PUTHASH.
1163 "Warning: no pointer at %p in hash table: this indicates "
1164 "non-fatal corruption caused by concurrent access to a "
1165 "hash-table from multiple threads. Any accesses to "
1166 "hash-tables shared between threads should be protected "
1167 "by locks.\n", (void*)&where
[2]);
1168 // We've scavenged three words.
1171 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1172 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1173 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1174 lose("hash table not instance (%x at %x)\n",
1179 /* Scavenge element 1, which should be some internal symbol that
1180 * the hash table code reserves for marking empty slots. */
1181 scavenge(where
+3, 1);
1182 if (!is_lisp_pointer(where
[3])) {
1183 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1186 /* Scavenge hash table, which will fix the positions of the other
1187 * needed objects. */
1188 scavenge((lispobj
*)hash_table
,
1189 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1191 /* Cross-check the kv_vector. */
1192 if (where
!= native_pointer(hash_table
->table
)) {
1193 lose("hash_table table!=this table %x\n", hash_table
->table
);
1196 if (hash_table
->weakness
== NIL
) {
1197 scav_hash_table_entries(hash_table
);
1199 /* Delay scavenging of this table by pushing it onto
1200 * weak_hash_tables (if it's not there already) for the weak
1202 if (hash_table
->next_weak_hash_table
== NIL
) {
1203 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1204 weak_hash_tables
= hash_table
;
1208 return (CEILING(kv_length
+ 2, 2));
1212 scav_weak_hash_tables (void)
1214 struct hash_table
*table
;
1216 /* Scavenge entries whose triggers are known to survive. */
1217 for (table
= weak_hash_tables
; table
!= NULL
;
1218 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1219 scav_hash_table_entries(table
);
1223 /* Walk through the chain whose first element is *FIRST and remove
1224 * dead weak entries. */
1226 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1227 lispobj
*kv_vector
, lispobj
*index_vector
,
1228 lispobj
*next_vector
, lispobj
*hash_vector
,
1229 lispobj empty_symbol
, int (*alivep_test
)(lispobj
,lispobj
))
1231 unsigned index
= *prev
;
1233 unsigned next
= next_vector
[index
];
1234 lispobj key
= kv_vector
[2 * index
];
1235 lispobj value
= kv_vector
[2 * index
+ 1];
1236 gc_assert(key
!= empty_symbol
);
1237 gc_assert(value
!= empty_symbol
);
1238 if (!alivep_test(key
, value
)) {
1239 unsigned count
= fixnum_value(hash_table
->number_entries
);
1240 gc_assert(count
> 0);
1242 hash_table
->number_entries
= make_fixnum(count
- 1);
1243 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1244 hash_table
->next_free_kv
= make_fixnum(index
);
1245 kv_vector
[2 * index
] = empty_symbol
;
1246 kv_vector
[2 * index
+ 1] = empty_symbol
;
1248 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1250 prev
= &next_vector
[index
];
1257 scan_weak_hash_table (struct hash_table
*hash_table
)
1260 lispobj
*index_vector
;
1261 uword_t length
= 0; /* prevent warning */
1262 lispobj
*next_vector
;
1263 uword_t next_vector_length
= 0; /* prevent warning */
1264 lispobj
*hash_vector
;
1265 lispobj empty_symbol
;
1266 lispobj weakness
= hash_table
->weakness
;
1269 kv_vector
= get_array_data(hash_table
->table
,
1270 SIMPLE_VECTOR_WIDETAG
, NULL
);
1271 index_vector
= get_array_data(hash_table
->index_vector
,
1272 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1273 next_vector
= get_array_data(hash_table
->next_vector
,
1274 SIMPLE_ARRAY_WORD_WIDETAG
,
1275 &next_vector_length
);
1276 hash_vector
= get_array_data(hash_table
->hash_vector
,
1277 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1278 empty_symbol
= kv_vector
[1];
1280 for (i
= 0; i
< length
; i
++) {
1281 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
1282 kv_vector
, index_vector
, next_vector
,
1283 hash_vector
, empty_symbol
,
1284 weak_hash_entry_alivep_fun(weakness
));
1288 /* Remove dead entries from weak hash tables. */
1290 scan_weak_hash_tables (void)
1292 struct hash_table
*table
, *next
;
1294 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1295 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1296 table
->next_weak_hash_table
= NIL
;
1297 scan_weak_hash_table(table
);
1300 weak_hash_tables
= NULL
;
1309 scav_lose(lispobj
*where
, lispobj object
)
1311 lose("no scavenge function for object %p (widetag 0x%x)\n",
1313 widetag_of(*where
));
1315 return 0; /* bogus return value to satisfy static type checking */
1319 trans_lose(lispobj object
)
1321 lose("no transport function for object %p (widetag 0x%x)\n",
1323 widetag_of(*native_pointer(object
)));
1324 return NIL
; /* bogus return value to satisfy static type checking */
1328 size_lose(lispobj
*where
)
1330 lose("no size function for object at %p (widetag 0x%x)\n",
1332 widetag_of(*where
));
1333 return 1; /* bogus return value to satisfy static type checking */
1341 #include "genesis/gc-tables.h"
1344 static lispobj
*search_spaces(void *pointer
)
1347 if (((start
= search_dynamic_space(pointer
)) != NULL
) ||
1348 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1349 ((start
= search_immobile_space(pointer
)) != NULL
) ||
1351 ((start
= search_static_space(pointer
)) != NULL
) ||
1352 ((start
= search_read_only_space(pointer
)) != NULL
))
1357 /* Find the code object for the given pc, or return NULL on
1360 component_ptr_from_pc(lispobj
*pc
)
1362 lispobj
*object
= search_spaces(pc
);
1364 if (object
!= NULL
&& widetag_of(*object
) == CODE_HEADER_WIDETAG
)
1370 /* Scan an area looking for an object which encloses the given pointer.
1371 * Return the object start on success, or NULL on failure. */
1373 gc_search_space3(void *pointer
, lispobj
*start
, void *limit
)
1375 if (pointer
< (void*)start
|| pointer
>= limit
) return NULL
;
1379 /* CAUTION: this code is _significantly_ slower than the production version
1380 due to the extra checks for forwarding. Only use it if debugging */
1381 for ( ; (void*)start
< limit
; start
+= count
) {
1382 lispobj
*forwarded_start
;
1383 if (forwarding_pointer_p(start
))
1384 forwarded_start
= native_pointer(forwarding_pointer_value(start
));
1386 forwarded_start
= start
;
1387 lispobj thing
= *forwarded_start
;
1388 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](forwarded_start
);
1389 /* Check whether the pointer is within this object. */
1390 if (pointer
< (void*)(start
+count
)) return start
;
1393 for ( ; (void*)start
< limit
; start
+= count
) {
1394 lispobj thing
= *start
;
1395 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](start
);
1396 /* Check whether the pointer is within this object. */
1397 if (pointer
< (void*)(start
+count
)) return start
;
1403 /* Helper for valid_lisp_pointer_p (below) and
1404 * conservative_root_p (gencgc).
1406 * pointer is the pointer to check validity of,
1407 * and start_addr is the address of the enclosing object.
1410 properly_tagged_descriptor_p(void *thing
, lispobj
*start_addr
)
1412 lispobj pointer
= (lispobj
)thing
;
1413 if (!is_lisp_pointer(pointer
)) {
1417 /* Check that the object pointed to is consistent with the pointer
1419 switch (lowtag_of(pointer
)) {
1420 case FUN_POINTER_LOWTAG
:
1421 /* Start_addr should be the enclosing code object, or a closure
1423 switch (widetag_of(*start_addr
)) {
1424 case CODE_HEADER_WIDETAG
:
1425 /* Make sure we actually point to a function in the code object,
1426 * as opposed to a random point there. */
1427 for_each_simple_fun(i
, function
, (struct code
*)start_addr
, 0, {
1428 if ((lispobj
)function
== pointer
-FUN_POINTER_LOWTAG
) return 1;
1431 case CLOSURE_HEADER_WIDETAG
:
1432 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
1433 return make_lispobj(start_addr
, FUN_POINTER_LOWTAG
) == pointer
;
1438 case LIST_POINTER_LOWTAG
:
1439 return make_lispobj(start_addr
, LIST_POINTER_LOWTAG
) == pointer
1440 && is_cons_half(start_addr
[0]) // Is it plausible?
1441 && is_cons_half(start_addr
[1]);
1443 case INSTANCE_POINTER_LOWTAG
:
1444 return make_lispobj(start_addr
, INSTANCE_POINTER_LOWTAG
) == pointer
1445 && widetag_of(*start_addr
) == INSTANCE_HEADER_WIDETAG
;
1447 case OTHER_POINTER_LOWTAG
:
1449 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1450 /* The all-architecture test below is good as far as it goes,
1451 * but an LRA object is similar to a FUN-POINTER: It is
1452 * embedded within a CODE-OBJECT pointed to by start_addr, and
1453 * cannot be found by simply walking the heap, therefore we
1454 * need to check for it. -- AB, 2010-Jun-04 */
1455 if ((widetag_of(start_addr
[0]) == CODE_HEADER_WIDETAG
)) {
1456 lispobj
*potential_lra
= native_pointer(pointer
);
1457 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
1458 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
1459 return 1; /* It's as good as we can verify. */
1464 if (pointer
!= make_lispobj(start_addr
, OTHER_POINTER_LOWTAG
)
1465 || !other_immediate_lowtag_p(*start_addr
))
1468 switch (widetag_of(start_addr
[0])) {
1469 case UNBOUND_MARKER_WIDETAG
:
1470 case NO_TLS_VALUE_MARKER_WIDETAG
:
1471 case CHARACTER_WIDETAG
:
1472 #if N_WORD_BITS == 64
1473 case SINGLE_FLOAT_WIDETAG
:
1477 /* only pointed to by function pointers? */
1478 case CLOSURE_HEADER_WIDETAG
:
1479 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
1482 case INSTANCE_HEADER_WIDETAG
:
1485 /* the valid other immediate pointer objects */
1486 case SIMPLE_VECTOR_WIDETAG
:
1488 case COMPLEX_WIDETAG
:
1489 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1490 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
1492 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1493 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
1495 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1496 case COMPLEX_LONG_FLOAT_WIDETAG
:
1498 #ifdef SIMD_PACK_WIDETAG
1499 case SIMD_PACK_WIDETAG
:
1501 case SIMPLE_ARRAY_WIDETAG
:
1502 case COMPLEX_BASE_STRING_WIDETAG
:
1503 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1504 case COMPLEX_CHARACTER_STRING_WIDETAG
:
1506 case COMPLEX_VECTOR_NIL_WIDETAG
:
1507 case COMPLEX_BIT_VECTOR_WIDETAG
:
1508 case COMPLEX_VECTOR_WIDETAG
:
1509 case COMPLEX_ARRAY_WIDETAG
:
1510 case VALUE_CELL_HEADER_WIDETAG
:
1511 case SYMBOL_HEADER_WIDETAG
:
1513 case CODE_HEADER_WIDETAG
:
1514 case BIGNUM_WIDETAG
:
1515 #if N_WORD_BITS != 64
1516 case SINGLE_FLOAT_WIDETAG
:
1518 case DOUBLE_FLOAT_WIDETAG
:
1519 #ifdef LONG_FLOAT_WIDETAG
1520 case LONG_FLOAT_WIDETAG
:
1522 #include "genesis/specialized-vectors.inc"
1524 case WEAK_POINTER_WIDETAG
:
1539 /* META: Note the ambiguous word "validate" in the comment below.
1540 * This means "Decide whether <x> is valid".
1541 * But when you see os_validate() elsewhere, that doesn't mean to ask
1542 * whether something is valid, it says to *make* it valid.
1543 * I think it would be nice if we could avoid using the word in the
1544 * sense in which os_validate() uses it, which would entail renaming
1545 * a bunch of stuff, which is harder than just explaining why
1546 * the comments can be deceptive */
1548 /* Used by the debugger to validate possibly bogus pointers before
1549 * calling MAKE-LISP-OBJ on them.
1551 * FIXME: We would like to make this perfect, because if the debugger
1552 * constructs a reference to a bugs lisp object, and it ends up in a
1553 * location scavenged by the GC all hell breaks loose.
1555 * Whereas conservative_root_p has to be conservative
1556 * and return true for all valid pointers, this could actually be eager
1557 * and lie about a few pointers without bad results... but that should
1558 * be reflected in the name.
1561 valid_lisp_pointer_p(lispobj pointer
)
1563 lispobj
*start
= search_spaces((void*)pointer
);
1565 return properly_tagged_descriptor_p((void*)pointer
, start
);
1570 maybe_gc(os_context_t
*context
)
1572 lispobj gc_happened
;
1573 struct thread
*thread
= arch_os_get_current_thread();
1574 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
1577 fake_foreign_function_call(context
);
1580 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
1581 * which case we will be running with no gc trigger barrier
1582 * thing for a while. But it shouldn't be long until the end
1585 * FIXME: It would be good to protect the end of dynamic space for
1586 * CheneyGC and signal a storage condition from there.
1589 /* Restore the signal mask from the interrupted context before
1590 * calling into Lisp if interrupts are enabled. Why not always?
1592 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
1593 * interrupt hits while in SUB-GC, it is deferred and the
1594 * os_context_sigmask of that interrupt is set to block further
1595 * deferrable interrupts (until the first one is
1596 * handled). Unfortunately, that context refers to this place and
1597 * when we return from here the signals will not be blocked.
1599 * A kludgy alternative is to propagate the sigmask change to the
1602 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
1603 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
1604 unblock_gc_signals(0, 0);
1606 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
1607 /* FIXME: Nothing must go wrong during GC else we end up running
1608 * the debugger, error handlers, and user code in general in a
1609 * potentially unsafe place. Running out of the control stack or
1610 * the heap in SUB-GC are ways to lose. Of course, deferrables
1611 * cannot be unblocked because there may be a pending handler, or
1612 * we may even be in a WITHOUT-INTERRUPTS. */
1613 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
1614 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
1615 (gc_happened
== NIL
)
1617 : ((gc_happened
== T
)
1620 /* gc_happened can take three values: T, NIL, 0.
1622 * T means that the thread managed to trigger a GC, and post-gc
1625 * NIL means that the thread is within without-gcing, and no GC
1628 * Finally, 0 means that *a* GC has occurred, but it wasn't
1629 * triggered by this thread; success, but post-gc doesn't have
1632 if ((gc_happened
== T
) &&
1633 /* See if interrupts are enabled or it's possible to enable
1634 * them. POST-GC has a similar check, but we don't want to
1635 * unlock deferrables in that case and get a pending interrupt
1637 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
1638 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
1639 #ifndef LISP_FEATURE_WIN32
1640 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
1641 if (!deferrables_blocked_p(context_sigmask
)) {
1642 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
1643 #ifndef LISP_FEATURE_SB_SAFEPOINT
1644 check_gc_signals_unblocked_or_lose(0);
1647 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
1648 funcall0(StaticSymbolFunction(POST_GC
));
1649 #ifndef LISP_FEATURE_WIN32
1651 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
1657 undo_fake_foreign_function_call(context
);
1659 /* Otherwise done by undo_fake_foreign_function_call. And
1660 something later wants them to be blocked. What a nice
1662 block_blockable_signals(0);
1665 FSHOW((stderr
, "/maybe_gc: returning\n"));
1666 return (gc_happened
!= NIL
);
1669 #define BYTES_ZERO_BEFORE_END (1<<12)
1671 /* There used to be a similar function called SCRUB-CONTROL-STACK in
1672 * Lisp and another called zero_stack() in cheneygc.c, but since it's
1673 * shorter to express in, and more often called from C, I keep only
1674 * the C one after fixing it. -- MG 2009-03-25 */
1676 /* Zero the unused portion of the control stack so that old objects
1677 * are not kept alive because of uninitialized stack variables.
1679 * "To summarize the problem, since not all allocated stack frame
1680 * slots are guaranteed to be written by the time you call an another
1681 * function or GC, there may be garbage pointers retained in your dead
1682 * stack locations. The stack scrubbing only affects the part of the
1683 * stack from the SP to the end of the allocated stack." - ram, on
1684 * cmucl-imp, Tue, 25 Sep 2001
1686 * So, as an (admittedly lame) workaround, from time to time we call
1687 * scrub-control-stack to zero out all the unused portion. This is
1688 * supposed to happen when the stack is mostly empty, so that we have
1689 * a chance of clearing more of it: callers are currently (2002.07.18)
1690 * REPL, SUB-GC and sig_stop_for_gc_handler. */
1692 /* Take care not to tread on the guard page and the hard guard page as
1693 * it would be unkind to sig_stop_for_gc_handler. Touching the return
1694 * guard page is not dangerous. For this to work the guard page must
1695 * be zeroed when protected. */
1697 /* FIXME: I think there is no guarantee that once
1698 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
1699 * may be what the "lame" adjective in the above comment is for. In
1700 * this case, exact gc may lose badly. */
1702 scrub_control_stack()
1704 scrub_thread_control_stack(arch_os_get_current_thread());
1708 scrub_thread_control_stack(struct thread
*th
)
1710 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
1711 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
1712 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1713 /* On these targets scrubbing from C is a bad idea, so we punt to
1714 * a routine in $ARCH-assem.S. */
1715 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
1716 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
1718 lispobj
*sp
= access_control_stack_pointer(th
);
1720 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
1721 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
1722 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
1723 ((os_vm_address_t
)sp
>= guard_page_address
) &&
1724 (th
->control_stack_guard_page_protected
!= NIL
)))
1726 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
1729 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1730 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
1735 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1739 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1740 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
1745 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1747 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
1750 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1753 scavenge_control_stack(struct thread
*th
)
1755 lispobj
*object_ptr
;
1757 /* In order to properly support dynamic-extent allocation of
1758 * non-CONS objects, the control stack requires special handling.
1759 * Rather than calling scavenge() directly, grovel over it fixing
1760 * broken hearts, scavenging pointers to oldspace, and pitching a
1761 * fit when encountering unboxed data. This prevents stray object
1762 * headers from causing the scavenger to blow past the end of the
1763 * stack (an error case checked in scavenge()). We don't worry
1764 * about treating unboxed words as boxed or vice versa, because
1765 * the compiler isn't allowed to store unboxed objects on the
1766 * control stack. -- AB, 2011-Dec-02 */
1768 for (object_ptr
= th
->control_stack_start
;
1769 object_ptr
< access_control_stack_pointer(th
);
1772 lispobj object
= *object_ptr
;
1773 #ifdef LISP_FEATURE_GENCGC
1774 if (forwarding_pointer_p(object_ptr
))
1775 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
1776 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
1778 if (is_lisp_pointer(object
) && from_space_p(object
)) {
1779 /* It currently points to old space. Check for a
1780 * forwarding pointer. */
1781 lispobj
*ptr
= native_pointer(object
);
1782 if (forwarding_pointer_p(ptr
)) {
1783 /* Yes, there's a forwarding pointer. */
1784 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
1786 /* Scavenge that pointer. */
1787 long n_words_scavenged
=
1788 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
1789 gc_assert(n_words_scavenged
== 1);
1791 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
1792 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
1793 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
1798 /* Scavenging Interrupt Contexts */
1800 static int boxed_registers
[] = BOXED_REGISTERS
;
1802 /* The GC has a notion of an "interior pointer" register, an unboxed
1803 * register that typically contains a pointer to inside an object
1804 * referenced by another pointer. The most obvious of these is the
1805 * program counter, although many compiler backends define a "Lisp
1806 * Interior Pointer" register known to the runtime as reg_LIP, and
1807 * various CPU architectures have other registers that also partake of
1808 * the interior-pointer nature. As the code for pairing an interior
1809 * pointer value up with its "base" register, and fixing it up after
1810 * scavenging is complete is horribly repetitive, a few macros paper
1811 * over the monotony. --AB, 2010-Jul-14 */
1813 /* These macros are only ever used over a lexical environment which
1814 * defines a pointer to an os_context_t called context, thus we don't
1815 * bother to pass that context in as a parameter. */
1817 /* Define how to access a given interior pointer. */
1818 #define ACCESS_INTERIOR_POINTER_pc \
1819 *os_context_pc_addr(context)
1820 #define ACCESS_INTERIOR_POINTER_lip \
1821 *os_context_register_addr(context, reg_LIP)
1822 #define ACCESS_INTERIOR_POINTER_lr \
1823 *os_context_lr_addr(context)
1824 #define ACCESS_INTERIOR_POINTER_npc \
1825 *os_context_npc_addr(context)
1826 #define ACCESS_INTERIOR_POINTER_ctr \
1827 *os_context_ctr_addr(context)
1829 #define INTERIOR_POINTER_VARS(name) \
1830 uword_t name##_offset; \
1831 int name##_register_pair
1833 #define PAIR_INTERIOR_POINTER(name) \
1834 pair_interior_pointer(context, \
1835 ACCESS_INTERIOR_POINTER_##name, \
1837 &name##_register_pair)
1839 /* One complexity here is that if a paired register is not found for
1840 * an interior pointer, then that pointer does not get updated.
1841 * Originally, there was some commentary about using an index of -1
1842 * when calling os_context_register_addr() on SPARC referring to the
1843 * program counter, but the real reason is to allow an interior
1844 * pointer register to point to the runtime, read-only space, or
1845 * static space without problems. */
1846 #define FIXUP_INTERIOR_POINTER(name) \
1848 if (name##_register_pair >= 0) { \
1849 ACCESS_INTERIOR_POINTER_##name = \
1850 (*os_context_register_addr(context, \
1851 name##_register_pair) \
1859 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
1860 uword_t
*saved_offset
, int *register_pair
)
1865 * I (RLT) think this is trying to find the boxed register that is
1866 * closest to the LIP address, without going past it. Usually, it's
1867 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
1869 /* 0x7FFFFFFF on 32-bit platforms;
1870 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
1871 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
1872 *register_pair
= -1;
1873 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1878 index
= boxed_registers
[i
];
1879 reg
= *os_context_register_addr(context
, index
);
1881 /* An interior pointer is never relative to a non-pointer
1882 * register (an oversight in the original implementation).
1883 * The simplest argument for why this is true is to consider
1884 * the fixnum that happens by coincide to be the word-index in
1885 * memory of the header for some object plus two. This is
1886 * happenstance would cause the register containing the fixnum
1887 * to be selected as the register_pair if the interior pointer
1888 * is to anywhere after the first two words of the object.
1889 * The fixnum won't be changed during GC, but the object might
1890 * move, thus destroying the interior pointer. --AB,
1893 if (is_lisp_pointer(reg
) &&
1894 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
1895 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
1896 if (offset
< *saved_offset
) {
1897 *saved_offset
= offset
;
1898 *register_pair
= index
;
1905 scavenge_interrupt_context(os_context_t
* context
)
1909 /* FIXME: The various #ifdef noise here is precisely that: noise.
1910 * Is it possible to fold it into the macrology so that we have
1911 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
1912 * compile out for the registers that don't exist on a given
1915 INTERIOR_POINTER_VARS(pc
);
1917 INTERIOR_POINTER_VARS(lip
);
1919 #ifdef ARCH_HAS_LINK_REGISTER
1920 INTERIOR_POINTER_VARS(lr
);
1922 #ifdef ARCH_HAS_NPC_REGISTER
1923 INTERIOR_POINTER_VARS(npc
);
1925 #ifdef LISP_FEATURE_PPC
1926 INTERIOR_POINTER_VARS(ctr
);
1929 PAIR_INTERIOR_POINTER(pc
);
1931 PAIR_INTERIOR_POINTER(lip
);
1933 #ifdef ARCH_HAS_LINK_REGISTER
1934 PAIR_INTERIOR_POINTER(lr
);
1936 #ifdef ARCH_HAS_NPC_REGISTER
1937 PAIR_INTERIOR_POINTER(npc
);
1939 #ifdef LISP_FEATURE_PPC
1940 PAIR_INTERIOR_POINTER(ctr
);
1943 /* Scavenge all boxed registers in the context. */
1944 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1948 index
= boxed_registers
[i
];
1949 foo
= *os_context_register_addr(context
, index
);
1951 *os_context_register_addr(context
, index
) = foo
;
1953 /* this is unlikely to work as intended on bigendian
1954 * 64 bit platforms */
1956 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
1959 /* Now that the scavenging is done, repair the various interior
1961 FIXUP_INTERIOR_POINTER(pc
);
1963 FIXUP_INTERIOR_POINTER(lip
);
1965 #ifdef ARCH_HAS_LINK_REGISTER
1966 FIXUP_INTERIOR_POINTER(lr
);
1968 #ifdef ARCH_HAS_NPC_REGISTER
1969 FIXUP_INTERIOR_POINTER(npc
);
1971 #ifdef LISP_FEATURE_PPC
1972 FIXUP_INTERIOR_POINTER(ctr
);
1977 scavenge_interrupt_contexts(struct thread
*th
)
1980 os_context_t
*context
;
1982 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
1984 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
1985 printf("Number of active contexts: %d\n", index
);
1988 for (i
= 0; i
< index
; i
++) {
1989 context
= th
->interrupt_contexts
[i
];
1990 scavenge_interrupt_context(context
);
1993 #endif /* x86oid targets */
1995 void varint_unpacker_init(struct varint_unpacker
* unpacker
, lispobj integer
)
1997 if (fixnump(integer
)) {
1998 unpacker
->word
= fixnum_value(integer
);
1999 unpacker
->limit
= N_WORD_BYTES
;
2000 unpacker
->data
= (char*)&unpacker
->word
;
2002 struct bignum
* bignum
= (struct bignum
*)(integer
- OTHER_POINTER_LOWTAG
);
2004 unpacker
->limit
= HeaderValue(bignum
->header
) * N_WORD_BYTES
;
2005 unpacker
->data
= (char*)bignum
->digits
;
2007 unpacker
->index
= 0;
2010 // Fetch the next varint from 'unpacker' into 'result'.
2011 // Because there is no length prefix on the number of varints encoded,
2012 // spurious trailing zeros might be observed. The data consumer can
2013 // circumvent that by storing a count as the first value in the series.
2014 // Return 1 for success, 0 for EOF.
2015 int varint_unpack(struct varint_unpacker
* unpacker
, int* result
)
2017 if (unpacker
->index
>= unpacker
->limit
) return 0;
2018 int accumulator
= 0;
2021 #ifdef LISP_FEATURE_LITTLE_ENDIAN
2022 int byte
= unpacker
->data
[unpacker
->index
];
2024 // bignums are little-endian in word order,
2025 // but machine-native within each word.
2026 // We could pack bytes MSB-to-LSB in the bigdigits,
2027 // but that seems less intuitive on the Lisp side.
2028 int word_index
= unpacker
->index
/ N_WORD_BYTES
;
2029 int byte_index
= unpacker
->index
% N_WORD_BYTES
;
2030 int byte
= (((unsigned int*)unpacker
->data
)[word_index
]
2031 >> (byte_index
* 8)) & 0xFF;
2034 accumulator
|= (byte
& 0x7F) << shift
;
2035 if (!(byte
& 0x80)) break;
2036 gc_assert(unpacker
->index
< unpacker
->limit
);
2039 *result
= accumulator
;