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>.
36 #include "interrupt.h"
41 #include "hopscotch.h"
42 #include "genesis/primitive-objects.h"
43 #include "genesis/static-symbols.h"
44 #include "genesis/layout.h"
45 #include "genesis/hash-table.h"
46 #define WANT_SCAV_TRANS_SIZE_TABLES
47 #include "gc-internal.h"
48 #include "gc-private.h"
49 #include "forwarding-ptr.h"
52 #ifdef LISP_FEATURE_SPARC
53 #define LONG_FLOAT_SIZE 4
54 #elif defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
55 #define LONG_FLOAT_SIZE 3
58 os_vm_size_t dynamic_space_size
= DEFAULT_DYNAMIC_SPACE_SIZE
;
59 os_vm_size_t thread_control_stack_size
= DEFAULT_CONTROL_STACK_SIZE
;
61 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
62 static lispobj (*transother
[64])(lispobj object
);
63 sword_t (*sizetab
[256])(lispobj
*where
);
64 struct weak_pointer
*weak_pointers
;
66 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
68 /// These sizing macros return the number of *payload* words,
69 /// exclusive of the object header word. Payload length is always
70 /// an odd number so that total word count is an even number.
72 /* Each size category is designed to allow 1 bit for a GC mark bit,
73 * possibly some flag bits, and the payload length in words.
74 * There are three size categories for most non-vector objects,
75 * differing in how many flag bits versus size bits there are.
76 * The GC mark bit is always in bit index 31 of the header regardless of
77 * machine word size. Bit index 31 is chosen for consistency between 32-bit
78 * and 64-bit machines. It is a natural choice for 32-bit headers by avoiding
79 * intererence with other header fields. It is also chosen for 64-bit headers
80 * because the upper 32 bits of headers for some objects are already occupied
81 * by other data: symbol TLS index, instance layout, etc.
84 /* The largest payload count is expressed in 23 bits. These objects
85 * can't reside in immobile space as there is no room for generation bits.
86 * All sorts of objects fall into this category, but mostly due to inertia.
87 * There are no non-vector boxed objects whose size should be so large.
92 #define BOXED_NWORDS(obj) ((HeaderValue(obj) & 0x7FFFFF) | 1)
94 /* Medium-sized payload count is expressed in 15 bits. Objects in this category
95 * may reside in immobile space: CODE, CLOSURE, INSTANCE, FUNCALLABLE-INSTANCE.
96 * The single data bit is used as a closure's NAMED flag.
98 * Header: gen# | data | size | tag
99 * ----- ----- ------- ------
100 * 8 bits | 1 bit | 15 bits | 8 bits
102 #define SHORT_BOXED_NWORDS(obj) ((HeaderValue(obj) & SHORT_HEADER_MAX_WORDS) | 1)
104 /* Tiny payload count is expressed in 8 bits. Objects in this size category
105 * can reside in immobile space: SYMBOL, FDEFN.
106 * Header: gen# | flags | size | tag
107 * ----- ------ ------ ------
108 * 8 bits 8 bits 8 bits | 8 bits
109 * FDEFN flag bits: 1 bit for statically-linked
110 * SYMBOL flag bits: 1 bit for present in initial core image
112 #define TINY_BOXED_NWORDS(obj) ((HeaderValue(obj) & 0xFF) | 1)
118 /* gc_general_copy_object is inline from gc-internal.h */
120 /* to copy a boxed object */
122 copy_object(lispobj object
, sword_t nwords
)
124 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
127 static void (*scav_ptr
[4])(lispobj
*where
, lispobj object
); /* forward decl */
129 static inline void scav1(lispobj
* object_ptr
, lispobj object
)
132 // * With 32-bit words, is_lisp_pointer(object) returns true if object_ptr
133 // points to a forwarding pointer, so we need a sanity check inside the
134 // branch for is_lisp_pointer(). For maximum efficiency, check that only
135 // after from_space_p() returns false, so that valid pointers into
136 // from_space incur no extra test. This could be improved further by
137 // skipping the FP check if 'object' points within dynamic space, i.e.,
138 // when find_page_index() returns >= 0. That would entail injecting
139 // from_space_p() explicitly into the loop, so as to separate the
140 // "was a page found at all" condition from the page generation test.
142 // * With 64-bit words, is_lisp_pointer(object) is false when object_ptr
143 // points to a forwarding pointer, and the fixnump() test also returns
144 // false, so we'll indirect through scavtab[]. This will safely invoke
145 // scav_lose(), detecting corruption without any extra cost.
146 // The major difference between that and the explicit test is that you
147 // won't see 'start' and 'n_words', but if you need those, chances are
148 // you'll want to run under an external debugger in the first place.
149 // [And btw it sure would be nice to assert statically
150 // that is_lisp_pointer(0x01) is indeed false]
152 #define FIX_POINTER() { \
153 lispobj *ptr = native_pointer(object); \
154 if (forwarding_pointer_p(ptr)) \
155 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); \
156 else /* Scavenge that pointer. */ \
157 scav_ptr[(object>>(N_LOWTAG_BITS-2))&3](object_ptr, object); \
159 #ifdef LISP_FEATURE_IMMOBILE_SPACE
161 // It would be fine, though suboptimal, to use from_space_p() here.
162 // If it returns false, we don't want to call immobile_space_p()
163 // unless the pointer is *not* into dynamic space.
164 if ((page
= find_page_index((void*)object
)) >= 0) {
165 if (page_table
[page
].gen
== from_space
&& !pinned_p(object
, page
))
167 } else if (immobile_space_p(object
)) {
168 lispobj
*ptr
= native_pointer(object
);
169 if (immobile_obj_gen_bits(ptr
) == from_space
)
170 enliven_immobile_obj(ptr
, 1);
173 if (from_space_p(object
)) {
176 #if (N_WORD_BITS == 32) && defined(LISP_FEATURE_GENCGC)
177 if (forwarding_pointer_p(object_ptr
))
178 lose("unexpected forwarding pointer in scavenge @ %p\n",
181 /* It points somewhere other than oldspace. Leave it
187 inline void gc_scav_pair(lispobj where
[2])
189 lispobj object
= where
[0];
190 if (is_lisp_pointer(object
))
191 scav1(where
, object
);
193 if (is_lisp_pointer(object
))
194 scav1(where
+1, object
);
197 // Scavenge a block of memory from 'start' to 'end'
198 // that may contain object headers.
199 void heap_scavenge(lispobj
*start
, lispobj
*end
)
203 for (object_ptr
= start
; object_ptr
< end
;) {
204 lispobj object
= *object_ptr
;
205 if (other_immediate_lowtag_p(object
))
206 /* It's some sort of header object or another. */
207 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
208 else { // it's a cons
209 gc_scav_pair(object_ptr
);
213 // This assertion is usually the one that fails when something
214 // is subtly wrong with the heap, so definitely always do it.
215 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
216 object_ptr
, start
, end
);
219 // Scavenge a block of memory from 'start' extending for 'n_words'
220 // that must not contain any object headers.
221 sword_t
scavenge(lispobj
*start
, sword_t n_words
)
223 gc_dcheck(compacting_p());
224 lispobj
*end
= start
+ n_words
;
226 for (object_ptr
= start
; object_ptr
< end
; object_ptr
++) {
227 lispobj object
= *object_ptr
;
228 if (is_lisp_pointer(object
)) scav1(object_ptr
, object
);
233 /* If 'fun' is provided, then call it on each livened object,
234 * otherwise use scav1() */
235 void scav_binding_stack(lispobj
* where
, lispobj
* end
, void (*fun
)(lispobj
))
237 /* The binding stack consists of pairs of words, each holding a value and
238 * either a TLS index (if threads), or symbol (if no threads).
239 * Here we scavenge only the entries' values.
241 * Were the TLS index scavenged, it can never cause a symbol to move,
242 * let alone be considered live. So we are bug-for-bug compatible regardless
243 * of +/- sb-thread if a symbol would otherwise be garbage at this point.
244 * As a practical matter, it is technically impossible for a symbol's only
245 * reason for livenesss to be the binding stack. Nonetheless it is best to
246 * enforce behavioral consistency whether or not the platform has threads.
248 * Bindings of compile-time known symbols is fairly easy to reason about.
249 * Code headers point to symbols, therefore code objects retains symbols.
250 * The edge case of a PROGV binding of a freshly made symbol (via MAKE-SYMBOL)
251 * is interesting. Indeed we preserve the symbol because PROGV places a reference
252 * on the control stack, thereby either pinning or scavenging as the case may be.
253 * If it did not, we would need a map from TLS index to symbol, updated if
254 * a symbol moves, allowing death of a symbol only when no binding entry
255 * mentions that index. Such complication is unnecessary at present.
257 struct binding
* binding
= (struct binding
*)where
;
258 if (fun
) { // call the specified function
259 for ( ; (lispobj
*)binding
< end
; ++binding
)
260 if (is_lisp_pointer(binding
->value
))
263 } else { // call scav1
264 for ( ; (lispobj
*)binding
< end
; ++binding
)
265 if (is_lisp_pointer(binding
->value
))
266 scav1(&binding
->value
, binding
->value
);
269 void scan_binding_stack()
271 #ifndef LISP_FEATURE_SB_THREAD
273 for_each_thread(th
) { /* 'all' is exactly one */
274 struct binding
*binding
= (struct binding
*)th
->binding_stack_start
;
275 lispobj
*end
= (lispobj
*)get_binding_stack_pointer(th
);
276 for ( ; (lispobj
*)binding
< end
; ++binding
) {
277 if (is_lisp_pointer(binding
->symbol
) &&
278 forwarding_pointer_p(native_pointer(binding
->symbol
)))
280 forwarding_pointer_value(native_pointer(binding
->symbol
));
286 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
287 static lispobj
trans_short_boxed(lispobj object
);
290 scav_fun_pointer(lispobj
*where
, lispobj object
)
292 gc_dcheck(functionp(object
));
294 /* Object is a pointer into from_space - not a FP. */
295 lispobj
*first_pointer
= native_pointer(object
);
297 /* must transport object -- object may point to either a function
298 * header, a funcallable instance header, or a closure header. */
299 lispobj copy
= widetag_of(*first_pointer
) == SIMPLE_FUN_WIDETAG
300 ? trans_fun_header(object
) : trans_short_boxed(object
);
302 if (copy
!= object
) {
303 /* Set forwarding pointer */
304 set_forwarding_pointer(first_pointer
,copy
);
307 CHECK_COPY_POSTCONDITIONS(copy
, FUN_POINTER_LOWTAG
);
316 trans_code(struct code
*code
)
318 /* if object has already been transported, just return pointer */
319 if (forwarding_pointer_p((lispobj
*)code
)) {
320 return (struct code
*)native_pointer(forwarding_pointer_value((lispobj
*)code
));
323 gc_dcheck(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
325 /* prepare to transport the code vector */
326 lispobj l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
327 sword_t nheader_words
= code_header_words(code
->header
);
328 sword_t ncode_words
= code_instruction_words(code
->code_size
);
329 lispobj l_new_code
= copy_large_object(l_code
, nheader_words
+ ncode_words
,
332 #ifdef LISP_FEATURE_GENCGC
333 if (l_new_code
== l_code
)
337 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
339 /* set forwarding pointers for all the function headers in the */
340 /* code object. also fix all self pointers */
341 /* Do this by scanning the new code, since the old header is unusable */
343 uword_t displacement
= l_new_code
- l_code
;
344 struct code
*new_code
= (struct code
*) native_pointer(l_new_code
);
346 for_each_simple_fun(i
, nfheaderp
, new_code
, 1, {
347 /* Calculate the old raw function pointer */
348 struct simple_fun
* fheaderp
=
349 (struct simple_fun
*)LOW_WORD((char*)nfheaderp
- displacement
);
350 /* Calculate the new lispobj */
351 lispobj nfheaderl
= make_lispobj(nfheaderp
, FUN_POINTER_LOWTAG
);
353 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
355 /* fix self pointer. */
357 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
358 FUN_RAW_ADDR_OFFSET
+
362 #ifdef LISP_FEATURE_GENCGC
363 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
364 spaces once when all copying is done. */
365 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
366 ncode_words
* sizeof(sword_t
));
370 gencgc_apply_code_fixups(code
, new_code
);
376 scav_code_header(lispobj
*where
, lispobj header
)
378 struct code
*code
= (struct code
*) where
;
379 sword_t n_header_words
= code_header_words(header
);
381 /* Scavenge the boxed section of the code data block. */
382 scavenge(where
+ 1, n_header_words
- 1);
384 /* Scavenge the boxed section of each function object in the
385 * code data block. */
386 for_each_simple_fun(i
, function_ptr
, code
, 1, {
387 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
388 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
391 return n_header_words
+ code_instruction_words(code
->code_size
);
395 trans_code_header(lispobj object
)
397 struct code
*ncode
= trans_code((struct code
*) native_pointer(object
));
398 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
402 size_code_header(lispobj
*where
)
404 return code_header_words(((struct code
*)where
)->header
)
405 + code_instruction_words(((struct code
*)where
)->code_size
);
408 #ifdef RETURN_PC_WIDETAG
410 scav_return_pc_header(lispobj
*where
, lispobj object
)
412 lose("attempted to scavenge a return PC header where=%p object=%#lx\n",
413 where
, (uword_t
) object
);
414 return 0; /* bogus return value to satisfy static type checking */
418 trans_return_pc_header(lispobj object
)
420 struct simple_fun
*return_pc
= (struct simple_fun
*) native_pointer(object
);
421 uword_t offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
423 /* Transport the whole code object */
424 struct code
*code
= (struct code
*) ((uword_t
) return_pc
- offset
);
425 struct code
*ncode
= trans_code(code
);
427 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
429 #endif /* RETURN_PC_WIDETAG */
431 /* On the 386, closures hold a pointer to the raw address instead of the
432 * function object, so we can use CALL [$FDEFN+const] to invoke
433 * the function without loading it into a register. Given that code
434 * objects don't move, we don't need to update anything, but we do
435 * have to figure out that the function is still live. */
437 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
439 scav_closure(lispobj
*where
, lispobj header
)
441 struct closure
*closure
= (struct closure
*)where
;
442 int payload_words
= SHORT_BOXED_NWORDS(header
);
443 lispobj fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
445 #ifdef LISP_FEATURE_GENCGC
446 /* The function may have moved so update the raw address. But
447 * don't write unnecessarily. */
448 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
449 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
451 // Payload includes 'fun' which was just looked at, so subtract it.
452 scavenge(closure
->info
, payload_words
- 1);
453 return 1 + payload_words
;
457 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
459 scav_fun_header(lispobj
*where
, lispobj object
)
461 lose("attempted to scavenge a function header where=%p object=%#lx\n",
462 where
, (uword_t
) object
);
463 return 0; /* bogus return value to satisfy static type checking */
465 #endif /* LISP_FEATURE_X86 */
468 trans_fun_header(lispobj object
)
470 struct simple_fun
*fheader
= (struct simple_fun
*) native_pointer(object
);
472 (HeaderValue(fheader
->header
) & FUN_HEADER_NWORDS_MASK
) * N_WORD_BYTES
;
474 /* Transport the whole code object */
475 struct code
*code
= (struct code
*) ((uword_t
) fheader
- offset
);
476 struct code
*ncode
= trans_code(code
);
478 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
487 trans_instance(lispobj object
)
489 gc_dcheck(instancep(object
));
490 lispobj header
= *(lispobj
*)(object
- INSTANCE_POINTER_LOWTAG
);
491 return copy_object(object
, 1 + (instance_length(header
)|1));
495 scav_instance_pointer(lispobj
*where
, lispobj object
)
497 /* Object is a pointer into from space - not a FP. */
498 lispobj copy
= trans_instance(object
);
500 gc_dcheck(copy
!= object
);
502 set_forwarding_pointer(native_pointer(object
), copy
);
513 static lispobj
trans_list(lispobj object
);
516 scav_list_pointer(lispobj
*where
, lispobj object
)
518 gc_dcheck(listp(object
));
520 lispobj copy
= trans_list(object
);
521 gc_dcheck(copy
!= object
);
523 CHECK_COPY_POSTCONDITIONS(copy
, LIST_POINTER_LOWTAG
);
531 trans_list(lispobj object
)
534 struct cons
*copy
= (struct cons
*)
535 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
536 lispobj new_list_pointer
= make_lispobj(copy
, LIST_POINTER_LOWTAG
);
537 copy
->car
= CONS(object
)->car
;
538 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
539 lispobj cdr
= CONS(object
)->cdr
;
540 set_forwarding_pointer((lispobj
*)CONS(object
), new_list_pointer
);
542 /* Try to linearize the list in the cdr direction to help reduce
544 while (listp(cdr
) && from_space_p(cdr
)) {
545 lispobj
* native_cdr
= (lispobj
*)CONS(cdr
);
546 if (forwarding_pointer_p(native_cdr
)) { // Might as well fix now.
547 cdr
= forwarding_pointer_value(native_cdr
);
551 struct cons
*cdr_copy
= (struct cons
*)
552 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
553 cdr_copy
->car
= ((struct cons
*)native_cdr
)->car
;
554 /* Grab the cdr before it is clobbered. */
555 lispobj next
= ((struct cons
*)native_cdr
)->cdr
;
556 /* Set cdr of the predecessor, and store an FP. */
557 set_forwarding_pointer(native_cdr
,
558 copy
->cdr
= make_lispobj(cdr_copy
,
559 LIST_POINTER_LOWTAG
));
564 return new_list_pointer
;
569 * scavenging and transporting other pointers
573 scav_other_pointer(lispobj
*where
, lispobj object
)
575 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
577 /* Object is a pointer into from space - not FP. */
578 lispobj
*first_pointer
= (lispobj
*)(object
- OTHER_POINTER_LOWTAG
);
579 int tag
= widetag_of(*first_pointer
);
580 lispobj copy
= transother
[other_immediate_lowtag_p(tag
)?tag
>>2:0](object
);
582 // If the object was large, then instead of transporting it,
583 // gencgc might simply promote the pages and return the same pointer.
584 // That decision is made in general_copy_large_object().
585 if (copy
!= object
) {
586 set_forwarding_pointer(first_pointer
, copy
);
587 #ifdef LISP_FEATURE_GENCGC
591 #ifndef LISP_FEATURE_GENCGC
594 CHECK_COPY_POSTCONDITIONS(copy
, OTHER_POINTER_LOWTAG
);
599 * immediate, boxed, and unboxed objects
602 /* The immediate object scavenger basically wants to be "scav_cons",
603 * and so returns 2. To see why it's right, observe that scavenge() will
604 * not invoke a scavtab entry on any object except for one satisfying
605 * is_lisp_pointer(). So if a scavtab[] function got here,
606 * then it must be via heap_scavenge(). But heap_scavenge() should only
607 * dispatch via scavtab[] if it thought it saw an object header.
608 * So why do we act like it saw a cons? Because conses can contain an
609 * immediate object that satisfies both other_immediate_lowtag_p()
610 * and is_lisp_immediate(), namely, the objects specifically mentioned at
611 * is_cons_half(). So heap_scavenge() is nearly testing is_cons_half()
612 * but even more efficiently, by ignoring the unusual immediate widetags
613 * until we get to scav_immediate.
615 * And just to hammer the point home: we won't blow past the end of a specific
616 * range of words when scavenging a binding or control stack or anything else,
617 * because scavenge() skips immediate objects all by itself,
618 * or rather it skips anything not satisfying is_lisp_pointer().
620 * As to the unbound marker, see rev. 09c78105eabc6bf2b339f421d4ed1df4678003db
621 * which says that we might see it in conses for reasons somewhat unknown.
624 scav_immediate(lispobj
*where
, lispobj object
)
627 if (is_lisp_pointer(object
)) scav1(where
, object
);
632 trans_immediate(lispobj object
)
634 lose("trying to transport an immediate\n");
635 return NIL
; /* bogus return value to satisfy static type checking */
639 size_immediate(lispobj
*where
)
644 static inline boolean
bignum_logbitp_inline(int index
, struct bignum
* bignum
)
646 int len
= HeaderValue(bignum
->header
);
647 int word_index
= index
/ N_WORD_BITS
;
648 int bit_index
= index
% N_WORD_BITS
;
649 return word_index
< len
? (bignum
->digits
[word_index
] >> bit_index
) & 1 : 0;
651 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
653 /* If the bignum in the layout has another pointer to it (besides the layout)
654 acting as a root, and which is scavenged first, then transporting the
655 bignum causes the layout to see a FP, as would copying an instance whose
656 layout that is. This is a nearly impossible scenario to create organically
657 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
658 except for a few things that would cause it to be pinned anyway,
659 such as it being kept in a local variable during structure manipulation.
660 See 'interleaved-raw.impure.lisp' for a way to trigger this */
661 if (forwarding_pointer_p((lispobj
*)bignum
)) {
662 lispobj forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
664 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
665 (void*)bignum
, (void*)forwarded
);
667 bignum
= (struct bignum
*)native_pointer(forwarded
);
669 return bignum_logbitp_inline(index
, bignum
);
672 // Helper function for stepping through the tagged slots of an instance in
673 // scav_instance and verify_space.
675 instance_scan(void (*proc
)(lispobj
*, sword_t
, uword_t
),
676 lispobj
*instance_slots
,
677 sword_t nslots
, /* number of payload words */
678 lispobj layout_bitmap
,
683 if (fixnump(layout_bitmap
)) {
684 if (layout_bitmap
== make_fixnum(-1))
685 proc(instance_slots
, nslots
, arg
);
687 sword_t bitmap
= fixnum_value(layout_bitmap
); // signed integer!
688 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
690 proc(instance_slots
+ index
, 1, arg
);
692 } else { /* huge bitmap */
693 struct bignum
* bitmap
;
694 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
695 for (index
= 0; index
< nslots
; index
++)
696 if (bignum_logbitp_inline(index
, bitmap
))
697 proc(instance_slots
+ index
, 1, arg
);
702 scav_instance(lispobj
*where
, lispobj header
)
704 lispobj lbitmap
= make_fixnum(-1);
706 if (instance_layout(where
)) {
707 lispobj
*layout
= native_pointer(instance_layout(where
));
708 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
709 if (__immobile_obj_gen_bits(layout
) == from_space
)
710 enliven_immobile_obj(layout
, 1);
712 if (forwarding_pointer_p(layout
))
713 layout
= native_pointer(forwarding_pointer_value(layout
));
715 lbitmap
= ((struct layout
*)layout
)->bitmap
;
717 sword_t nslots
= instance_length(header
) | 1;
718 if (lbitmap
== make_fixnum(-1))
719 scavenge(where
+1, nslots
);
720 else if (!fixnump(lbitmap
)) {
721 /* It is conceivable that 'lbitmap' points to from_space, AND that it
722 * is stored in one of the slots of the instance about to be scanned.
723 * If so, then forwarding it will deposit new bits into its first
724 * one or two words, rendering it bogus for use as the instance's bitmap.
725 * So scavenge it up front to fix its address */
726 scav1(&lbitmap
, lbitmap
);
727 instance_scan((void(*)(lispobj
*,sword_t
,uword_t
))scavenge
,
728 where
+1, nslots
, lbitmap
, 0);
730 sword_t bitmap
= fixnum_value(lbitmap
); // signed integer!
733 for ( ; n
-- ; bitmap
>>= 1) {
735 if ((bitmap
& 1) && is_lisp_pointer(obj
= *where
))
742 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
744 scav_funinstance(lispobj
*where
, lispobj header
)
746 // This works because the layout is in the header word of all instances,
747 // ordinary and funcallable, when compact headers are enabled.
748 // The trampoline slot in the funcallable-instance is raw, but can be
749 // scavenged, because it points to readonly space, never oldspace.
750 // (And for certain backends it looks like a fixnum, not a pointer)
751 return scav_instance(where
, header
);
755 //// Boxed object scav/trans/size functions
757 #define DEF_SCAV_BOXED(suffix, sizer) \
758 static sword_t __attribute__((unused)) \
759 scav_##suffix(lispobj *where, lispobj header) { \
760 return 1 + scavenge(where+1, sizer(header)); \
762 static lispobj trans_##suffix(lispobj object) { \
763 return copy_object(object, 1 + sizer(*native_pointer(object))); \
765 static sword_t size_##suffix(lispobj *where) { return 1 + sizer(*where); }
767 DEF_SCAV_BOXED(boxed
, BOXED_NWORDS
)
768 DEF_SCAV_BOXED(short_boxed
, SHORT_BOXED_NWORDS
)
769 DEF_SCAV_BOXED(tiny_boxed
, TINY_BOXED_NWORDS
)
771 /* Bignums use the high bit as the mark, and all remaining bits
772 * excluding the 8 widetag bits to convey the size.
773 * To size it, shift out the high bit, the shift right by an extra bit,
774 * round to odd, and add 1 for the header. */
775 static inline sword_t
size_bignum(lispobj
*where
) {
776 return 1 + ((*where
<< 1 >> (1+N_WIDETAG_BITS
)) | 1);
779 static lispobj
trans_bignum(lispobj object
)
781 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
782 return copy_large_object(object
, size_bignum(native_pointer(object
)),
786 /* Note: on the sparc we don't have to do anything special for fdefns, */
787 /* 'cause the raw-addr has a function lowtag. */
788 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
790 scav_fdefn(lispobj
*where
, lispobj object
)
792 struct fdefn
*fdefn
= (struct fdefn
*)where
;
794 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
795 fdefn->fun, fdefn->raw_addr)); */
797 scavenge(where
+ 1, 2); // 'name' and 'fun'
798 #ifndef LISP_FEATURE_IMMOBILE_CODE
799 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
800 if (raw_fun
> READ_ONLY_SPACE_END
) {
801 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
802 scavenge(&simple_fun
, 1);
803 /* Don't write unnecessarily. */
804 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
805 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
807 #elif defined(LISP_FEATURE_X86_64)
808 lispobj obj
= fdefn_callee_lispobj(fdefn
);
811 scavenge(&new, 1); // enliven
812 gc_dcheck(new == obj
); // must not move
815 # error "Need to implement scav_fdefn"
822 scav_unboxed(lispobj
*where
, lispobj object
)
824 sword_t length
= HeaderValue(object
) + 1;
825 return ALIGN_UP(length
, 2);
829 trans_unboxed(lispobj object
)
831 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
832 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
833 return copy_unboxed_object(object
, ALIGN_UP(length
, 2));
837 trans_ratio_or_complex(lispobj object
)
839 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
840 lispobj
* x
= native_pointer(object
);
844 /* A zero ratio or complex means it was just allocated by fixed-alloc and
845 a bignum can still be written there. Not a problem with a conservative GC
846 since it will be pinned down. */
847 if (fixnump(a
) && fixnump(b
)
848 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
853 return copy_unboxed_object(object
, 4);
855 return copy_object(object
, 4);
858 /* vector-like objects */
860 trans_vector(lispobj object
)
862 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
864 sword_t length
= fixnum_value(VECTOR(object
)->length
);
865 return copy_large_object(object
, ALIGN_UP(length
+ 2, 2), BOXED_PAGE_FLAG
);
869 size_vector(lispobj
*where
)
871 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
872 return ALIGN_UP(length
+ 2, 2);
875 static inline uword_t
876 NWORDS(uword_t x
, uword_t n_bits
)
878 /* A good compiler should be able to constant-fold this whole thing,
879 even with the conditional. */
880 if(n_bits
<= N_WORD_BITS
) {
881 uword_t elements_per_word
= N_WORD_BITS
/n_bits
;
883 return ALIGN_UP(x
, elements_per_word
)/elements_per_word
;
886 /* FIXME: should have some sort of assertion that N_WORD_BITS
887 evenly divides n_bits */
888 return x
* (n_bits
/N_WORD_BITS
);
892 #define DEF_SCAV_TRANS_SIZE_UB(nbits) \
893 DEF_SPECIALIZED_VECTOR(vector_unsigned_byte_##nbits, NWORDS(length, nbits))
894 #define DEF_SPECIALIZED_VECTOR(name, nwords) \
895 static sword_t __attribute__((unused)) scav_##name(lispobj *where, lispobj header) { \
896 sword_t length = fixnum_value(((struct vector*)where)->length); \
897 return ALIGN_UP(nwords + 2, 2); \
899 static lispobj __attribute__((unused)) trans_##name(lispobj object) { \
900 gc_dcheck(lowtag_of(object) == OTHER_POINTER_LOWTAG); \
901 sword_t length = fixnum_value(VECTOR(object)->length); \
902 return copy_large_object(object, ALIGN_UP(nwords + 2, 2), UNBOXED_PAGE_FLAG); \
904 static sword_t __attribute__((unused)) size_##name(lispobj *where) { \
905 sword_t length = fixnum_value(((struct vector*)where)->length); \
906 return ALIGN_UP(nwords + 2, 2); \
909 DEF_SPECIALIZED_VECTOR(vector_nil
, 0*length
)
910 DEF_SPECIALIZED_VECTOR(vector_bit
, NWORDS(length
,1))
911 /* NOTE: strings contain one more element of data (a terminating '\0'
912 * to help interface with C functions) than indicated by the length slot.
913 * This is true even for UCS4 strings, despite that C APIs are unlikely
914 * to have a convention that expects 4 zero bytes. */
915 DEF_SPECIALIZED_VECTOR(base_string
, NWORDS((length
+1), 8))
916 DEF_SPECIALIZED_VECTOR(character_string
, NWORDS((length
+1), 32))
917 DEF_SCAV_TRANS_SIZE_UB(2)
918 DEF_SCAV_TRANS_SIZE_UB(4)
919 DEF_SCAV_TRANS_SIZE_UB(8)
920 DEF_SCAV_TRANS_SIZE_UB(16)
921 DEF_SCAV_TRANS_SIZE_UB(32)
922 DEF_SCAV_TRANS_SIZE_UB(64)
923 DEF_SCAV_TRANS_SIZE_UB(128)
924 #ifdef LONG_FLOAT_SIZE
925 DEF_SPECIALIZED_VECTOR(vector_long_float
, length
* LONG_FLOAT_SIZE
)
926 DEF_SPECIALIZED_VECTOR(vector_complex_long_float
, length
* (2 * LONG_FLOAT_SIZE
))
930 trans_weak_pointer(lispobj object
)
933 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
935 #if defined(DEBUG_WEAK)
936 printf("Transporting weak pointer from 0x%08x\n", object
);
939 /* Need to remember where all the weak pointers are that have */
940 /* been transported so they can be fixed up in a post-GC pass. */
942 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
943 #ifndef LISP_FEATURE_GENCGC
944 struct weak_pointer
*wp
= (struct weak_pointer
*) native_pointer(copy
);
946 gc_dcheck(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
947 /* Push the weak pointer onto the list of weak pointers. */
948 if (weak_pointer_breakable_p(wp
)) {
949 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
956 void scan_weak_pointers(void)
958 struct weak_pointer
*wp
, *next_wp
;
959 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
960 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
964 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
967 lispobj pointee
= wp
->value
;
968 gc_assert(is_lisp_pointer(pointee
));
969 lispobj
*objaddr
= native_pointer(pointee
);
971 /* Now, we need to check whether the object has been forwarded. If
972 * it has been, the weak pointer is still good and needs to be
973 * updated. Otherwise, the weak pointer needs to be broken. */
975 if (from_space_p(pointee
)) {
976 wp
->value
= forwarding_pointer_p(objaddr
) ?
977 LOW_WORD(forwarding_pointer_value(objaddr
)) : UNBOUND_MARKER_WIDETAG
;
979 #ifdef LISP_FEATURE_IMMOBILE_SPACE
980 else if (immobile_space_p(pointee
)) {
981 if (immobile_obj_gen_bits(objaddr
) == from_space
)
982 wp
->value
= UNBOUND_MARKER_WIDETAG
;
985 #ifdef LISP_FEATURE_GENCGC
986 // Large objects are "moved" by touching the page table gen field.
987 // Do nothing if the target of this weak pointer had that happen.
988 else if (new_space_p(pointee
)) { }
991 lose("unbreakable pointer %p", wp
);
998 #if N_WORD_BITS == 32
999 #define EQ_HASH_MASK 0x1fffffff
1000 #elif N_WORD_BITS == 64
1001 #define EQ_HASH_MASK 0x1fffffffffffffff
1004 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1005 * target-hash-table.lisp. */
1006 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1008 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1009 * slot. Set to NULL at the end of a collection.
1011 * This is not optimal because, when a table is tenured, it won't be
1012 * processed automatically; only the yougest generation is GC'd by
1013 * default. On the other hand, all applications will need an
1014 * occasional full GC anyway, so it's not that bad either. */
1015 struct hash_table
*weak_hash_tables
= NULL
;
1016 struct hopscotch_table weak_objects
; // other than weak pointers
1018 /* Return true if OBJ has already survived the current GC. */
1019 static inline int pointer_survived_gc_yet(lispobj obj
)
1021 #ifdef LISP_FEATURE_CHENEYGC
1022 // This is the most straightforward definition.
1023 return (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
)));
1025 /* Check for a pointer to dynamic space before considering immobile space.
1026 Based on the relative size of the spaces, this should be a win because
1027 if the object is in the dynamic space and not the 'from' generation
1028 we don't want to test immobile_space_p() at all.
1029 Additionally, pinned_p() is both more expensive and less likely than
1030 forwarding_pointer_p(), so we want to reverse those conditions, which
1031 would not be possible with pinned_p() buried inside from_space_p(). */
1032 page_index_t page_index
= find_page_index((void*)obj
);
1033 if (page_index
>= 0)
1034 return page_table
[page_index
].gen
!= from_space
||
1035 forwarding_pointer_p(native_pointer(obj
)) ||
1036 pinned_p(obj
, page_index
);
1037 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1038 if (immobile_space_p(obj
))
1039 return immobile_obj_gen_bits(native_pointer(obj
)) != from_space
;
1045 #define HT_ENTRY_LIVENESS_FUN_ARRAY_NAME weak_ht_alivep_funs
1046 #include "weak-hash-pred.inc"
1048 /* Return the beginning of data in ARRAY (skipping the header and the
1049 * length) or NULL if it isn't an array of the specified widetag after
1051 static inline lispobj
*
1052 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1054 if (is_lisp_pointer(array
) && widetag_of(*native_pointer(array
)) == widetag
) {
1056 *length
= fixnum_value(native_pointer(array
)[1]);
1057 return native_pointer(array
) + 2;
1063 static void inline add_trigger(lispobj triggering_object
, lispobj
* plivened_object
)
1065 extern uword_t
gc_private_cons(uword_t
, uword_t
);
1066 if (is_lisp_pointer(*plivened_object
)) // Nonpointer objects are ignored
1067 hopscotch_put(&weak_objects
, triggering_object
,
1068 gc_private_cons((uword_t
)plivened_object
,
1069 hopscotch_get(&weak_objects
,
1070 triggering_object
, 0)));
1073 int debug_weak_ht
= 0;
1074 static void inline add_kv_triggers(lispobj
* pair
, int weakness
)
1076 if (debug_weak_ht
) {
1077 const char *const strings
[3] = {"key","val","key-or-val"}; // {1, 2, 3}
1078 fprintf(stderr
, "weak %s: <%"OBJ_FMTX
",%"OBJ_FMTX
">\n",
1079 strings
[weakness
-1], pair
[0], pair
[1]);
1081 if (weakness
& 1) add_trigger(pair
[0], &pair
[1]);
1082 if (weakness
& 2) add_trigger(pair
[1], &pair
[0]);
1085 /* This is essentially a set join operation over the set of all live objects
1086 * against the set of watched objects.
1087 * The question is which way to perform the join for maximum efficiency:
1089 * 1. as each object is transported, test if it's in the trigger table
1091 * 2. scan the trigger table periodically checking whether each object is live.
1093 * (1) performs a constant amount more work (a hashtable lookup) per forwarding
1094 * and also has to maintain some kind of queue of the objects whose trigger
1096 * (2) has no hashtable lookup entailed by transporting, but performs a number
1097 * of extra survived_gc_yet() calls periodically corresponding to triggering
1098 * objects that and are not known to be live.
1100 * There are far more transported objects than key objects in the weak object
1101 * table, so despite that (1) has lower computational complexity,
1102 * it seems like (2) works well in practice due to the cheaper implementation.
1103 * Obviously we could benchmark and compare, but seeing as how this already
1104 * fixes the scaling problem in a huge way, it's not an important question.
1107 /* Call 'predicate' on each triggering object, and if it returns 1, then call
1108 * 'mark' on each livened object, or use scav1() if 'mark' is null */
1109 boolean
test_weak_triggers(int (*predicate
)(lispobj
), void (*mark
)(lispobj
))
1111 extern void gc_private_free(struct cons
*);
1112 int old_count
= weak_objects
.count
;
1114 lispobj trigger_obj
;
1116 if (!old_count
) return 0;
1118 printf("begin scan_weak_pairs: count=%d\n", old_count
);
1120 struct cons
**values
= (struct cons
**)weak_objects
.values
;
1122 predicate
= pointer_survived_gc_yet
;
1124 for_each_hopscotch_key(index
, trigger_obj
, weak_objects
) {
1125 gc_assert(is_lisp_pointer(trigger_obj
));
1126 if (predicate(trigger_obj
)) {
1128 if (debug_weak_ht
) {
1129 fprintf(stderr
, "weak object %"OBJ_FMTX
" livens", trigger_obj
);
1130 for ( chain
= values
[index
] ; chain
; chain
= (struct cons
*)chain
->cdr
)
1131 fprintf(stderr
, " *%"OBJ_FMTX
"=%"OBJ_FMTX
,
1132 chain
->car
, *(lispobj
*)chain
->car
);
1133 fputc('\n', stderr
);
1135 chain
= values
[index
];
1137 for ( ; chain
; chain
= (struct cons
*)chain
->cdr
) {
1138 lispobj
*plivened_obj
= (lispobj
*)chain
->car
;
1139 // Don't scavenge the cell in place! We lack the information
1140 // required to set the rehash flag on address-sensitive keys.
1141 lispobj livened_obj
= *plivened_obj
;
1145 scav1(&livened_obj
, livened_obj
);
1147 gc_private_free(values
[index
]);
1148 hopscotch_delete(&weak_objects
, trigger_obj
);
1149 if (!weak_objects
.count
) {
1150 hopscotch_reset(&weak_objects
);
1152 fprintf(stderr
, "no more weak pairs\n");
1155 gc_assert(weak_objects
.count
> 0);
1158 fprintf(stderr
, "weak object %"OBJ_FMTX
" still dead\n", trigger_obj
);
1162 printf("end scan_weak_pairs: count=%d\n", weak_objects
.count
);
1163 return weak_objects
.count
!= old_count
;
1169 hopscotch_create(&weak_objects
, HOPSCOTCH_HASH_FUN_DEFAULT
, N_WORD_BYTES
,
1170 32 /* logical bin count */, 0 /* default range */);
1173 /* Only need to worry about scavenging the _real_ entries in the
1174 * table. The vector element at index 0 (the hash table itself)
1175 * was scavenged already. */
1176 boolean
scav_hash_table_entries(struct hash_table
*hash_table
,
1177 int (*predicate
)(lispobj
,lispobj
),
1178 void (*scav_entry
)(lispobj
*))
1182 uword_t next_vector_length
;
1183 uword_t hash_vector_length
;
1185 boolean any_deferred
= 0;
1187 lispobj
*kv_vector
= get_array_data(hash_table
->table
,
1188 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1189 if (kv_vector
== NULL
)
1190 lose("invalid kv_vector %x\n", hash_table
->table
);
1192 lispobj
*index_vector
= get_array_data(hash_table
->index_vector
,
1193 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1194 if (index_vector
== NULL
)
1195 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1197 lispobj
*next_vector
= get_array_data(hash_table
->next_vector
,
1198 SIMPLE_ARRAY_WORD_WIDETAG
,
1199 &next_vector_length
);
1200 if (next_vector
== NULL
)
1201 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1203 lispobj
*hash_vector
= get_array_data(hash_table
->hash_vector
,
1204 SIMPLE_ARRAY_WORD_WIDETAG
,
1205 &hash_vector_length
);
1206 if (hash_vector
!= NULL
)
1207 gc_assert(hash_vector_length
== next_vector_length
);
1209 /* These lengths could be different as the index_vector can be a
1210 * different length from the others, a larger index_vector could
1211 * help reduce collisions. */
1212 gc_assert(next_vector_length
*2 == kv_length
);
1214 if (kv_vector
[1] && kv_vector
[1] != make_fixnum(1))
1215 lose("unexpected need-to-rehash: %"OBJ_FMTX
, kv_vector
[1]);
1217 /* Work through the KV vector. */
1219 // We can disregard any entry in which both key and value are immediates.
1220 // This effectively ignores empty pairs, as well as makes fixnum -> fixnum
1221 // mappings more efficient.
1222 // If the bitwise OR of two lispobjs satisfies is_lisp_pointer(),
1223 // then at least one is a pointer.
1224 #define SCAV_ENTRIES(entry_alivep, defer) \
1225 for (i = 1; i < next_vector_length; i++) { \
1226 lispobj key = kv_vector[2*i], value = kv_vector[2*i+1]; \
1227 if (is_lisp_pointer(key|value)) { \
1228 if (!entry_alivep) { defer; any_deferred = 1; } else { \
1229 /* Scavenge the key and value. */ \
1230 scav_entry(&kv_vector[2*i]); \
1231 /* If an EQ-based key has moved, mark the hash-table for rehash */ \
1232 if (kv_vector[2*i] != key && \
1233 (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) \
1236 if (predicate
) { // Call the predicate on each entry to decide liveness
1237 int weakness
= hashtable_weakness(hash_table
);
1238 SCAV_ENTRIES(predicate(key
, value
),
1239 add_kv_triggers(&kv_vector
[2*i
], weakness
));
1240 if (!any_deferred
&& debug_weak_ht
)
1242 "will skip rescan of weak ht: %d/%d items\n",
1243 (int)fixnum_value(hash_table
->number_entries
),
1244 (int)fixnum_value(hash_table
->rehash_trigger
));
1245 } else { // The entries are always live
1249 // Though at least partly writable, the vector might have
1250 // element 1 on a write-protected page.
1252 NON_FAULTING_STORE(kv_vector
[1] = make_fixnum(1), &kv_vector
[1]);
1253 return any_deferred
;
1257 scav_vector (lispobj
*where
, lispobj header
)
1259 sword_t kv_length
= fixnum_value(where
[1]);
1260 struct hash_table
*hash_table
;
1262 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1263 * hash tables in the Lisp HASH-TABLE code to indicate need for
1264 * special GC support. */
1265 if (is_vector_subtype(header
, VectorNormal
)) {
1267 scavenge(where
+ 2, kv_length
);
1268 return ALIGN_UP(kv_length
+ 2, 2);
1271 /* Scavenge element 0, which may be a hash-table structure. */
1272 scavenge(where
+2, 1);
1273 if (!is_lisp_pointer(where
[2])) {
1274 /* This'll happen when REHASH clears the header of old-kv-vector
1275 * and fills it with zero, but some other thread simulatenously
1276 * sets the header in %%PUTHASH.
1279 "Warning: no pointer at %p in hash table: this indicates "
1280 "non-fatal corruption caused by concurrent access to a "
1281 "hash-table from multiple threads. Any accesses to "
1282 "hash-tables shared between threads should be protected "
1283 "by locks.\n", (void*)&where
[2]);
1286 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1287 if (widetag_of(hash_table
->header
) != INSTANCE_WIDETAG
) {
1288 lose("hash table not instance (%"OBJ_FMTX
" at %p)\n",
1293 /* Verify that vector element 1 is as expected.
1294 Don't bother scavenging it, since we lose() if it's not an immediate. */
1295 if (where
[3] && where
[3] != make_fixnum(1))
1296 lose("unexpected need-to-rehash: %"OBJ_FMTX
, where
[3]);
1298 /* Scavenge hash table, which will fix the positions of the other
1299 * needed objects. */
1300 scav_instance((lispobj
*)hash_table
, hash_table
->header
);
1302 /* Cross-check the kv_vector. */
1303 if (where
!= native_pointer(hash_table
->table
)) {
1304 lose("hash_table table!=this table %"OBJ_FMTX
, hash_table
->table
);
1307 if (!hashtable_weakp(hash_table
)) {
1308 scav_hash_table_entries(hash_table
, 0, gc_scav_pair
);
1309 } else if (hash_table
->next_weak_hash_table
== NIL
) {
1310 int weakness
= hashtable_weakness(hash_table
);
1312 /* Key-AND-Value means that no scavenging can/will be performed as
1313 * a consequence of visiting the table. Each entry is looked at once
1314 * only, after _all_ other work is done, and then it's either live
1315 * or it isn't based on whether both halves are live. So the initial
1316 * value of 'defer = 1' is correct. For all other weakness kinds,
1317 * we might be able to skip rescan depending on whether all entries
1318 * are actually live right now, as opposed to provisionally live */
1319 if (weakness
!= WEAKNESS_KEY_AND_VALUE
)
1320 defer
= scav_hash_table_entries(hash_table
,
1321 weak_ht_alivep_funs
[weakness
],
1323 /* There is a down-side to *not* pushing the table into the list,
1324 * but it should not matter too much: if we attempt to scavenge more
1325 * than once (when and only when the newspace areas overflow),
1326 * then we don't know that we already did it, and we'll do it again.
1327 * This is the same as occurs on all other objects */
1329 NON_FAULTING_STORE(hash_table
->next_weak_hash_table
1330 = (lispobj
)weak_hash_tables
,
1331 &hash_table
->next_weak_hash_table
);
1332 weak_hash_tables
= hash_table
;
1336 return (ALIGN_UP(kv_length
+ 2, 2));
1339 /* Walk through the chain whose first element is *FIRST and remove
1340 * dead weak entries. */
1342 cull_weak_hash_table_bucket(struct hash_table
*hash_table
, lispobj
*prev
,
1343 lispobj
*kv_vector
, lispobj
*index_vector
,
1344 lispobj
*next_vector
, lispobj
*hash_vector
,
1345 int (*alivep_test
)(lispobj
,lispobj
),
1346 void (*fix_pointers
)(lispobj
[2]),
1347 boolean save_culled_values
,
1350 const lispobj empty_symbol
= UNBOUND_MARKER_WIDETAG
;
1351 unsigned index
= *prev
;
1353 unsigned next
= next_vector
[index
];
1354 lispobj key
= kv_vector
[2 * index
];
1355 lispobj value
= kv_vector
[2 * index
+ 1];
1356 gc_assert(key
!= empty_symbol
);
1357 gc_assert(value
!= empty_symbol
);
1358 if (!alivep_test(key
, value
)) {
1359 gc_assert(hash_table
->number_entries
> 0);
1361 hash_table
->number_entries
-= make_fixnum(1);
1362 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1363 hash_table
->next_free_kv
= make_fixnum(index
);
1364 kv_vector
[2 * index
] = empty_symbol
;
1365 if (save_culled_values
) {
1366 lispobj val
= kv_vector
[2 * index
+ 1];
1367 gc_assert(!is_lisp_pointer(val
));
1368 struct cons
*cons
= (struct cons
*)
1369 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
1370 // Lisp code which manipulates the culled_values slot must use
1371 // compare-and-swap, but C code need not, because GC runs in one
1372 // thread and has stopped the Lisp world.
1373 cons
->cdr
= hash_table
->culled_values
;
1374 hash_table
->culled_values
= make_lispobj(cons
, LIST_POINTER_LOWTAG
);
1377 kv_vector
[2 * index
+ 1] = empty_symbol
;
1379 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1381 if (fix_pointers
) { // Follow FPs as necessary
1382 lispobj key
= kv_vector
[2 * index
];
1383 fix_pointers(&kv_vector
[2 * index
]);
1384 if (kv_vector
[2 * index
] != key
&&
1385 (!hash_vector
|| hash_vector
[index
] == MAGIC_HASH_VECTOR_VALUE
))
1388 prev
= &next_vector
[index
];
1395 cull_weak_hash_table (struct hash_table
*hash_table
,
1396 int (*alivep_test
)(lispobj
,lispobj
),
1397 void (*fix_pointers
)(lispobj
[2]))
1399 uword_t length
= 0; /* prevent warning */
1400 uword_t next_vector_length
= 0; /* prevent warning */
1403 lispobj
*kv_vector
= get_array_data(hash_table
->table
,
1404 SIMPLE_VECTOR_WIDETAG
, NULL
);
1405 lispobj
*index_vector
= get_array_data(hash_table
->index_vector
,
1406 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1407 lispobj
*next_vector
= get_array_data(hash_table
->next_vector
,
1408 SIMPLE_ARRAY_WORD_WIDETAG
,
1409 &next_vector_length
);
1410 lispobj
*hash_vector
= get_array_data(hash_table
->hash_vector
,
1411 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1414 boolean save_culled_values
= (hash_table
->flags
& MAKE_FIXNUM(4)) != 0;
1415 for (i
= 0; i
< length
; i
++) {
1416 cull_weak_hash_table_bucket(hash_table
, &index_vector
[i
],
1417 kv_vector
, index_vector
, next_vector
,
1418 hash_vector
, alivep_test
, fix_pointers
,
1419 save_culled_values
, &rehash
);
1421 /* If an EQ-based key has moved, mark the hash-table for rehash */
1423 NON_FAULTING_STORE(kv_vector
[1] = make_fixnum(1), &kv_vector
[1]);
1426 /* Fix one <k,v> pair in a weak hashtable.
1427 * Do not call scavenge(), just follow forwarding pointers */
1428 static void pair_follow_fps(lispobj ht_entry
[2])
1430 lispobj obj
= ht_entry
[0];
1431 if (is_lisp_pointer(obj
) && from_space_p (obj
) &&
1432 forwarding_pointer_p(native_pointer(obj
)))
1433 ht_entry
[0] = forwarding_pointer_value(native_pointer(obj
));
1435 if (is_lisp_pointer(obj
) && from_space_p (obj
) &&
1436 forwarding_pointer_p(native_pointer(obj
)))
1437 ht_entry
[1] = forwarding_pointer_value(native_pointer(obj
));
1440 /* Remove dead entries from weak hash tables. */
1441 void cull_weak_hash_tables(int (*alivep
[5])(lispobj
,lispobj
))
1443 struct hash_table
*table
, *next
;
1445 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1446 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1447 NON_FAULTING_STORE(table
->next_weak_hash_table
= NIL
,
1448 &table
->next_weak_hash_table
);
1449 cull_weak_hash_table(table
, alivep
[hashtable_weakness(table
)],
1452 weak_hash_tables
= NULL
;
1453 /* Reset weak_objects only if the count is nonzero.
1454 * If test_weak_triggers() caused the count to hit zero, then it already
1455 * performed a reset. Consecutive resets with no intervening insert are
1456 * technically ok, but it's best to avoid halving the size twice,
1457 * which is what an extra reset would do if it saw no inserts. */
1458 if (weak_objects
.count
)
1459 hopscotch_reset(&weak_objects
);
1468 scav_lose(lispobj
*where
, lispobj object
)
1470 lose("no scavenge function for object %p (widetag 0x%x)\n",
1472 widetag_of(*where
));
1474 return 0; /* bogus return value to satisfy static type checking */
1478 trans_lose(lispobj object
)
1480 lose("no transport function for object %p (widetag 0x%x)\n",
1482 widetag_of(*native_pointer(object
)));
1483 return NIL
; /* bogus return value to satisfy static type checking */
1487 size_lose(lispobj
*where
)
1489 lose("no size function for object at %p (widetag 0x%x)\n",
1491 widetag_of(*where
));
1492 return 1; /* bogus return value to satisfy static type checking */
1500 #include "genesis/gc-tables.h"
1503 lispobj
*search_all_gc_spaces(void *pointer
)
1506 if (((start
= search_dynamic_space(pointer
)) != NULL
) ||
1507 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1508 ((start
= search_immobile_space(pointer
)) != NULL
) ||
1510 ((start
= search_static_space(pointer
)) != NULL
) ||
1511 ((start
= search_read_only_space(pointer
)) != NULL
))
1516 /* Find the code object for the given pc, or return NULL on
1519 component_ptr_from_pc(lispobj
*pc
)
1521 lispobj
*object
= search_all_gc_spaces(pc
);
1523 if (object
!= NULL
&& widetag_of(*object
) == CODE_HEADER_WIDETAG
)
1529 /* Scan an area looking for an object which encloses the given pointer.
1530 * Return the object start on success, or NULL on failure. */
1532 gc_search_space3(void *pointer
, lispobj
*start
, void *limit
)
1534 if (pointer
< (void*)start
|| pointer
>= limit
) return NULL
;
1538 /* CAUTION: this code is _significantly_ slower than the production version
1539 due to the extra checks for forwarding. Only use it if debugging */
1540 for ( ; (void*)start
< limit
; start
+= count
) {
1541 lispobj
*forwarded_start
;
1542 if (forwarding_pointer_p(start
))
1543 forwarded_start
= native_pointer(forwarding_pointer_value(start
));
1545 forwarded_start
= start
;
1546 lispobj thing
= *forwarded_start
;
1547 count
= OBJECT_SIZE(thing
, forwarded_start
);
1548 /* Check whether the pointer is within this object. */
1549 if (pointer
< (void*)(start
+count
)) return start
;
1552 for ( ; (void*)start
< limit
; start
+= count
) {
1553 lispobj thing
= *start
;
1554 count
= OBJECT_SIZE(thing
, start
);
1555 /* Check whether the pointer is within this object. */
1556 if (pointer
< (void*)(start
+count
)) return start
;
1562 /* Helper for valid_lisp_pointer_p (below) and
1563 * conservative_root_p (gencgc).
1565 * pointer is the pointer to check validity of,
1566 * and start_addr is the address of the enclosing object.
1568 * This is actually quite simple to check: because the heap state is assumed
1569 * consistent, and 'start_addr' is known good, having come from
1570 * gc_search_space(), only the 'pointer' argument is dubious.
1571 * So make 'start_addr' into a tagged pointer and see if that matches 'pointer'.
1572 * If it does, then 'pointer' is valid.
1575 properly_tagged_p_internal(lispobj pointer
, lispobj
*start_addr
)
1577 // If a headerless object, confirm that 'pointer' is a list pointer.
1578 // Given the precondition that the heap is in a valid state,
1579 // it may be assumed that one check of is_cons_half() suffices;
1580 // we don't need to check the other half.
1581 lispobj header
= *start_addr
;
1582 if (is_cons_half(header
))
1583 return make_lispobj(start_addr
, LIST_POINTER_LOWTAG
) == pointer
;
1585 // Because this heap object was not deemed to be a cons,
1586 // it must be an object header. Don't need a check except when paranoid.
1587 gc_dcheck(other_immediate_lowtag_p(header
));
1589 // The space of potential widetags has 64 elements, not 256,
1590 // because of the constant low 2 bits.
1591 int widetag
= widetag_of(header
);
1592 int lowtag
= lowtag_for_widetag
[widetag
>>2];
1593 if (lowtag
&& make_lispobj(start_addr
, lowtag
) == pointer
)
1594 return 1; // instant win
1596 if (widetag
== CODE_HEADER_WIDETAG
) {
1597 // Check for RETURN_PC_HEADER first since it's quicker.
1598 // Then consider the embedded simple-funs.
1599 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1600 /* The all-architecture test below is good as far as it goes,
1601 * but an LRA object is similar to a FUN-POINTER: It is
1602 * embedded within a CODE-OBJECT pointed to by start_addr, and
1603 * cannot be found by simply walking the heap, therefore we
1604 * need to check for it. -- AB, 2010-Jun-04 */
1605 if (lowtag_of(pointer
) == OTHER_POINTER_LOWTAG
) {
1606 lispobj
*potential_lra
= native_pointer(pointer
);
1607 if ((widetag_of(potential_lra
[0]) == RETURN_PC_WIDETAG
) &&
1608 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
1609 return 1; /* It's as good as we can verify. */
1613 if (functionp(pointer
)) {
1614 struct simple_fun
*pfun
=
1615 (struct simple_fun
*)(pointer
-FUN_POINTER_LOWTAG
);
1616 for_each_simple_fun(i
, function
, (struct code
*)start_addr
, 0, {
1617 if (pfun
== function
) return 1;
1621 return 0; // no good
1624 /* META: Note the ambiguous word "validate" in the comment below.
1625 * This means "Decide whether <x> is valid".
1626 * But when you see os_validate() elsewhere, that doesn't mean to ask
1627 * whether something is valid, it says to *make* it valid.
1628 * I think it would be nice if we could avoid using the word in the
1629 * sense in which os_validate() uses it, which would entail renaming
1630 * a bunch of stuff, which is harder than just explaining why
1631 * the comments can be deceptive */
1633 /* Used by the debugger to validate possibly bogus pointers before
1634 * calling MAKE-LISP-OBJ on them.
1636 * FIXME: We would like to make this perfect, because if the debugger
1637 * constructs a reference to a bugs lisp object, and it ends up in a
1638 * location scavenged by the GC all hell breaks loose.
1640 * Whereas conservative_root_p has to be conservative
1641 * and return true for all valid pointers, this could actually be eager
1642 * and lie about a few pointers without bad results... but that should
1643 * be reflected in the name.
1646 valid_lisp_pointer_p(lispobj pointer
)
1648 lispobj
*start
= search_all_gc_spaces((void*)pointer
);
1650 return properly_tagged_descriptor_p((void*)pointer
, start
);
1655 maybe_gc(os_context_t
*context
)
1657 lispobj gc_happened
;
1658 __attribute__((unused
)) struct thread
*thread
= arch_os_get_current_thread();
1659 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
1662 fake_foreign_function_call(context
);
1665 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
1666 * which case we will be running with no gc trigger barrier
1667 * thing for a while. But it shouldn't be long until the end
1670 * FIXME: It would be good to protect the end of dynamic space for
1671 * CheneyGC and signal a storage condition from there.
1674 /* Restore the signal mask from the interrupted context before
1675 * calling into Lisp if interrupts are enabled. Why not always?
1677 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
1678 * interrupt hits while in SUB-GC, it is deferred and the
1679 * os_context_sigmask of that interrupt is set to block further
1680 * deferrable interrupts (until the first one is
1681 * handled). Unfortunately, that context refers to this place and
1682 * when we return from here the signals will not be blocked.
1684 * A kludgy alternative is to propagate the sigmask change to the
1687 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
1688 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
1689 unblock_gc_signals(0, 0);
1691 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
1692 /* FIXME: Nothing must go wrong during GC else we end up running
1693 * the debugger, error handlers, and user code in general in a
1694 * potentially unsafe place. Running out of the control stack or
1695 * the heap in SUB-GC are ways to lose. Of course, deferrables
1696 * cannot be unblocked because there may be a pending handler, or
1697 * we may even be in a WITHOUT-INTERRUPTS. */
1698 gc_happened
= funcall1(StaticSymbolFunction(SUB_GC
), 0);
1699 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
1700 (gc_happened
== NIL
)
1702 : ((gc_happened
== T
)
1705 /* gc_happened can take three values: T, NIL, 0.
1707 * T means that the thread managed to trigger a GC, and post-gc
1710 * NIL means that the thread is within without-gcing, and no GC
1713 * Finally, 0 means that *a* GC has occurred, but it wasn't
1714 * triggered by this thread; success, but post-gc doesn't have
1717 if ((gc_happened
== T
) &&
1718 /* See if interrupts are enabled or it's possible to enable
1719 * them. POST-GC has a similar check, but we don't want to
1720 * unlock deferrables in that case and get a pending interrupt
1722 ((read_TLS(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
1723 (read_TLS(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
1724 #ifndef LISP_FEATURE_WIN32
1725 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
1726 if (!deferrables_blocked_p(context_sigmask
)) {
1727 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
1728 #ifndef LISP_FEATURE_SB_SAFEPOINT
1729 check_gc_signals_unblocked_or_lose(0);
1732 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
1733 funcall0(StaticSymbolFunction(POST_GC
));
1734 #ifndef LISP_FEATURE_WIN32
1736 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
1742 undo_fake_foreign_function_call(context
);
1744 /* Otherwise done by undo_fake_foreign_function_call. And
1745 something later wants them to be blocked. What a nice
1747 block_blockable_signals(0);
1750 FSHOW((stderr
, "/maybe_gc: returning\n"));
1751 return (gc_happened
!= NIL
);
1754 #define BYTES_ZERO_BEFORE_END (1<<12)
1756 /* There used to be a similar function called SCRUB-CONTROL-STACK in
1757 * Lisp and another called zero_stack() in cheneygc.c, but since it's
1758 * shorter to express in, and more often called from C, I keep only
1759 * the C one after fixing it. -- MG 2009-03-25 */
1761 /* Zero the unused portion of the control stack so that old objects
1762 * are not kept alive because of uninitialized stack variables.
1764 * "To summarize the problem, since not all allocated stack frame
1765 * slots are guaranteed to be written by the time you call an another
1766 * function or GC, there may be garbage pointers retained in your dead
1767 * stack locations. The stack scrubbing only affects the part of the
1768 * stack from the SP to the end of the allocated stack." - ram, on
1769 * cmucl-imp, Tue, 25 Sep 2001
1771 * So, as an (admittedly lame) workaround, from time to time we call
1772 * scrub-control-stack to zero out all the unused portion. This is
1773 * supposed to happen when the stack is mostly empty, so that we have
1774 * a chance of clearing more of it: callers are currently (2002.07.18)
1775 * REPL, SUB-GC and sig_stop_for_gc_handler. */
1777 /* Take care not to tread on the guard page and the hard guard page as
1778 * it would be unkind to sig_stop_for_gc_handler. Touching the return
1779 * guard page is not dangerous. For this to work the guard page must
1780 * be zeroed when protected. */
1782 /* FIXME: I think there is no guarantee that once
1783 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
1784 * may be what the "lame" adjective in the above comment is for. In
1785 * this case, exact gc may lose badly. */
1787 scrub_control_stack()
1789 scrub_thread_control_stack(arch_os_get_current_thread());
1793 scrub_thread_control_stack(struct thread
*th
)
1795 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
1796 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
1797 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1798 /* On these targets scrubbing from C is a bad idea, so we punt to
1799 * a routine in $ARCH-assem.S. */
1800 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
1801 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
1803 lispobj
*sp
= access_control_stack_pointer(th
);
1805 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
1806 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
1807 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
1808 ((os_vm_address_t
)sp
>= guard_page_address
) &&
1809 (th
->control_stack_guard_page_protected
!= NIL
)))
1811 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
1814 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1815 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
1820 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1824 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1825 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
1830 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1832 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
1835 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1838 scavenge_control_stack(struct thread
*th
)
1840 if (!compacting_p()) {
1841 long nwords
= (lispobj
*)access_control_stack_pointer(th
) - th
->control_stack_start
;
1842 gc_mark_range(th
->control_stack_start
, nwords
);
1845 lispobj
*object_ptr
;
1847 /* In order to properly support dynamic-extent allocation of
1848 * non-CONS objects, the control stack requires special handling.
1849 * Rather than calling scavenge() directly, grovel over it fixing
1850 * broken hearts, scavenging pointers to oldspace, and pitching a
1851 * fit when encountering unboxed data. This prevents stray object
1852 * headers from causing the scavenger to blow past the end of the
1853 * stack (an error case checked in scavenge()). We don't worry
1854 * about treating unboxed words as boxed or vice versa, because
1855 * the compiler isn't allowed to store unboxed objects on the
1856 * control stack. -- AB, 2011-Dec-02 */
1858 /* FIXME: I believe that this loop could be replaced by scavenge(),
1859 * as it can not "... blow past the end" on header words,
1860 * the way that heap_scavenge() might */
1861 for (object_ptr
= th
->control_stack_start
;
1862 object_ptr
< access_control_stack_pointer(th
);
1865 lispobj object
= *object_ptr
;
1866 #ifdef LISP_FEATURE_GENCGC
1867 if (forwarding_pointer_p(object_ptr
))
1868 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
1869 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
1871 if (is_lisp_pointer(object
) && from_space_p(object
)) {
1872 /* It currently points to old space. Check for a
1873 * forwarding pointer. */
1874 lispobj
*ptr
= native_pointer(object
);
1875 if (forwarding_pointer_p(ptr
)) {
1876 /* Yes, there's a forwarding pointer. */
1877 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
1879 /* Scavenge that pointer. */
1880 long n_words_scavenged
=
1881 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
1882 gc_assert(n_words_scavenged
== 1);
1884 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
1885 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
1886 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
1891 /* Scavenging Interrupt Contexts */
1893 static int boxed_registers
[] = BOXED_REGISTERS
;
1895 /* The GC has a notion of an "interior pointer" register, an unboxed
1896 * register that typically contains a pointer to inside an object
1897 * referenced by another pointer. The most obvious of these is the
1898 * program counter, although many compiler backends define a "Lisp
1899 * Interior Pointer" register known to the runtime as reg_LIP, and
1900 * various CPU architectures have other registers that also partake of
1901 * the interior-pointer nature. As the code for pairing an interior
1902 * pointer value up with its "base" register, and fixing it up after
1903 * scavenging is complete is horribly repetitive, a few macros paper
1904 * over the monotony. --AB, 2010-Jul-14 */
1906 /* These macros are only ever used over a lexical environment which
1907 * defines a pointer to an os_context_t called context, thus we don't
1908 * bother to pass that context in as a parameter. */
1910 /* Define how to access a given interior pointer. */
1911 #define ACCESS_INTERIOR_POINTER_pc \
1912 *os_context_pc_addr(context)
1913 #define ACCESS_INTERIOR_POINTER_lip \
1914 *os_context_register_addr(context, reg_LIP)
1915 #define ACCESS_INTERIOR_POINTER_lr \
1916 *os_context_lr_addr(context)
1917 #define ACCESS_INTERIOR_POINTER_npc \
1918 *os_context_npc_addr(context)
1919 #define ACCESS_INTERIOR_POINTER_ctr \
1920 *os_context_ctr_addr(context)
1922 #define INTERIOR_POINTER_VARS(name) \
1923 uword_t name##_offset; \
1924 int name##_register_pair
1926 #define PAIR_INTERIOR_POINTER(name) \
1927 pair_interior_pointer(context, \
1928 ACCESS_INTERIOR_POINTER_##name, \
1930 &name##_register_pair)
1932 /* One complexity here is that if a paired register is not found for
1933 * an interior pointer, then that pointer does not get updated.
1934 * Originally, there was some commentary about using an index of -1
1935 * when calling os_context_register_addr() on SPARC referring to the
1936 * program counter, but the real reason is to allow an interior
1937 * pointer register to point to the runtime, read-only space, or
1938 * static space without problems. */
1939 #define FIXUP_INTERIOR_POINTER(name) \
1941 if (name##_register_pair >= 0) { \
1942 ACCESS_INTERIOR_POINTER_##name = \
1943 (*os_context_register_addr(context, \
1944 name##_register_pair) \
1952 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
1953 uword_t
*saved_offset
, int *register_pair
)
1958 * I (RLT) think this is trying to find the boxed register that is
1959 * closest to the LIP address, without going past it. Usually, it's
1960 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
1962 /* 0x7FFFFFFF on 32-bit platforms;
1963 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
1964 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
1965 *register_pair
= -1;
1966 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1971 index
= boxed_registers
[i
];
1972 reg
= *os_context_register_addr(context
, index
);
1974 /* An interior pointer is never relative to a non-pointer
1975 * register (an oversight in the original implementation).
1976 * The simplest argument for why this is true is to consider
1977 * the fixnum that happens by coincide to be the word-index in
1978 * memory of the header for some object plus two. This is
1979 * happenstance would cause the register containing the fixnum
1980 * to be selected as the register_pair if the interior pointer
1981 * is to anywhere after the first two words of the object.
1982 * The fixnum won't be changed during GC, but the object might
1983 * move, thus destroying the interior pointer. --AB,
1986 if (is_lisp_pointer(reg
) &&
1987 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
1988 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
1989 if (offset
< *saved_offset
) {
1990 *saved_offset
= offset
;
1991 *register_pair
= index
;
1998 scavenge_interrupt_context(os_context_t
* context
)
2002 /* FIXME: The various #ifdef noise here is precisely that: noise.
2003 * Is it possible to fold it into the macrology so that we have
2004 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2005 * compile out for the registers that don't exist on a given
2008 INTERIOR_POINTER_VARS(pc
);
2010 INTERIOR_POINTER_VARS(lip
);
2012 #ifdef ARCH_HAS_LINK_REGISTER
2013 INTERIOR_POINTER_VARS(lr
);
2015 #ifdef ARCH_HAS_NPC_REGISTER
2016 INTERIOR_POINTER_VARS(npc
);
2018 #ifdef LISP_FEATURE_PPC
2019 INTERIOR_POINTER_VARS(ctr
);
2022 PAIR_INTERIOR_POINTER(pc
);
2024 PAIR_INTERIOR_POINTER(lip
);
2026 #ifdef ARCH_HAS_LINK_REGISTER
2027 PAIR_INTERIOR_POINTER(lr
);
2029 #ifdef ARCH_HAS_NPC_REGISTER
2030 PAIR_INTERIOR_POINTER(npc
);
2032 #ifdef LISP_FEATURE_PPC
2033 PAIR_INTERIOR_POINTER(ctr
);
2036 /* Scavenge all boxed registers in the context. */
2037 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
2038 os_context_register_t
*boxed_reg
;
2041 /* We can't "just" cast os_context_register_addr() to a
2042 * pointer to lispobj and pass it to scavenge, because some
2043 * systems can have a wider register width than we use for
2044 * lisp objects, and on big-endian systems casting a pointer
2045 * to a narrower target type doesn't work properly.
2046 * Therefore, we copy the value out to a temporary lispobj
2047 * variable, scavenge there, and copy the value back in.
2049 * FIXME: lispobj is unsigned, os_context_register_t may be
2050 * signed or unsigned, are we truncating or sign-extending
2051 * values here that shouldn't be modified? Possibly affects
2052 * any architecture that has 32-bit and 64-bit variants where
2053 * we run in 32-bit mode on 64-bit hardware when the OS is set
2054 * up for 64-bit from the start. Or an environment with
2055 * 32-bit addresses and 64-bit registers. */
2057 boxed_reg
= os_context_register_addr(context
, boxed_registers
[i
]);
2059 if (compacting_p()) scavenge(&datum
, 1); else gc_mark_obj(datum
);
2063 /* Now that the scavenging is done, repair the various interior
2065 FIXUP_INTERIOR_POINTER(pc
);
2067 FIXUP_INTERIOR_POINTER(lip
);
2069 #ifdef ARCH_HAS_LINK_REGISTER
2070 FIXUP_INTERIOR_POINTER(lr
);
2072 #ifdef ARCH_HAS_NPC_REGISTER
2073 FIXUP_INTERIOR_POINTER(npc
);
2075 #ifdef LISP_FEATURE_PPC
2076 FIXUP_INTERIOR_POINTER(ctr
);
2081 scavenge_interrupt_contexts(struct thread
*th
)
2084 os_context_t
*context
;
2086 index
= fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
2088 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2089 printf("Number of active contexts: %d\n", index
);
2092 for (i
= 0; i
< index
; i
++) {
2093 context
= th
->interrupt_contexts
[i
];
2094 scavenge_interrupt_context(context
);
2097 #endif /* x86oid targets */
2099 void varint_unpacker_init(struct varint_unpacker
* unpacker
, lispobj integer
)
2101 if (fixnump(integer
)) {
2102 unpacker
->word
= fixnum_value(integer
);
2103 unpacker
->limit
= N_WORD_BYTES
;
2104 unpacker
->data
= (char*)&unpacker
->word
;
2106 struct bignum
* bignum
= (struct bignum
*)(integer
- OTHER_POINTER_LOWTAG
);
2108 unpacker
->limit
= HeaderValue(bignum
->header
) * N_WORD_BYTES
;
2109 unpacker
->data
= (char*)bignum
->digits
;
2111 unpacker
->index
= 0;
2114 // Fetch the next varint from 'unpacker' into 'result'.
2115 // Because there is no length prefix on the number of varints encoded,
2116 // spurious trailing zeros might be observed. The data consumer can
2117 // circumvent that by storing a count as the first value in the series.
2118 // Return 1 for success, 0 for EOF.
2119 int varint_unpack(struct varint_unpacker
* unpacker
, int* result
)
2121 if (unpacker
->index
>= unpacker
->limit
) return 0;
2122 int accumulator
= 0;
2125 #ifdef LISP_FEATURE_LITTLE_ENDIAN
2126 int byte
= unpacker
->data
[unpacker
->index
];
2128 // bignums are little-endian in word order,
2129 // but machine-native within each word.
2130 // We could pack bytes MSB-to-LSB in the bigdigits,
2131 // but that seems less intuitive on the Lisp side.
2132 int word_index
= unpacker
->index
/ N_WORD_BYTES
;
2133 int byte_index
= unpacker
->index
% N_WORD_BYTES
;
2134 int byte
= (((unsigned int*)unpacker
->data
)[word_index
]
2135 >> (byte_index
* 8)) & 0xFF;
2138 accumulator
|= (byte
& 0x7F) << shift
;
2139 if (!(byte
& 0x80)) break;
2140 gc_assert(unpacker
->index
< unpacker
->limit
);
2143 *result
= accumulator
;
2147 /* Our own implementation of heapsort, because some C libraries have a qsort()
2148 * that calls malloc() apparently, which we MUST NOT do. */
2150 typedef uword_t
* heap
;
2152 #define swap(a,i,j) { uword_t temp=a[i];a[i]=a[j];a[j]=temp; }
2153 static void sift_down(heap array
, int start
, int end
)
2156 while (root
* 2 + 1 <= end
) {
2157 int child
= root
* 2 + 1;
2158 if (child
+ 1 <= end
&& array
[child
] < array
[child
+1])
2160 if (array
[root
] < array
[child
]) {
2161 swap(array
, root
, child
);
2169 static void heapify(heap array
, int length
)
2171 int start
= (length
- 2) / 2;
2172 while (start
>= 0) {
2173 sift_down(array
, start
, length
-1);
2178 void gc_heapsort_uwords(heap array
, int length
)
2180 heapify(array
, length
);
2181 int end
= length
- 1;
2183 swap(array
, end
, 0);
2185 sift_down(array
, 0, end
);