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 "genesis/primitive-objects.h"
42 #include "genesis/static-symbols.h"
43 #include "genesis/layout.h"
44 #include "genesis/hash-table.h"
45 #define WANT_SCAV_TRANS_SIZE_TABLES
46 #include "gc-internal.h"
47 #include "forwarding-ptr.h"
50 #ifdef LISP_FEATURE_SPARC
51 #define LONG_FLOAT_SIZE 4
52 #elif defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
53 #define LONG_FLOAT_SIZE 3
56 os_vm_size_t dynamic_space_size
= DEFAULT_DYNAMIC_SPACE_SIZE
;
57 os_vm_size_t thread_control_stack_size
= DEFAULT_CONTROL_STACK_SIZE
;
59 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
60 lispobj (*transother
[256])(lispobj object
);
61 sword_t (*sizetab
[256])(lispobj
*where
);
62 struct weak_pointer
*weak_pointers
;
64 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
66 /// These sizing macros return the number of *payload* words,
67 /// exclusive of the object header word. Payload length is always
68 /// an odd number so that total word count is an even number.
69 #define BOXED_NWORDS(obj) (HeaderValue(obj) | 1)
70 // Payload count expressed in 15 bits
71 #define SHORT_BOXED_NWORDS(obj) ((HeaderValue(obj) & SHORT_HEADER_MAX_WORDS) | 1)
72 // Payload count expressed in 8 bits
73 #define TINY_BOXED_NWORDS(obj) ((HeaderValue(obj) & 0xFF) | 1)
79 /* gc_general_copy_object is inline from gc-internal.h */
81 /* to copy a boxed object */
83 copy_object(lispobj object
, sword_t nwords
)
85 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
88 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
90 static inline void scav1(lispobj
* object_ptr
, lispobj object
)
93 // * With 32-bit words, is_lisp_pointer(object) returns true if object_ptr
94 // points to a forwarding pointer, so we need a sanity check inside the
95 // branch for is_lisp_pointer(). For maximum efficiency, check that only
96 // after from_space_p() returns false, so that valid pointers into
97 // from_space incur no extra test. This could be improved further by
98 // skipping the FP check if 'object' points within dynamic space, i.e.,
99 // when find_page_index() returns >= 0. That would entail injecting
100 // from_space_p() explicitly into the loop, so as to separate the
101 // "was a page found at all" condition from the page generation test.
103 // * With 64-bit words, is_lisp_pointer(object) is false when object_ptr
104 // points to a forwarding pointer, and the fixnump() test also returns
105 // false, so we'll indirect through scavtab[]. This will safely invoke
106 // scav_lose(), detecting corruption without any extra cost.
107 // The major difference between that and the explicit test is that you
108 // won't see 'start' and 'n_words', but if you need those, chances are
109 // you'll want to run under an external debugger in the first place.
110 // [And btw it sure would be nice to assert statically
111 // that is_lisp_pointer(0x01) is indeed false]
113 #define FIX_POINTER() { \
114 lispobj *ptr = native_pointer(object); \
115 if (forwarding_pointer_p(ptr)) \
116 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); \
117 else /* Scavenge that pointer. */ \
118 (void)scavtab[widetag_of(object)](object_ptr, object); \
120 #ifdef LISP_FEATURE_IMMOBILE_SPACE
122 // It would be fine, though suboptimal, to use from_space_p() here.
123 // If it returns false, we don't want to call immobile_space_p()
124 // unless the pointer is *not* into dynamic space.
125 if ((page
= find_page_index((void*)object
)) >= 0) {
126 if (page_table
[page
].gen
== from_space
&& !pinned_p(object
, page
))
128 } else if (immobile_space_p(object
)) {
129 lispobj
*ptr
= native_pointer(object
);
130 if (immobile_obj_gen_bits(ptr
) == from_space
)
131 promote_immobile_obj(ptr
, 1);
134 if (from_space_p(object
)) {
137 #if (N_WORD_BITS == 32) && defined(LISP_FEATURE_GENCGC)
138 if (forwarding_pointer_p(object_ptr
))
139 lose("unexpected forwarding pointer in scavenge @ %p\n",
142 /* It points somewhere other than oldspace. Leave it
148 // Scavenge a block of memory from 'start' to 'end'
149 // that may contain object headers.
150 void heap_scavenge(lispobj
*start
, lispobj
*end
)
154 for (object_ptr
= start
; object_ptr
< end
;) {
155 lispobj object
= *object_ptr
;
156 if (other_immediate_lowtag_p(object
))
157 /* It's some sort of header object or another. */
158 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
159 else { // it's a cons
160 if (is_lisp_pointer(object
))
161 scav1(object_ptr
, object
);
162 object
= *++object_ptr
;
163 if (is_lisp_pointer(object
))
164 scav1(object_ptr
, object
);
168 // This assertion is usually the one that fails when something
169 // is subtly wrong with the heap, so definitely always do it.
170 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
171 object_ptr
, start
, end
);
174 // Scavenge a block of memory from 'start' extending for 'n_words'
175 // that must not contain any object headers.
176 sword_t
scavenge(lispobj
*start
, sword_t n_words
)
178 lispobj
*end
= start
+ n_words
;
180 for (object_ptr
= start
; object_ptr
< end
; object_ptr
++) {
181 lispobj object
= *object_ptr
;
182 if (is_lisp_pointer(object
)) scav1(object_ptr
, object
);
187 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
188 static lispobj
trans_short_boxed(lispobj object
);
191 scav_fun_pointer(lispobj
*where
, lispobj object
)
193 gc_dcheck(lowtag_of(object
) == FUN_POINTER_LOWTAG
);
195 /* Object is a pointer into from_space - not a FP. */
196 lispobj
*first_pointer
= native_pointer(object
);
198 /* must transport object -- object may point to either a function
199 * header, a funcallable instance header, or a closure header. */
200 lispobj copy
= widetag_of(*first_pointer
) == SIMPLE_FUN_WIDETAG
201 ? trans_fun_header(object
) : trans_short_boxed(object
);
203 if (copy
!= object
) {
204 /* Set forwarding pointer */
205 set_forwarding_pointer(first_pointer
,copy
);
208 CHECK_COPY_POSTCONDITIONS(copy
, FUN_POINTER_LOWTAG
);
217 trans_code(struct code
*code
)
219 /* if object has already been transported, just return pointer */
220 if (forwarding_pointer_p((lispobj
*)code
)) {
222 printf("Was already transported\n");
224 return (struct code
*)native_pointer(forwarding_pointer_value((lispobj
*)code
));
227 gc_dcheck(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
229 /* prepare to transport the code vector */
230 lispobj l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
231 sword_t nheader_words
= code_header_words(code
->header
);
232 sword_t ncode_words
= code_instruction_words(code
->code_size
);
233 sword_t nwords
= nheader_words
+ ncode_words
;
234 lispobj l_new_code
= gc_general_copy_object(l_code
, nwords
, CODE_PAGE_FLAG
);
235 struct code
*new_code
= (struct code
*) native_pointer(l_new_code
);
237 #if defined(DEBUG_CODE_GC)
238 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
239 (uword_t
) code
, (uword_t
) new_code
);
240 printf("Code object is %d words long.\n", nwords
);
243 #ifdef LISP_FEATURE_GENCGC
244 if (new_code
== code
)
248 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
250 /* set forwarding pointers for all the function headers in the */
251 /* code object. also fix all self pointers */
252 /* Do this by scanning the new code, since the old header is unusable */
254 uword_t displacement
= l_new_code
- l_code
;
256 for_each_simple_fun(i
, nfheaderp
, new_code
, 1, {
257 /* Calculate the old raw function pointer */
258 struct simple_fun
* fheaderp
=
259 (struct simple_fun
*)LOW_WORD((char*)nfheaderp
- displacement
);
260 /* Calculate the new lispobj */
261 lispobj nfheaderl
= make_lispobj(nfheaderp
, FUN_POINTER_LOWTAG
);
264 printf("fheaderp->header (at %x) <- %x\n",
265 &(fheaderp
->header
) , nfheaderl
);
267 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
269 /* fix self pointer. */
271 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
272 FUN_RAW_ADDR_OFFSET
+
276 #ifdef LISP_FEATURE_GENCGC
277 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
278 spaces once when all copying is done. */
279 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
280 ncode_words
* sizeof(sword_t
));
284 #ifdef LISP_FEATURE_X86
285 gencgc_apply_code_fixups(code
, new_code
);
292 scav_code_header(lispobj
*where
, lispobj header
)
294 struct code
*code
= (struct code
*) where
;
295 sword_t n_header_words
= code_header_words(header
);
297 /* Scavenge the boxed section of the code data block. */
298 scavenge(where
+ 1, n_header_words
- 1);
300 /* Scavenge the boxed section of each function object in the
301 * code data block. */
302 for_each_simple_fun(i
, function_ptr
, code
, 1, {
303 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
304 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
307 return n_header_words
+ code_instruction_words(code
->code_size
);
311 trans_code_header(lispobj object
)
313 struct code
*ncode
= trans_code((struct code
*) native_pointer(object
));
314 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
318 size_code_header(lispobj
*where
)
320 return code_header_words(((struct code
*)where
)->header
)
321 + code_instruction_words(((struct code
*)where
)->code_size
);
324 #ifdef RETURN_PC_WIDETAG
326 scav_return_pc_header(lispobj
*where
, lispobj object
)
328 lose("attempted to scavenge a return PC header where=%p object=%#lx\n",
329 where
, (uword_t
) object
);
330 return 0; /* bogus return value to satisfy static type checking */
334 trans_return_pc_header(lispobj object
)
336 struct simple_fun
*return_pc
= (struct simple_fun
*) native_pointer(object
);
337 uword_t offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
339 /* Transport the whole code object */
340 struct code
*code
= (struct code
*) ((uword_t
) return_pc
- offset
);
341 struct code
*ncode
= trans_code(code
);
343 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
345 #endif /* RETURN_PC_WIDETAG */
347 /* On the 386, closures hold a pointer to the raw address instead of the
348 * function object, so we can use CALL [$FDEFN+const] to invoke
349 * the function without loading it into a register. Given that code
350 * objects don't move, we don't need to update anything, but we do
351 * have to figure out that the function is still live. */
353 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
355 scav_closure(lispobj
*where
, lispobj header
)
357 struct closure
*closure
= (struct closure
*)where
;
358 int payload_words
= SHORT_BOXED_NWORDS(header
);
359 lispobj fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
361 #ifdef LISP_FEATURE_GENCGC
362 /* The function may have moved so update the raw address. But
363 * don't write unnecessarily. */
364 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
365 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
367 // Payload includes 'fun' which was just looked at, so subtract it.
368 scavenge(closure
->info
, payload_words
- 1);
369 return 1 + payload_words
;
373 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
375 scav_fun_header(lispobj
*where
, lispobj object
)
377 lose("attempted to scavenge a function header where=%p object=%#lx\n",
378 where
, (uword_t
) object
);
379 return 0; /* bogus return value to satisfy static type checking */
381 #endif /* LISP_FEATURE_X86 */
384 trans_fun_header(lispobj object
)
386 struct simple_fun
*fheader
= (struct simple_fun
*) native_pointer(object
);
387 uword_t offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
389 /* Transport the whole code object */
390 struct code
*code
= (struct code
*) ((uword_t
) fheader
- offset
);
391 struct code
*ncode
= trans_code(code
);
393 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
402 trans_instance(lispobj object
)
404 gc_dcheck(lowtag_of(object
) == INSTANCE_POINTER_LOWTAG
);
405 lispobj header
= *(lispobj
*)(object
- INSTANCE_POINTER_LOWTAG
);
406 return copy_object(object
, 1 + (instance_length(header
)|1));
410 scav_instance_pointer(lispobj
*where
, lispobj object
)
412 /* Object is a pointer into from space - not a FP. */
413 lispobj copy
= trans_instance(object
);
415 gc_dcheck(copy
!= object
);
417 set_forwarding_pointer(native_pointer(object
), copy
);
428 static lispobj
trans_list(lispobj object
);
431 scav_list_pointer(lispobj
*where
, lispobj object
)
433 gc_dcheck(lowtag_of(object
) == LIST_POINTER_LOWTAG
);
435 lispobj copy
= trans_list(object
);
436 gc_dcheck(copy
!= object
);
438 CHECK_COPY_POSTCONDITIONS(copy
, LIST_POINTER_LOWTAG
);
446 trans_list(lispobj object
)
449 struct cons
*copy
= (struct cons
*)
450 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
451 lispobj new_list_pointer
= make_lispobj(copy
, LIST_POINTER_LOWTAG
);
452 copy
->car
= CONS(object
)->car
;
453 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
454 lispobj cdr
= CONS(object
)->cdr
;
455 set_forwarding_pointer((lispobj
*)CONS(object
), new_list_pointer
);
457 /* Try to linearize the list in the cdr direction to help reduce
459 while (lowtag_of(cdr
) == LIST_POINTER_LOWTAG
&& from_space_p(cdr
)) {
460 lispobj
* native_cdr
= (lispobj
*)CONS(cdr
);
461 if (forwarding_pointer_p(native_cdr
)) { // Might as well fix now.
462 cdr
= forwarding_pointer_value(native_cdr
);
466 struct cons
*cdr_copy
= (struct cons
*)
467 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
468 cdr_copy
->car
= ((struct cons
*)native_cdr
)->car
;
469 /* Grab the cdr before it is clobbered. */
470 lispobj next
= ((struct cons
*)native_cdr
)->cdr
;
471 /* Set cdr of the predecessor, and store an FP. */
472 set_forwarding_pointer(native_cdr
,
473 copy
->cdr
= make_lispobj(cdr_copy
,
474 LIST_POINTER_LOWTAG
));
479 return new_list_pointer
;
484 * scavenging and transporting other pointers
488 scav_other_pointer(lispobj
*where
, lispobj object
)
490 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
492 /* Object is a pointer into from space - not FP. */
493 lispobj
*first_pointer
= (lispobj
*)(object
- OTHER_POINTER_LOWTAG
);
494 lispobj copy
= transother
[widetag_of(*first_pointer
)](object
);
496 // If the object was large, then instead of transporting it,
497 // gencgc might simply promote the pages and return the same pointer.
498 // That decision is made in general_copy_large_object().
499 if (copy
!= object
) {
500 set_forwarding_pointer(first_pointer
, copy
);
501 #ifdef LISP_FEATURE_GENCGC
505 #ifndef LISP_FEATURE_GENCGC
508 CHECK_COPY_POSTCONDITIONS(copy
, OTHER_POINTER_LOWTAG
);
513 * immediate, boxed, and unboxed objects
516 /* The immediate object scavenger basically wants to be "scav_cons",
517 * and so returns 2. To see why it's right, observe that scavenge() will
518 * not invoke a scavtab entry on any object except for one satisfying
519 * is_lisp_pointer(). So if a scavtab[] function got here,
520 * then it must be via heap_scavenge(). But heap_scavenge() should only
521 * dispatch via scavtab[] if it thought it saw an object header.
522 * So why do we act like it saw a cons? Because conses can contain an
523 * immediate object that satisfies both other_immediate_lowtag_p()
524 * and is_lisp_immediate(), namely, the objects specifically mentioned at
525 * is_cons_half(). So heap_scavenge() is nearly testing is_cons_half()
526 * but even more efficiently, by ignoring the unusual immediate widetags
527 * until we get to scav_immediate.
529 * And just to hammer the point home: we won't blow past the end of a specific
530 * range of words when scavenging a binding or control stack or anything else,
531 * because scavenge() skips immediate objects all by itself,
532 * or rather it skips anything not satisfying is_lisp_pointer().
534 * As to the unbound marker, see rev. 09c78105eabc6bf2b339f421d4ed1df4678003db
535 * which says that we might see it in conses for reasons somewhat unknown.
538 scav_immediate(lispobj
*where
, lispobj object
)
541 if (is_lisp_pointer(object
)) scav1(where
, object
);
546 trans_immediate(lispobj object
)
548 lose("trying to transport an immediate\n");
549 return NIL
; /* bogus return value to satisfy static type checking */
553 size_immediate(lispobj
*where
)
558 static inline boolean
bignum_logbitp_inline(int index
, struct bignum
* bignum
)
560 int len
= HeaderValue(bignum
->header
);
561 int word_index
= index
/ N_WORD_BITS
;
562 int bit_index
= index
% N_WORD_BITS
;
563 return word_index
< len
? (bignum
->digits
[word_index
] >> bit_index
) & 1 : 0;
565 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
567 /* If the bignum in the layout has another pointer to it (besides the layout)
568 acting as a root, and which is scavenged first, then transporting the
569 bignum causes the layout to see a FP, as would copying an instance whose
570 layout that is. This is a nearly impossible scenario to create organically
571 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
572 except for a few things that would cause it to be pinned anyway,
573 such as it being kept in a local variable during structure manipulation.
574 See 'interleaved-raw.impure.lisp' for a way to trigger this */
575 if (forwarding_pointer_p((lispobj
*)bignum
)) {
576 lispobj forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
578 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
579 (void*)bignum
, (void*)forwarded
);
581 bignum
= (struct bignum
*)native_pointer(forwarded
);
583 return bignum_logbitp_inline(index
, bignum
);
586 // Helper function for stepping through the tagged slots of an instance in
587 // scav_instance and verify_space.
589 instance_scan(void (*proc
)(lispobj
*, sword_t
),
590 lispobj
*instance_slots
,
591 sword_t nslots
, /* number of payload words */
592 lispobj layout_bitmap
)
596 if (fixnump(layout_bitmap
)) {
597 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
598 for (index
= 0; index
< nslots
; index
++, bitmap
>>= 1)
600 proc(instance_slots
+ index
, 1);
601 } else { /* huge bitmap */
602 struct bignum
* bitmap
;
603 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
604 if (forwarding_pointer_p((lispobj
*)bitmap
))
605 bitmap
= (struct bignum
*)
606 native_pointer(forwarding_pointer_value((lispobj
*)bitmap
));
607 for (index
= 0; index
< nslots
; index
++)
608 if (bignum_logbitp_inline(index
, bitmap
))
609 proc(instance_slots
+ index
, 1);
614 scav_instance(lispobj
*where
, lispobj header
)
616 lispobj
* layout
= (lispobj
*)instance_layout(where
);
617 lispobj lbitmap
= make_fixnum(-1);
620 layout
= native_pointer((lispobj
)layout
);
621 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
622 if (__immobile_obj_gen_bits(layout
) == from_space
)
623 promote_immobile_obj(layout
, 1);
625 if (forwarding_pointer_p(layout
))
626 layout
= native_pointer(forwarding_pointer_value(layout
));
628 lbitmap
= ((struct layout
*)layout
)->bitmap
;
630 sword_t nslots
= instance_length(header
) | 1;
631 if (lbitmap
== make_fixnum(-1))
632 scavenge(where
+1, nslots
);
633 else if (!fixnump(lbitmap
))
634 instance_scan((void(*)(lispobj
*,sword_t
))scavenge
,
635 where
+1, nslots
, lbitmap
);
637 sword_t bitmap
= (sword_t
)lbitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
640 for ( ; n
-- ; bitmap
>>= 1) {
642 if ((bitmap
& 1) && is_lisp_pointer(obj
= *where
))
649 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
651 scav_funinstance(lispobj
*where
, lispobj header
)
653 // This works because the layout is in the header word of all instances,
654 // ordinary and funcallable, when compact headers are enabled.
655 // The trampoline slot in the funcallable-instance is raw, but can be
656 // scavenged, because it points to readonly space, never oldspace.
657 // (And for certain backends it looks like a fixnum, not a pointer)
658 return scav_instance(where
, header
);
662 //// Boxed object scav/trans/size functions
664 #define DEF_SCAV_BOXED(suffix, sizer) \
665 static sword_t __attribute__((unused)) \
666 scav_##suffix(lispobj *where, lispobj header) { \
667 return 1 + scavenge(where+1, sizer(header)); \
669 static lispobj trans_##suffix(lispobj object) { \
670 return copy_object(object, 1 + sizer(*native_pointer(object))); \
672 static sword_t size_##suffix(lispobj *where) { return 1 + sizer(*where); }
674 DEF_SCAV_BOXED(boxed
, BOXED_NWORDS
)
675 DEF_SCAV_BOXED(short_boxed
, SHORT_BOXED_NWORDS
)
676 DEF_SCAV_BOXED(tiny_boxed
, TINY_BOXED_NWORDS
)
678 /* Note: on the sparc we don't have to do anything special for fdefns, */
679 /* 'cause the raw-addr has a function lowtag. */
680 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
682 scav_fdefn(lispobj
*where
, lispobj object
)
684 struct fdefn
*fdefn
= (struct fdefn
*)where
;
686 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
687 fdefn->fun, fdefn->raw_addr)); */
689 scavenge(where
+ 1, 2); // 'name' and 'fun'
690 #ifndef LISP_FEATURE_IMMOBILE_CODE
691 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
692 if (raw_fun
> READ_ONLY_SPACE_END
) {
693 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
694 scavenge(&simple_fun
, 1);
695 /* Don't write unnecessarily. */
696 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
697 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
699 #elif defined(LISP_FEATURE_X86_64)
700 lispobj obj
= fdefn_raw_referent(fdefn
);
703 scavenge(&new, 1); // enliven
704 gc_dcheck(new == obj
); // must not move
707 # error "Need to implement scav_fdefn"
714 scav_unboxed(lispobj
*where
, lispobj object
)
716 sword_t length
= HeaderValue(object
) + 1;
717 return CEILING(length
, 2);
721 trans_unboxed(lispobj object
)
723 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
724 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
725 return copy_unboxed_object(object
, CEILING(length
, 2));
729 trans_ratio_or_complex(lispobj object
)
731 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
732 lispobj
* x
= native_pointer(object
);
736 /* A zero ratio or complex means it was just allocated by fixed-alloc and
737 a bignum can still be written there. Not a problem with a conservative GC
738 since it will be pinned down. */
739 if (fixnump(a
) && fixnump(b
)
740 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
745 return copy_unboxed_object(object
, 4);
747 return copy_object(object
, 4);
750 /* vector-like objects */
752 trans_vector(lispobj object
)
754 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
757 fixnum_value(((struct vector
*)native_pointer(object
))->length
);
758 return copy_large_object(object
, CEILING(length
+ 2, 2));
762 size_vector(lispobj
*where
)
764 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
765 return CEILING(length
+ 2, 2);
768 static inline uword_t
769 NWORDS(uword_t x
, uword_t n_bits
)
771 /* A good compiler should be able to constant-fold this whole thing,
772 even with the conditional. */
773 if(n_bits
<= N_WORD_BITS
) {
774 uword_t elements_per_word
= N_WORD_BITS
/n_bits
;
776 return CEILING(x
, elements_per_word
)/elements_per_word
;
779 /* FIXME: should have some sort of assertion that N_WORD_BITS
780 evenly divides n_bits */
781 return x
* (n_bits
/N_WORD_BITS
);
785 #define DEF_SCAV_TRANS_SIZE_UB(nbits) \
786 DEF_SPECIALIZED_VECTOR(vector_unsigned_byte_##nbits, NWORDS(length, nbits))
787 #define DEF_SPECIALIZED_VECTOR(name, nwords) \
788 static sword_t __attribute__((unused)) scav_##name(lispobj *where, lispobj header) { \
789 sword_t length = fixnum_value(((struct vector*)where)->length); \
790 return CEILING(nwords + 2, 2); \
792 static lispobj __attribute__((unused)) trans_##name(lispobj object) { \
793 gc_dcheck(lowtag_of(object) == OTHER_POINTER_LOWTAG); \
794 sword_t length = fixnum_value(((struct vector*)(object-OTHER_POINTER_LOWTAG))->length); \
795 return copy_large_unboxed_object(object, CEILING(nwords + 2, 2)); \
797 static sword_t __attribute__((unused)) size_##name(lispobj *where) { \
798 sword_t length = fixnum_value(((struct vector*)where)->length); \
799 return CEILING(nwords + 2, 2); \
802 DEF_SPECIALIZED_VECTOR(vector_nil
, 0*length
)
803 DEF_SPECIALIZED_VECTOR(vector_bit
, NWORDS(length
,1))
804 /* NOTE: strings contain one more element of data (a terminating '\0'
805 * to help interface with C functions) than indicated by the length slot.
806 * This is true even for UCS4 strings, despite that C APIs are unlikely
807 * to have a convention that expects 4 zero bytes. */
808 DEF_SPECIALIZED_VECTOR(base_string
, NWORDS((length
+1), 8))
809 DEF_SPECIALIZED_VECTOR(character_string
, NWORDS((length
+1), 32))
810 DEF_SCAV_TRANS_SIZE_UB(2)
811 DEF_SCAV_TRANS_SIZE_UB(4)
812 DEF_SCAV_TRANS_SIZE_UB(8)
813 DEF_SCAV_TRANS_SIZE_UB(16)
814 DEF_SCAV_TRANS_SIZE_UB(32)
815 DEF_SCAV_TRANS_SIZE_UB(64)
816 DEF_SCAV_TRANS_SIZE_UB(128)
817 #ifdef LONG_FLOAT_SIZE
818 DEF_SPECIALIZED_VECTOR(vector_long_float
, length
* LONG_FLOAT_SIZE
)
819 DEF_SPECIALIZED_VECTOR(vector_complex_long_float
, length
* (2 * LONG_FLOAT_SIZE
))
823 trans_weak_pointer(lispobj object
)
826 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
828 #if defined(DEBUG_WEAK)
829 printf("Transporting weak pointer from 0x%08x\n", object
);
832 /* Need to remember where all the weak pointers are that have */
833 /* been transported so they can be fixed up in a post-GC pass. */
835 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
836 #ifndef LISP_FEATURE_GENCGC
837 struct weak_pointer
*wp
= (struct weak_pointer
*) native_pointer(copy
);
839 gc_dcheck(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
840 /* Push the weak pointer onto the list of weak pointers. */
841 if (weak_pointer_breakable_p(wp
)) {
842 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
849 void scan_weak_pointers(void)
851 struct weak_pointer
*wp
, *next_wp
;
852 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
853 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
857 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
860 lispobj pointee
= wp
->value
;
861 gc_assert(is_lisp_pointer(pointee
));
862 lispobj
*objaddr
= native_pointer(pointee
);
864 /* Now, we need to check whether the object has been forwarded. If
865 * it has been, the weak pointer is still good and needs to be
866 * updated. Otherwise, the weak pointer needs to be broken. */
868 if (from_space_p(pointee
)) {
869 wp
->value
= forwarding_pointer_p(objaddr
) ?
870 LOW_WORD(forwarding_pointer_value(objaddr
)) : UNBOUND_MARKER_WIDETAG
;
872 #ifdef LISP_FEATURE_IMMOBILE_SPACE
873 else if (immobile_space_p(pointee
) &&
874 immobile_obj_gen_bits(objaddr
) == from_space
) {
875 wp
->value
= UNBOUND_MARKER_WIDETAG
;
879 lose("unbreakable pointer %p", wp
);
886 #if N_WORD_BITS == 32
887 #define EQ_HASH_MASK 0x1fffffff
888 #elif N_WORD_BITS == 64
889 #define EQ_HASH_MASK 0x1fffffffffffffff
892 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
893 * target-hash-table.lisp. */
894 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
896 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
897 * slot. Set to NULL at the end of a collection.
899 * This is not optimal because, when a table is tenured, it won't be
900 * processed automatically; only the yougest generation is GC'd by
901 * default. On the other hand, all applications will need an
902 * occasional full GC anyway, so it's not that bad either. */
903 struct hash_table
*weak_hash_tables
= NULL
;
905 /* Return true if OBJ has already survived the current GC. */
906 static inline int pointer_survived_gc_yet(lispobj obj
)
908 #ifdef LISP_FEATURE_CHENEYGC
909 // This is the most straightforward definition.
910 return (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
)));
912 /* Check for a pointer to dynamic space before considering immobile space.
913 Based on the relative size of the spaces, this should be a win because
914 if the object is in the dynamic space and not the 'from' generation
915 we don't want to test immobile_space_p() at all.
916 Additionally, pinned_p() is both more expensive and less likely than
917 forwarding_pointer_p(), so we want to reverse those conditions, which
918 would not be possible with pinned_p() buried inside from_space_p(). */
919 page_index_t page_index
= find_page_index((void*)obj
);
921 return page_table
[page_index
].gen
!= from_space
||
922 forwarding_pointer_p(native_pointer(obj
)) ||
923 pinned_p(obj
, page_index
);
924 #ifdef LISP_FEATURE_IMMOBILE_SPACE
925 if (immobile_space_p(obj
))
926 return immobile_obj_gen_bits(native_pointer(obj
)) != from_space
;
932 #ifdef EMPTY_HT_SLOT /* only if it's a static symbol */
933 // "ish" because EMPTY_HT_SLOT is of course a pointer.
934 # define ht_cell_nonpointerish(x) (!is_lisp_pointer(x) || x==EMPTY_HT_SLOT)
936 # define ht_cell_nonpointerish(x) !is_lisp_pointer(x)
939 static int survived_gc_yet_KEY(lispobj key
, lispobj value
) {
940 return ht_cell_nonpointerish(key
) || pointer_survived_gc_yet(key
);
942 static int survived_gc_yet_VALUE(lispobj key
, lispobj value
) {
943 return ht_cell_nonpointerish(value
) || pointer_survived_gc_yet(value
);
945 static int survived_gc_yet_AND(lispobj key
, lispobj value
) {
946 int key_nonpointer
= ht_cell_nonpointerish(key
);
947 int val_nonpointer
= ht_cell_nonpointerish(value
);
948 if (key_nonpointer
&& val_nonpointer
) return 1;
949 return (key_nonpointer
|| pointer_survived_gc_yet(key
))
950 && (val_nonpointer
|| pointer_survived_gc_yet(value
));
952 static int survived_gc_yet_OR(lispobj key
, lispobj value
) {
953 int key_nonpointer
= ht_cell_nonpointerish(key
);
954 int val_nonpointer
= ht_cell_nonpointerish(value
);
955 if (key_nonpointer
|| val_nonpointer
) return 1;
956 // Both MUST be pointers
957 return pointer_survived_gc_yet(key
) || pointer_survived_gc_yet(value
);
960 static int (*weak_hash_entry_alivep_fun(lispobj weakness
))(lispobj
,lispobj
)
963 case KEY
: return survived_gc_yet_KEY
;
964 case VALUE
: return survived_gc_yet_VALUE
;
965 case KEY_OR_VALUE
: return survived_gc_yet_OR
;
966 case KEY_AND_VALUE
: return survived_gc_yet_AND
;
967 case NIL
: return NULL
;
968 default: lose("Bad hash table weakness");
972 /* Return the beginning of data in ARRAY (skipping the header and the
973 * length) or NULL if it isn't an array of the specified widetag after
975 static inline lispobj
*
976 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
978 if (is_lisp_pointer(array
) && widetag_of(*native_pointer(array
)) == widetag
) {
980 *length
= fixnum_value(native_pointer(array
)[1]);
981 return native_pointer(array
) + 2;
987 /* Only need to worry about scavenging the _real_ entries in the
988 * table. Phantom entries such as the hash table itself at index 0 and
989 * the empty marker at index 1 were scavenged by scav_vector that
990 * either called this function directly or arranged for it to be
991 * called later by pushing the hash table onto weak_hash_tables. */
993 scav_hash_table_entries (struct hash_table
*hash_table
)
997 lispobj
*index_vector
;
999 lispobj
*next_vector
;
1000 uword_t next_vector_length
;
1001 lispobj
*hash_vector
;
1002 uword_t hash_vector_length
;
1003 lispobj empty_symbol
;
1004 lispobj weakness
= hash_table
->weakness
;
1007 kv_vector
= get_array_data(hash_table
->table
,
1008 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1009 if (kv_vector
== NULL
)
1010 lose("invalid kv_vector %x\n", hash_table
->table
);
1012 index_vector
= get_array_data(hash_table
->index_vector
,
1013 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1014 if (index_vector
== NULL
)
1015 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1017 next_vector
= get_array_data(hash_table
->next_vector
,
1018 SIMPLE_ARRAY_WORD_WIDETAG
,
1019 &next_vector_length
);
1020 if (next_vector
== NULL
)
1021 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1023 hash_vector
= get_array_data(hash_table
->hash_vector
,
1024 SIMPLE_ARRAY_WORD_WIDETAG
,
1025 &hash_vector_length
);
1026 if (hash_vector
!= NULL
)
1027 gc_assert(hash_vector_length
== next_vector_length
);
1029 /* These lengths could be different as the index_vector can be a
1030 * different length from the others, a larger index_vector could
1031 * help reduce collisions. */
1032 gc_assert(next_vector_length
*2 == kv_length
);
1034 empty_symbol
= kv_vector
[1];
1035 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1036 if (widetag_of(*native_pointer(empty_symbol
)) != SYMBOL_WIDETAG
) {
1037 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1038 *native_pointer(empty_symbol
));
1041 /* Work through the KV vector. */
1042 int (*alivep_test
)(lispobj
,lispobj
) = weak_hash_entry_alivep_fun(weakness
);
1043 #define SCAV_ENTRIES(aliveness_predicate) \
1044 for (i = 1; i < next_vector_length; i++) { \
1045 lispobj old_key = kv_vector[2*i]; \
1046 lispobj __attribute__((unused)) value = kv_vector[2*i+1]; \
1047 if (aliveness_predicate) { \
1048 /* Scavenge the key and value. */ \
1049 scavenge(&kv_vector[2*i], 2); \
1050 /* If an EQ-based key has moved, mark the hash-table for rehash */ \
1051 if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) { \
1052 lispobj new_key = kv_vector[2*i]; \
1053 if (old_key != new_key && new_key != empty_symbol) \
1054 hash_table->needs_rehash_p = T; \
1057 SCAV_ENTRIES(alivep_test(old_key
, value
))
1063 scav_vector (lispobj
*where
, lispobj object
)
1065 sword_t kv_length
= fixnum_value(where
[1]);
1066 struct hash_table
*hash_table
;
1068 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1069 * hash tables in the Lisp HASH-TABLE code to indicate need for
1070 * special GC support. */
1071 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
) {
1073 scavenge(where
+ 2, kv_length
);
1074 return CEILING(kv_length
+ 2, 2);
1077 /* Scavenge element 0, which may be a hash-table structure. */
1078 scavenge(where
+2, 1);
1079 if (!is_lisp_pointer(where
[2])) {
1080 /* This'll happen when REHASH clears the header of old-kv-vector
1081 * and fills it with zero, but some other thread simulatenously
1082 * sets the header in %%PUTHASH.
1085 "Warning: no pointer at %p in hash table: this indicates "
1086 "non-fatal corruption caused by concurrent access to a "
1087 "hash-table from multiple threads. Any accesses to "
1088 "hash-tables shared between threads should be protected "
1089 "by locks.\n", (void*)&where
[2]);
1092 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1093 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1094 if (widetag_of(hash_table
->header
) != INSTANCE_WIDETAG
) {
1095 lose("hash table not instance (%x at %x)\n",
1100 /* Scavenge element 1, which should be some internal symbol that
1101 * the hash table code reserves for marking empty slots. */
1102 scavenge(where
+3, 1);
1103 if (!is_lisp_pointer(where
[3])) {
1104 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1107 /* Scavenge hash table, which will fix the positions of the other
1108 * needed objects. */
1109 scav_instance((lispobj
*)hash_table
, hash_table
->header
);
1111 /* Cross-check the kv_vector. */
1112 if (where
!= native_pointer(hash_table
->table
)) {
1113 lose("hash_table table!=this table %x\n", hash_table
->table
);
1116 if (hash_table
->weakness
== NIL
) {
1117 scav_hash_table_entries(hash_table
);
1119 /* Delay scavenging of this table by pushing it onto
1120 * weak_hash_tables (if it's not there already) for the weak
1122 if (hash_table
->next_weak_hash_table
== NIL
) {
1123 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1124 weak_hash_tables
= hash_table
;
1128 return (CEILING(kv_length
+ 2, 2));
1132 scav_weak_hash_tables (void)
1134 struct hash_table
*table
;
1136 /* Scavenge entries whose triggers are known to survive. */
1137 for (table
= weak_hash_tables
; table
!= NULL
;
1138 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1139 scav_hash_table_entries(table
);
1143 /* Walk through the chain whose first element is *FIRST and remove
1144 * dead weak entries. */
1146 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1147 lispobj
*kv_vector
, lispobj
*index_vector
,
1148 lispobj
*next_vector
, lispobj
*hash_vector
,
1149 lispobj empty_symbol
, int (*alivep_test
)(lispobj
,lispobj
))
1151 unsigned index
= *prev
;
1153 unsigned next
= next_vector
[index
];
1154 lispobj key
= kv_vector
[2 * index
];
1155 lispobj value
= kv_vector
[2 * index
+ 1];
1156 gc_assert(key
!= empty_symbol
);
1157 gc_assert(value
!= empty_symbol
);
1158 if (!alivep_test(key
, value
)) {
1159 unsigned count
= fixnum_value(hash_table
->number_entries
);
1160 gc_assert(count
> 0);
1162 hash_table
->number_entries
= make_fixnum(count
- 1);
1163 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1164 hash_table
->next_free_kv
= make_fixnum(index
);
1165 kv_vector
[2 * index
] = empty_symbol
;
1166 kv_vector
[2 * index
+ 1] = empty_symbol
;
1168 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1170 prev
= &next_vector
[index
];
1177 scan_weak_hash_table (struct hash_table
*hash_table
)
1180 lispobj
*index_vector
;
1181 uword_t length
= 0; /* prevent warning */
1182 lispobj
*next_vector
;
1183 uword_t next_vector_length
= 0; /* prevent warning */
1184 lispobj
*hash_vector
;
1185 lispobj empty_symbol
;
1186 lispobj weakness
= hash_table
->weakness
;
1189 kv_vector
= get_array_data(hash_table
->table
,
1190 SIMPLE_VECTOR_WIDETAG
, NULL
);
1191 index_vector
= get_array_data(hash_table
->index_vector
,
1192 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1193 next_vector
= get_array_data(hash_table
->next_vector
,
1194 SIMPLE_ARRAY_WORD_WIDETAG
,
1195 &next_vector_length
);
1196 hash_vector
= get_array_data(hash_table
->hash_vector
,
1197 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1198 empty_symbol
= kv_vector
[1];
1200 for (i
= 0; i
< length
; i
++) {
1201 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
1202 kv_vector
, index_vector
, next_vector
,
1203 hash_vector
, empty_symbol
,
1204 weak_hash_entry_alivep_fun(weakness
));
1208 /* Remove dead entries from weak hash tables. */
1210 scan_weak_hash_tables (void)
1212 struct hash_table
*table
, *next
;
1214 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1215 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1216 table
->next_weak_hash_table
= NIL
;
1217 scan_weak_hash_table(table
);
1220 weak_hash_tables
= NULL
;
1229 scav_lose(lispobj
*where
, lispobj object
)
1231 lose("no scavenge function for object %p (widetag 0x%x)\n",
1233 widetag_of(*where
));
1235 return 0; /* bogus return value to satisfy static type checking */
1239 trans_lose(lispobj object
)
1241 lose("no transport function for object %p (widetag 0x%x)\n",
1243 widetag_of(*native_pointer(object
)));
1244 return NIL
; /* bogus return value to satisfy static type checking */
1248 size_lose(lispobj
*where
)
1250 lose("no size function for object at %p (widetag 0x%x)\n",
1252 widetag_of(*where
));
1253 return 1; /* bogus return value to satisfy static type checking */
1261 #include "genesis/gc-tables.h"
1264 static lispobj
*search_spaces(void *pointer
)
1267 if (((start
= search_dynamic_space(pointer
)) != NULL
) ||
1268 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1269 ((start
= search_immobile_space(pointer
)) != NULL
) ||
1271 ((start
= search_static_space(pointer
)) != NULL
) ||
1272 ((start
= search_read_only_space(pointer
)) != NULL
))
1277 /* Find the code object for the given pc, or return NULL on
1280 component_ptr_from_pc(lispobj
*pc
)
1282 lispobj
*object
= search_spaces(pc
);
1284 if (object
!= NULL
&& widetag_of(*object
) == CODE_HEADER_WIDETAG
)
1290 /* Scan an area looking for an object which encloses the given pointer.
1291 * Return the object start on success, or NULL on failure. */
1293 gc_search_space3(void *pointer
, lispobj
*start
, void *limit
)
1295 if (pointer
< (void*)start
|| pointer
>= limit
) return NULL
;
1299 /* CAUTION: this code is _significantly_ slower than the production version
1300 due to the extra checks for forwarding. Only use it if debugging */
1301 for ( ; (void*)start
< limit
; start
+= count
) {
1302 lispobj
*forwarded_start
;
1303 if (forwarding_pointer_p(start
))
1304 forwarded_start
= native_pointer(forwarding_pointer_value(start
));
1306 forwarded_start
= start
;
1307 lispobj thing
= *forwarded_start
;
1308 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](forwarded_start
);
1309 /* Check whether the pointer is within this object. */
1310 if (pointer
< (void*)(start
+count
)) return start
;
1313 for ( ; (void*)start
< limit
; start
+= count
) {
1314 lispobj thing
= *start
;
1315 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](start
);
1316 /* Check whether the pointer is within this object. */
1317 if (pointer
< (void*)(start
+count
)) return start
;
1323 /* Helper for valid_lisp_pointer_p (below) and
1324 * conservative_root_p (gencgc).
1326 * pointer is the pointer to check validity of,
1327 * and start_addr is the address of the enclosing object.
1329 * This is actually quite simple to check: because the heap state is assumed
1330 * consistent, and 'start_addr' is known good, having come from
1331 * gc_search_space(), only the 'pointer' argument is dubious.
1332 * So make 'start_addr' into a tagged pointer and see if that matches 'pointer'.
1333 * If it does, then 'pointer' is valid.
1336 properly_tagged_p_internal(lispobj pointer
, lispobj
*start_addr
)
1338 // If a headerless object, confirm that 'pointer' is a list pointer.
1339 // Given the precondition that the heap is in a valid state,
1340 // it may be assumed that one check of is_cons_half() suffices;
1341 // we don't need to check the other half.
1342 lispobj header
= *start_addr
;
1343 if (is_cons_half(header
))
1344 return make_lispobj(start_addr
, LIST_POINTER_LOWTAG
) == pointer
;
1346 // Because this heap object was not deemed to be a cons,
1347 // it must be an object header. Don't need a check except when paranoid.
1348 gc_dcheck(other_immediate_lowtag_p(header
));
1350 // The space of potential widetags has 64 elements, not 256,
1351 // because of the constant low 2 bits.
1352 int widetag
= widetag_of(header
);
1353 int lowtag
= lowtag_for_widetag
[widetag
>>2];
1354 if (lowtag
&& make_lispobj(start_addr
, lowtag
) == pointer
)
1355 return 1; // instant win
1357 if (widetag
== CODE_HEADER_WIDETAG
) {
1358 // Check for RETURN_PC_HEADER first since it's quicker.
1359 // Then consider the embedded simple-funs.
1360 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1361 /* The all-architecture test below is good as far as it goes,
1362 * but an LRA object is similar to a FUN-POINTER: It is
1363 * embedded within a CODE-OBJECT pointed to by start_addr, and
1364 * cannot be found by simply walking the heap, therefore we
1365 * need to check for it. -- AB, 2010-Jun-04 */
1366 if (lowtag_of(pointer
) == OTHER_POINTER_LOWTAG
) {
1367 lispobj
*potential_lra
= native_pointer(pointer
);
1368 if ((widetag_of(potential_lra
[0]) == RETURN_PC_WIDETAG
) &&
1369 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
1370 return 1; /* It's as good as we can verify. */
1374 if (lowtag_of(pointer
) == FUN_POINTER_LOWTAG
) {
1375 struct simple_fun
*pfun
=
1376 (struct simple_fun
*)(pointer
-FUN_POINTER_LOWTAG
);
1377 for_each_simple_fun(i
, function
, (struct code
*)start_addr
, 0, {
1378 if (pfun
== function
) return 1;
1382 return 0; // no good
1385 /* META: Note the ambiguous word "validate" in the comment below.
1386 * This means "Decide whether <x> is valid".
1387 * But when you see os_validate() elsewhere, that doesn't mean to ask
1388 * whether something is valid, it says to *make* it valid.
1389 * I think it would be nice if we could avoid using the word in the
1390 * sense in which os_validate() uses it, which would entail renaming
1391 * a bunch of stuff, which is harder than just explaining why
1392 * the comments can be deceptive */
1394 /* Used by the debugger to validate possibly bogus pointers before
1395 * calling MAKE-LISP-OBJ on them.
1397 * FIXME: We would like to make this perfect, because if the debugger
1398 * constructs a reference to a bugs lisp object, and it ends up in a
1399 * location scavenged by the GC all hell breaks loose.
1401 * Whereas conservative_root_p has to be conservative
1402 * and return true for all valid pointers, this could actually be eager
1403 * and lie about a few pointers without bad results... but that should
1404 * be reflected in the name.
1407 valid_lisp_pointer_p(lispobj pointer
)
1409 lispobj
*start
= search_spaces((void*)pointer
);
1411 return properly_tagged_descriptor_p((void*)pointer
, start
);
1416 maybe_gc(os_context_t
*context
)
1418 lispobj gc_happened
;
1419 struct thread
*thread
= arch_os_get_current_thread();
1420 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
1423 fake_foreign_function_call(context
);
1426 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
1427 * which case we will be running with no gc trigger barrier
1428 * thing for a while. But it shouldn't be long until the end
1431 * FIXME: It would be good to protect the end of dynamic space for
1432 * CheneyGC and signal a storage condition from there.
1435 /* Restore the signal mask from the interrupted context before
1436 * calling into Lisp if interrupts are enabled. Why not always?
1438 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
1439 * interrupt hits while in SUB-GC, it is deferred and the
1440 * os_context_sigmask of that interrupt is set to block further
1441 * deferrable interrupts (until the first one is
1442 * handled). Unfortunately, that context refers to this place and
1443 * when we return from here the signals will not be blocked.
1445 * A kludgy alternative is to propagate the sigmask change to the
1448 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
1449 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
1450 unblock_gc_signals(0, 0);
1452 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
1453 /* FIXME: Nothing must go wrong during GC else we end up running
1454 * the debugger, error handlers, and user code in general in a
1455 * potentially unsafe place. Running out of the control stack or
1456 * the heap in SUB-GC are ways to lose. Of course, deferrables
1457 * cannot be unblocked because there may be a pending handler, or
1458 * we may even be in a WITHOUT-INTERRUPTS. */
1459 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
1460 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
1461 (gc_happened
== NIL
)
1463 : ((gc_happened
== T
)
1466 /* gc_happened can take three values: T, NIL, 0.
1468 * T means that the thread managed to trigger a GC, and post-gc
1471 * NIL means that the thread is within without-gcing, and no GC
1474 * Finally, 0 means that *a* GC has occurred, but it wasn't
1475 * triggered by this thread; success, but post-gc doesn't have
1478 if ((gc_happened
== T
) &&
1479 /* See if interrupts are enabled or it's possible to enable
1480 * them. POST-GC has a similar check, but we don't want to
1481 * unlock deferrables in that case and get a pending interrupt
1483 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
1484 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
1485 #ifndef LISP_FEATURE_WIN32
1486 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
1487 if (!deferrables_blocked_p(context_sigmask
)) {
1488 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
1489 #ifndef LISP_FEATURE_SB_SAFEPOINT
1490 check_gc_signals_unblocked_or_lose(0);
1493 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
1494 funcall0(StaticSymbolFunction(POST_GC
));
1495 #ifndef LISP_FEATURE_WIN32
1497 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
1503 undo_fake_foreign_function_call(context
);
1505 /* Otherwise done by undo_fake_foreign_function_call. And
1506 something later wants them to be blocked. What a nice
1508 block_blockable_signals(0);
1511 FSHOW((stderr
, "/maybe_gc: returning\n"));
1512 return (gc_happened
!= NIL
);
1515 #define BYTES_ZERO_BEFORE_END (1<<12)
1517 /* There used to be a similar function called SCRUB-CONTROL-STACK in
1518 * Lisp and another called zero_stack() in cheneygc.c, but since it's
1519 * shorter to express in, and more often called from C, I keep only
1520 * the C one after fixing it. -- MG 2009-03-25 */
1522 /* Zero the unused portion of the control stack so that old objects
1523 * are not kept alive because of uninitialized stack variables.
1525 * "To summarize the problem, since not all allocated stack frame
1526 * slots are guaranteed to be written by the time you call an another
1527 * function or GC, there may be garbage pointers retained in your dead
1528 * stack locations. The stack scrubbing only affects the part of the
1529 * stack from the SP to the end of the allocated stack." - ram, on
1530 * cmucl-imp, Tue, 25 Sep 2001
1532 * So, as an (admittedly lame) workaround, from time to time we call
1533 * scrub-control-stack to zero out all the unused portion. This is
1534 * supposed to happen when the stack is mostly empty, so that we have
1535 * a chance of clearing more of it: callers are currently (2002.07.18)
1536 * REPL, SUB-GC and sig_stop_for_gc_handler. */
1538 /* Take care not to tread on the guard page and the hard guard page as
1539 * it would be unkind to sig_stop_for_gc_handler. Touching the return
1540 * guard page is not dangerous. For this to work the guard page must
1541 * be zeroed when protected. */
1543 /* FIXME: I think there is no guarantee that once
1544 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
1545 * may be what the "lame" adjective in the above comment is for. In
1546 * this case, exact gc may lose badly. */
1548 scrub_control_stack()
1550 scrub_thread_control_stack(arch_os_get_current_thread());
1554 scrub_thread_control_stack(struct thread
*th
)
1556 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
1557 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
1558 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1559 /* On these targets scrubbing from C is a bad idea, so we punt to
1560 * a routine in $ARCH-assem.S. */
1561 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
1562 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
1564 lispobj
*sp
= access_control_stack_pointer(th
);
1566 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
1567 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
1568 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
1569 ((os_vm_address_t
)sp
>= guard_page_address
) &&
1570 (th
->control_stack_guard_page_protected
!= NIL
)))
1572 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
1575 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1576 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
1581 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1585 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1586 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
1591 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1593 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
1596 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1599 scavenge_control_stack(struct thread
*th
)
1601 lispobj
*object_ptr
;
1603 /* In order to properly support dynamic-extent allocation of
1604 * non-CONS objects, the control stack requires special handling.
1605 * Rather than calling scavenge() directly, grovel over it fixing
1606 * broken hearts, scavenging pointers to oldspace, and pitching a
1607 * fit when encountering unboxed data. This prevents stray object
1608 * headers from causing the scavenger to blow past the end of the
1609 * stack (an error case checked in scavenge()). We don't worry
1610 * about treating unboxed words as boxed or vice versa, because
1611 * the compiler isn't allowed to store unboxed objects on the
1612 * control stack. -- AB, 2011-Dec-02 */
1614 for (object_ptr
= th
->control_stack_start
;
1615 object_ptr
< access_control_stack_pointer(th
);
1618 lispobj object
= *object_ptr
;
1619 #ifdef LISP_FEATURE_GENCGC
1620 if (forwarding_pointer_p(object_ptr
))
1621 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
1622 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
1624 if (is_lisp_pointer(object
) && from_space_p(object
)) {
1625 /* It currently points to old space. Check for a
1626 * forwarding pointer. */
1627 lispobj
*ptr
= native_pointer(object
);
1628 if (forwarding_pointer_p(ptr
)) {
1629 /* Yes, there's a forwarding pointer. */
1630 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
1632 /* Scavenge that pointer. */
1633 long n_words_scavenged
=
1634 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
1635 gc_assert(n_words_scavenged
== 1);
1637 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
1638 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
1639 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
1644 /* Scavenging Interrupt Contexts */
1646 static int boxed_registers
[] = BOXED_REGISTERS
;
1648 /* The GC has a notion of an "interior pointer" register, an unboxed
1649 * register that typically contains a pointer to inside an object
1650 * referenced by another pointer. The most obvious of these is the
1651 * program counter, although many compiler backends define a "Lisp
1652 * Interior Pointer" register known to the runtime as reg_LIP, and
1653 * various CPU architectures have other registers that also partake of
1654 * the interior-pointer nature. As the code for pairing an interior
1655 * pointer value up with its "base" register, and fixing it up after
1656 * scavenging is complete is horribly repetitive, a few macros paper
1657 * over the monotony. --AB, 2010-Jul-14 */
1659 /* These macros are only ever used over a lexical environment which
1660 * defines a pointer to an os_context_t called context, thus we don't
1661 * bother to pass that context in as a parameter. */
1663 /* Define how to access a given interior pointer. */
1664 #define ACCESS_INTERIOR_POINTER_pc \
1665 *os_context_pc_addr(context)
1666 #define ACCESS_INTERIOR_POINTER_lip \
1667 *os_context_register_addr(context, reg_LIP)
1668 #define ACCESS_INTERIOR_POINTER_lr \
1669 *os_context_lr_addr(context)
1670 #define ACCESS_INTERIOR_POINTER_npc \
1671 *os_context_npc_addr(context)
1672 #define ACCESS_INTERIOR_POINTER_ctr \
1673 *os_context_ctr_addr(context)
1675 #define INTERIOR_POINTER_VARS(name) \
1676 uword_t name##_offset; \
1677 int name##_register_pair
1679 #define PAIR_INTERIOR_POINTER(name) \
1680 pair_interior_pointer(context, \
1681 ACCESS_INTERIOR_POINTER_##name, \
1683 &name##_register_pair)
1685 /* One complexity here is that if a paired register is not found for
1686 * an interior pointer, then that pointer does not get updated.
1687 * Originally, there was some commentary about using an index of -1
1688 * when calling os_context_register_addr() on SPARC referring to the
1689 * program counter, but the real reason is to allow an interior
1690 * pointer register to point to the runtime, read-only space, or
1691 * static space without problems. */
1692 #define FIXUP_INTERIOR_POINTER(name) \
1694 if (name##_register_pair >= 0) { \
1695 ACCESS_INTERIOR_POINTER_##name = \
1696 (*os_context_register_addr(context, \
1697 name##_register_pair) \
1705 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
1706 uword_t
*saved_offset
, int *register_pair
)
1711 * I (RLT) think this is trying to find the boxed register that is
1712 * closest to the LIP address, without going past it. Usually, it's
1713 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
1715 /* 0x7FFFFFFF on 32-bit platforms;
1716 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
1717 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
1718 *register_pair
= -1;
1719 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1724 index
= boxed_registers
[i
];
1725 reg
= *os_context_register_addr(context
, index
);
1727 /* An interior pointer is never relative to a non-pointer
1728 * register (an oversight in the original implementation).
1729 * The simplest argument for why this is true is to consider
1730 * the fixnum that happens by coincide to be the word-index in
1731 * memory of the header for some object plus two. This is
1732 * happenstance would cause the register containing the fixnum
1733 * to be selected as the register_pair if the interior pointer
1734 * is to anywhere after the first two words of the object.
1735 * The fixnum won't be changed during GC, but the object might
1736 * move, thus destroying the interior pointer. --AB,
1739 if (is_lisp_pointer(reg
) &&
1740 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
1741 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
1742 if (offset
< *saved_offset
) {
1743 *saved_offset
= offset
;
1744 *register_pair
= index
;
1751 scavenge_interrupt_context(os_context_t
* context
)
1755 /* FIXME: The various #ifdef noise here is precisely that: noise.
1756 * Is it possible to fold it into the macrology so that we have
1757 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
1758 * compile out for the registers that don't exist on a given
1761 INTERIOR_POINTER_VARS(pc
);
1763 INTERIOR_POINTER_VARS(lip
);
1765 #ifdef ARCH_HAS_LINK_REGISTER
1766 INTERIOR_POINTER_VARS(lr
);
1768 #ifdef ARCH_HAS_NPC_REGISTER
1769 INTERIOR_POINTER_VARS(npc
);
1771 #ifdef LISP_FEATURE_PPC
1772 INTERIOR_POINTER_VARS(ctr
);
1775 PAIR_INTERIOR_POINTER(pc
);
1777 PAIR_INTERIOR_POINTER(lip
);
1779 #ifdef ARCH_HAS_LINK_REGISTER
1780 PAIR_INTERIOR_POINTER(lr
);
1782 #ifdef ARCH_HAS_NPC_REGISTER
1783 PAIR_INTERIOR_POINTER(npc
);
1785 #ifdef LISP_FEATURE_PPC
1786 PAIR_INTERIOR_POINTER(ctr
);
1789 /* Scavenge all boxed registers in the context. */
1790 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1791 os_context_register_t
*boxed_reg
;
1794 /* We can't "just" cast os_context_register_addr() to a
1795 * pointer to lispobj and pass it to scavenge, because some
1796 * systems can have a wider register width than we use for
1797 * lisp objects, and on big-endian systems casting a pointer
1798 * to a narrower target type doesn't work properly.
1799 * Therefore, we copy the value out to a temporary lispobj
1800 * variable, scavenge there, and copy the value back in.
1802 * FIXME: lispobj is unsigned, os_context_register_t may be
1803 * signed or unsigned, are we truncating or sign-extending
1804 * values here that shouldn't be modified? Possibly affects
1805 * any architecture that has 32-bit and 64-bit variants where
1806 * we run in 32-bit mode on 64-bit hardware when the OS is set
1807 * up for 64-bit from the start. Or an environment with
1808 * 32-bit addresses and 64-bit registers. */
1810 boxed_reg
= os_context_register_addr(context
, boxed_registers
[i
]);
1812 scavenge(&datum
, 1);
1816 /* Now that the scavenging is done, repair the various interior
1818 FIXUP_INTERIOR_POINTER(pc
);
1820 FIXUP_INTERIOR_POINTER(lip
);
1822 #ifdef ARCH_HAS_LINK_REGISTER
1823 FIXUP_INTERIOR_POINTER(lr
);
1825 #ifdef ARCH_HAS_NPC_REGISTER
1826 FIXUP_INTERIOR_POINTER(npc
);
1828 #ifdef LISP_FEATURE_PPC
1829 FIXUP_INTERIOR_POINTER(ctr
);
1834 scavenge_interrupt_contexts(struct thread
*th
)
1837 os_context_t
*context
;
1839 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
1841 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
1842 printf("Number of active contexts: %d\n", index
);
1845 for (i
= 0; i
< index
; i
++) {
1846 context
= th
->interrupt_contexts
[i
];
1847 scavenge_interrupt_context(context
);
1850 #endif /* x86oid targets */
1852 void varint_unpacker_init(struct varint_unpacker
* unpacker
, lispobj integer
)
1854 if (fixnump(integer
)) {
1855 unpacker
->word
= fixnum_value(integer
);
1856 unpacker
->limit
= N_WORD_BYTES
;
1857 unpacker
->data
= (char*)&unpacker
->word
;
1859 struct bignum
* bignum
= (struct bignum
*)(integer
- OTHER_POINTER_LOWTAG
);
1861 unpacker
->limit
= HeaderValue(bignum
->header
) * N_WORD_BYTES
;
1862 unpacker
->data
= (char*)bignum
->digits
;
1864 unpacker
->index
= 0;
1867 // Fetch the next varint from 'unpacker' into 'result'.
1868 // Because there is no length prefix on the number of varints encoded,
1869 // spurious trailing zeros might be observed. The data consumer can
1870 // circumvent that by storing a count as the first value in the series.
1871 // Return 1 for success, 0 for EOF.
1872 int varint_unpack(struct varint_unpacker
* unpacker
, int* result
)
1874 if (unpacker
->index
>= unpacker
->limit
) return 0;
1875 int accumulator
= 0;
1878 #ifdef LISP_FEATURE_LITTLE_ENDIAN
1879 int byte
= unpacker
->data
[unpacker
->index
];
1881 // bignums are little-endian in word order,
1882 // but machine-native within each word.
1883 // We could pack bytes MSB-to-LSB in the bigdigits,
1884 // but that seems less intuitive on the Lisp side.
1885 int word_index
= unpacker
->index
/ N_WORD_BYTES
;
1886 int byte_index
= unpacker
->index
% N_WORD_BYTES
;
1887 int byte
= (((unsigned int*)unpacker
->data
)[word_index
]
1888 >> (byte_index
* 8)) & 0xFF;
1891 accumulator
|= (byte
& 0x7F) << shift
;
1892 if (!(byte
& 0x80)) break;
1893 gc_assert(unpacker
->index
< unpacker
->limit
);
1896 *result
= accumulator
;
1900 /* Our own implementation of heapsort, because some C libraries have a qsort()
1901 * that calls malloc() apparently, which we MUST NOT do. */
1903 typedef uword_t
* heap
;
1905 #define swap(a,i,j) { uword_t temp=a[i];a[i]=a[j];a[j]=temp; }
1906 static void sift_down(heap array
, int start
, int end
)
1909 while (root
* 2 + 1 <= end
) {
1910 int child
= root
* 2 + 1;
1911 if (child
+ 1 <= end
&& array
[child
] < array
[child
+1])
1913 if (array
[root
] < array
[child
]) {
1914 swap(array
, root
, child
);
1922 static void heapify(heap array
, int length
)
1924 int start
= (length
- 2) / 2;
1925 while (start
>= 0) {
1926 sift_down(array
, start
, length
-1);
1931 void gc_heapsort_uwords(heap array
, int length
)
1933 heapify(array
, length
);
1934 int end
= length
- 1;
1936 swap(array
, end
, 0);
1938 sift_down(array
, 0, end
);
1942 //// Coalescing of constant strings for SAVE-LISP-AND-DIE
1944 static void remap_string(lispobj
* where
, struct hopscotch_table
* ht
)
1946 lispobj obj
= *where
;
1947 struct vector
* s
= (struct vector
*)native_pointer(obj
);
1948 extern char gc_coalesce_string_literals
;
1949 // gc_coalesce_string_literals represents the "aggressiveness" level.
1950 // If 1, then we share strings tagged as +STRING-SHAREABLE+,
1951 // but if >1, those and also +STRING-SHAREABLE-NONSTD+.
1952 int mask
= (gc_coalesce_string_literals
>1 ? 6 : 2)<<N_WIDETAG_BITS
;
1954 if (lowtag_of(obj
) == OTHER_POINTER_LOWTAG
&&
1955 (widetag_of(s
->header
) == SIMPLE_BASE_STRING_WIDETAG
1956 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1957 || widetag_of(s
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
1959 ) && (s
->header
& mask
) != 0) { /* shareable string */
1960 int index
= hopscotch_get(ht
, (uword_t
)s
, 0);
1961 if (!index
) // Not found
1962 hopscotch_insert(ht
, (uword_t
)s
, 1);
1964 *where
= make_lispobj((void*)ht
->keys
[index
-1], OTHER_POINTER_LOWTAG
);
1968 static uword_t
remap_strings(lispobj
* where
, lispobj
* limit
, uword_t arg
)
1970 struct hopscotch_table
* ht
= (struct hopscotch_table
*)arg
;
1971 lispobj layout
, bitmap
, *next
;
1972 sword_t nwords
, i
, j
;
1974 for ( ; where
< limit
; where
= next
) {
1975 lispobj header
= *where
;
1976 if (is_cons_half(header
)) {
1977 remap_string(where
+0, ht
);
1978 remap_string(where
+1, ht
);
1981 int widetag
= widetag_of(header
);
1982 nwords
= sizetab
[widetag
](where
);
1983 next
= where
+ nwords
;
1985 case INSTANCE_WIDETAG
: // mixed boxed/unboxed objects
1986 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
1987 case FUNCALLABLE_INSTANCE_WIDETAG
:
1989 layout
= instance_layout(where
);
1990 bitmap
= ((struct layout
*)native_pointer(layout
))->bitmap
;
1991 for(i
=1; i
<nwords
; ++i
)
1992 if (layout_bitmap_logbitp(i
-1, bitmap
))
1993 remap_string(where
+i
, ht
);
1995 case CODE_HEADER_WIDETAG
:
1996 for_each_simple_fun(i
, fun
, (struct code
*)where
, 0, {
1997 lispobj
* fun_slots
= SIMPLE_FUN_SCAV_START(fun
);
1998 for (j
=0; j
<SIMPLE_FUN_SCAV_NWORDS(fun
); ++j
)
1999 remap_string(fun_slots
+j
, ht
);
2001 nwords
= code_header_words(header
);
2004 if (unboxed_obj_widetag_p(widetag
))
2005 continue; // Ignore this object.
2007 for(i
=1; i
<nwords
; ++i
)
2008 remap_string(where
+i
, ht
);
2014 void coalesce_strings()
2016 struct hopscotch_table ht
;
2017 hopscotch_create(&ht
, HOPSCOTCH_STRING_HASH
, 0, 1<<17, 0);
2018 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2019 remap_strings((lispobj
*)IMMOBILE_SPACE_START
,
2020 (lispobj
*)SYMBOL(IMMOBILE_FIXEDOBJ_FREE_POINTER
)->value
,
2022 remap_strings((lispobj
*)IMMOBILE_VARYOBJ_SUBSPACE_START
,
2023 (lispobj
*)SYMBOL(IMMOBILE_SPACE_FREE_POINTER
)->value
,
2026 walk_generation(remap_strings
, -1, (uword_t
)&ht
);
2027 hopscotch_delete(&ht
);