2 * Garbage Collection common functions for scavenging, moving and sizing
3 * objects. These are for use with both GC (stop & copy GC) and GENCGC
7 * This software is part of the SBCL system. See the README file for
10 * This software is derived from the CMU CL system, which was
11 * written at Carnegie Mellon University and released into the
12 * public domain. The software is in the public domain and is
13 * provided with absolutely no warranty. See the COPYING and CREDITS
14 * files for more information.
18 * For a review of garbage collection techniques (e.g. generational
19 * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
20 * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
21 * had been accepted for _ACM Computing Surveys_ and was available
22 * as a PostScript preprint through
23 * <http://www.cs.utexas.edu/users/oops/papers.html>
25 * <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
28 #define _GNU_SOURCE /* for ffsl(3) from string.h */
38 #include "interrupt.h"
43 #include "genesis/primitive-objects.h"
44 #include "genesis/static-symbols.h"
45 #include "genesis/layout.h"
46 #include "genesis/hash-table.h"
47 #define WANT_SCAV_TRANS_SIZE_TABLES
48 #include "gc-internal.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 lispobj (*transother
[256])(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.
71 #define BOXED_NWORDS(obj) (HeaderValue(obj) | 1)
72 // Payload count expressed in 15 bits
73 #define SHORT_BOXED_NWORDS(obj) ((HeaderValue(obj) & SHORT_HEADER_MAX_WORDS) | 1)
74 // Payload count expressed in 8 bits
75 #define TINY_BOXED_NWORDS(obj) ((HeaderValue(obj) & 0xFF) | 1)
81 /* gc_general_copy_object is inline from gc-internal.h */
83 /* to copy a boxed object */
85 copy_object(lispobj object
, sword_t nwords
)
87 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
91 copy_code_object(lispobj object
, sword_t nwords
)
93 return gc_general_copy_object(object
, nwords
, CODE_PAGE_FLAG
);
96 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
98 static inline void scav1(lispobj
* object_ptr
, lispobj object
)
101 // * With 32-bit words, is_lisp_pointer(object) returns true if object_ptr
102 // points to a forwarding pointer, so we need a sanity check inside the
103 // branch for is_lisp_pointer(). For maximum efficiency, check that only
104 // after from_space_p() returns false, so that valid pointers into
105 // from_space incur no extra test. This could be improved further by
106 // skipping the FP check if 'object' points within dynamic space, i.e.,
107 // when find_page_index() returns >= 0. That would entail injecting
108 // from_space_p() explicitly into the loop, so as to separate the
109 // "was a page found at all" condition from the page generation test.
111 // * With 64-bit words, is_lisp_pointer(object) is false when object_ptr
112 // points to a forwarding pointer, and the fixnump() test also returns
113 // false, so we'll indirect through scavtab[]. This will safely invoke
114 // scav_lose(), detecting corruption without any extra cost.
115 // The major difference between that and the explicit test is that you
116 // won't see 'start' and 'n_words', but if you need those, chances are
117 // you'll want to run under an external debugger in the first place.
118 // [And btw it sure would be nice to assert statically
119 // that is_lisp_pointer(0x01) is indeed false]
121 #define FIX_POINTER() { \
122 lispobj *ptr = native_pointer(object); \
123 if (forwarding_pointer_p(ptr)) \
124 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); \
125 else /* Scavenge that pointer. */ \
126 (void)scavtab[widetag_of(object)](object_ptr, object); \
128 #ifdef LISP_FEATURE_IMMOBILE_SPACE
130 // It would be fine, though suboptimal, to use from_space_p() here.
131 // If it returns false, we don't want to call immobile_space_p()
132 // unless the pointer is *not* into dynamic space.
133 if ((page
= find_page_index((void*)object
)) >= 0) {
134 if (page_table
[page
].gen
== from_space
&& !pinned_p(object
, page
))
136 } else if (immobile_space_p(object
)) {
137 lispobj
*ptr
= native_pointer(object
);
138 if (immobile_obj_gen_bits(ptr
) == from_space
)
139 promote_immobile_obj(ptr
, 1);
142 if (from_space_p(object
)) {
145 #if (N_WORD_BITS == 32) && defined(LISP_FEATURE_GENCGC)
146 if (forwarding_pointer_p(object_ptr
))
147 lose("unexpected forwarding pointer in scavenge @ %p\n",
150 /* It points somewhere other than oldspace. Leave it
156 // Scavenge a block of memory from 'start' to 'end'
157 // that may contain object headers.
158 void heap_scavenge(lispobj
*start
, lispobj
*end
)
162 for (object_ptr
= start
; object_ptr
< end
;) {
163 lispobj object
= *object_ptr
;
164 if (other_immediate_lowtag_p(object
))
165 /* It's some sort of header object or another. */
166 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
167 else { // it's a cons
168 if (is_lisp_pointer(object
))
169 scav1(object_ptr
, object
);
170 object
= *++object_ptr
;
171 if (is_lisp_pointer(object
))
172 scav1(object_ptr
, object
);
176 // This assertion is usually the one that fails when something
177 // is subtly wrong with the heap, so definitely always do it.
178 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
179 object_ptr
, start
, end
);
182 // Scavenge a block of memory from 'start' extending for 'n_words'
183 // that must not contain any object headers.
184 sword_t
scavenge(lispobj
*start
, sword_t n_words
)
186 lispobj
*end
= start
+ n_words
;
188 for (object_ptr
= start
; object_ptr
< end
; object_ptr
++) {
189 lispobj object
= *object_ptr
;
190 if (is_lisp_pointer(object
)) scav1(object_ptr
, object
);
195 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
196 static lispobj
trans_short_boxed(lispobj object
);
199 scav_fun_pointer(lispobj
*where
, lispobj object
)
201 gc_dcheck(lowtag_of(object
) == FUN_POINTER_LOWTAG
);
203 /* Object is a pointer into from_space - not a FP. */
204 lispobj
*first_pointer
= native_pointer(object
);
206 /* must transport object -- object may point to either a function
207 * header, a funcallable instance header, or a closure header. */
208 lispobj copy
= widetag_of(*first_pointer
) == SIMPLE_FUN_HEADER_WIDETAG
209 ? trans_fun_header(object
) : trans_short_boxed(object
);
211 if (copy
!= object
) {
212 /* Set forwarding pointer */
213 set_forwarding_pointer(first_pointer
,copy
);
216 CHECK_COPY_POSTCONDITIONS(copy
, FUN_POINTER_LOWTAG
);
225 trans_code(struct code
*code
)
227 /* if object has already been transported, just return pointer */
228 if (forwarding_pointer_p((lispobj
*)code
)) {
230 printf("Was already transported\n");
232 return (struct code
*)native_pointer(forwarding_pointer_value((lispobj
*)code
));
235 gc_dcheck(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
237 /* prepare to transport the code vector */
238 lispobj l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
239 sword_t nheader_words
= code_header_words(code
->header
);
240 sword_t ncode_words
= code_instruction_words(code
->code_size
);
241 sword_t nwords
= nheader_words
+ ncode_words
;
242 lispobj l_new_code
= copy_code_object(l_code
, nwords
);
243 struct code
*new_code
= (struct code
*) native_pointer(l_new_code
);
245 #if defined(DEBUG_CODE_GC)
246 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
247 (uword_t
) code
, (uword_t
) new_code
);
248 printf("Code object is %d words long.\n", nwords
);
251 #ifdef LISP_FEATURE_GENCGC
252 if (new_code
== code
)
256 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
258 /* set forwarding pointers for all the function headers in the */
259 /* code object. also fix all self pointers */
260 /* Do this by scanning the new code, since the old header is unusable */
262 uword_t displacement
= l_new_code
- l_code
;
264 for_each_simple_fun(i
, nfheaderp
, new_code
, 1, {
265 /* Calculate the old raw function pointer */
266 struct simple_fun
* fheaderp
=
267 (struct simple_fun
*)LOW_WORD((char*)nfheaderp
- displacement
);
268 /* Calculate the new lispobj */
269 lispobj nfheaderl
= make_lispobj(nfheaderp
, FUN_POINTER_LOWTAG
);
272 printf("fheaderp->header (at %x) <- %x\n",
273 &(fheaderp
->header
) , nfheaderl
);
275 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
277 /* fix self pointer. */
279 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
280 FUN_RAW_ADDR_OFFSET
+
284 #ifdef LISP_FEATURE_GENCGC
285 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
286 spaces once when all copying is done. */
287 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
288 ncode_words
* sizeof(sword_t
));
292 #ifdef LISP_FEATURE_X86
293 gencgc_apply_code_fixups(code
, new_code
);
300 scav_code_header(lispobj
*where
, lispobj header
)
302 struct code
*code
= (struct code
*) where
;
303 sword_t n_header_words
= code_header_words(header
);
305 /* Scavenge the boxed section of the code data block. */
306 scavenge(where
+ 1, n_header_words
- 1);
308 /* Scavenge the boxed section of each function object in the
309 * code data block. */
310 for_each_simple_fun(i
, function_ptr
, code
, 1, {
311 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
312 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
315 return n_header_words
+ code_instruction_words(code
->code_size
);
319 trans_code_header(lispobj object
)
321 struct code
*ncode
= trans_code((struct code
*) native_pointer(object
));
322 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
326 size_code_header(lispobj
*where
)
328 return code_header_words(((struct code
*)where
)->header
)
329 + code_instruction_words(((struct code
*)where
)->code_size
);
332 #ifdef RETURN_PC_HEADER_WIDETAG
334 scav_return_pc_header(lispobj
*where
, lispobj object
)
336 lose("attempted to scavenge a return PC header where=%p object=%#lx\n",
337 where
, (uword_t
) object
);
338 return 0; /* bogus return value to satisfy static type checking */
342 trans_return_pc_header(lispobj object
)
344 struct simple_fun
*return_pc
= (struct simple_fun
*) native_pointer(object
);
345 uword_t offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
347 /* Transport the whole code object */
348 struct code
*code
= (struct code
*) ((uword_t
) return_pc
- offset
);
349 struct code
*ncode
= trans_code(code
);
351 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
353 #endif /* RETURN_PC_HEADER_WIDETAG */
355 /* On the 386, closures hold a pointer to the raw address instead of the
356 * function object, so we can use CALL [$FDEFN+const] to invoke
357 * the function without loading it into a register. Given that code
358 * objects don't move, we don't need to update anything, but we do
359 * have to figure out that the function is still live. */
361 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
363 scav_closure(lispobj
*where
, lispobj header
)
365 struct closure
*closure
= (struct closure
*)where
;
366 int payload_words
= SHORT_BOXED_NWORDS(header
);
367 lispobj fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
369 #ifdef LISP_FEATURE_GENCGC
370 /* The function may have moved so update the raw address. But
371 * don't write unnecessarily. */
372 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
373 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
375 // Payload includes 'fun' which was just looked at, so subtract it.
376 scavenge(closure
->info
, payload_words
- 1);
377 return 1 + payload_words
;
381 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
383 scav_fun_header(lispobj
*where
, lispobj object
)
385 lose("attempted to scavenge a function header where=%p object=%#lx\n",
386 where
, (uword_t
) object
);
387 return 0; /* bogus return value to satisfy static type checking */
389 #endif /* LISP_FEATURE_X86 */
392 trans_fun_header(lispobj object
)
394 struct simple_fun
*fheader
= (struct simple_fun
*) native_pointer(object
);
395 uword_t offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
397 /* Transport the whole code object */
398 struct code
*code
= (struct code
*) ((uword_t
) fheader
- offset
);
399 struct code
*ncode
= trans_code(code
);
401 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
410 trans_instance(lispobj object
)
412 gc_dcheck(lowtag_of(object
) == INSTANCE_POINTER_LOWTAG
);
413 lispobj header
= *(lispobj
*)(object
- INSTANCE_POINTER_LOWTAG
);
414 return copy_object(object
, 1 + (instance_length(header
)|1));
418 scav_instance_pointer(lispobj
*where
, lispobj object
)
420 /* Object is a pointer into from space - not a FP. */
421 lispobj copy
= trans_instance(object
);
423 gc_dcheck(copy
!= object
);
425 set_forwarding_pointer(native_pointer(object
), copy
);
436 static lispobj
trans_list(lispobj object
);
439 scav_list_pointer(lispobj
*where
, lispobj object
)
441 gc_dcheck(lowtag_of(object
) == LIST_POINTER_LOWTAG
);
443 lispobj copy
= trans_list(object
);
444 gc_dcheck(copy
!= object
);
446 CHECK_COPY_POSTCONDITIONS(copy
, LIST_POINTER_LOWTAG
);
454 trans_list(lispobj object
)
457 struct cons
*copy
= (struct cons
*)
458 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
459 lispobj new_list_pointer
= make_lispobj(copy
, LIST_POINTER_LOWTAG
);
460 copy
->car
= CONS(object
)->car
;
461 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
462 lispobj cdr
= CONS(object
)->cdr
;
463 set_forwarding_pointer((lispobj
*)CONS(object
), new_list_pointer
);
465 /* Try to linearize the list in the cdr direction to help reduce
467 while (lowtag_of(cdr
) == LIST_POINTER_LOWTAG
&& from_space_p(cdr
)) {
468 lispobj
* native_cdr
= (lispobj
*)CONS(cdr
);
469 if (forwarding_pointer_p(native_cdr
)) { // Might as well fix now.
470 cdr
= forwarding_pointer_value(native_cdr
);
474 struct cons
*cdr_copy
= (struct cons
*)
475 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
476 cdr_copy
->car
= ((struct cons
*)native_cdr
)->car
;
477 /* Grab the cdr before it is clobbered. */
478 lispobj next
= ((struct cons
*)native_cdr
)->cdr
;
479 /* Set cdr of the predecessor, and store an FP. */
480 set_forwarding_pointer(native_cdr
,
481 copy
->cdr
= make_lispobj(cdr_copy
,
482 LIST_POINTER_LOWTAG
));
487 return new_list_pointer
;
492 * scavenging and transporting other pointers
496 scav_other_pointer(lispobj
*where
, lispobj object
)
498 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
500 /* Object is a pointer into from space - not FP. */
501 lispobj
*first_pointer
= (lispobj
*)(object
- OTHER_POINTER_LOWTAG
);
502 lispobj copy
= transother
[widetag_of(*first_pointer
)](object
);
504 // If the object was large, then instead of transporting it,
505 // gencgc might simply promote the pages and return the same pointer.
506 // That decision is made in general_copy_large_object().
507 if (copy
!= object
) {
508 set_forwarding_pointer(first_pointer
, copy
);
509 #ifdef LISP_FEATURE_GENCGC
513 #ifndef LISP_FEATURE_GENCGC
516 CHECK_COPY_POSTCONDITIONS(copy
, OTHER_POINTER_LOWTAG
);
521 * immediate, boxed, and unboxed objects
524 /* The immediate object scavenger basically wants to be "scav_cons",
525 * and so returns 2. To see why it's right, observe that scavenge() will
526 * not invoke a scavtab entry on any object except for one satisfying
527 * is_lisp_pointer(). So if a scavtab[] function got here,
528 * then it must be via heap_scavenge(). But heap_scavenge() should only
529 * dispatch via scavtab[] if it thought it saw an object header.
530 * So why do we act like it saw a cons? Because conses can contain an
531 * immediate object that satisfies both other_immediate_lowtag_p()
532 * and is_lisp_immediate(), namely, the objects specifically mentioned at
533 * is_cons_half(). So heap_scavenge() is nearly testing is_cons_half()
534 * but even more efficiently, by ignoring the unusual immediate widetags
535 * until we get to scav_immediate.
537 * And just to hammer the point home: we won't blow past the end of a specific
538 * range of words when scavenging a binding or control stack or anything else,
539 * because scavenge() skips immediate objects all by itself,
540 * or rather it skips anything not satisfying is_lisp_pointer().
542 * As to the unbound marker, see rev. 09c78105eabc6bf2b339f421d4ed1df4678003db
543 * which says that we might see it in conses for reasons somewhat unknown.
546 scav_immediate(lispobj
*where
, lispobj object
)
549 if (is_lisp_pointer(object
)) scav1(where
, object
);
554 trans_immediate(lispobj object
)
556 lose("trying to transport an immediate\n");
557 return NIL
; /* bogus return value to satisfy static type checking */
561 size_immediate(lispobj
*where
)
567 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
569 /* If the bignum in the layout has another pointer to it (besides the layout)
570 acting as a root, and which is scavenged first, then transporting the
571 bignum causes the layout to see a FP, as would copying an instance whose
572 layout that is. This is a nearly impossible scenario to create organically
573 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
574 except for a few things that would cause it to be pinned anyway,
575 such as it being kept in a local variable during structure manipulation.
576 See 'interleaved-raw.impure.lisp' for a way to trigger this */
577 if (forwarding_pointer_p((lispobj
*)bignum
)) {
578 lispobj forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
580 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
581 (void*)bignum
, (void*)forwarded
);
583 bignum
= (struct bignum
*)native_pointer(forwarded
);
586 int len
= HeaderValue(bignum
->header
);
587 int word_index
= index
/ N_WORD_BITS
;
588 int bit_index
= index
% N_WORD_BITS
;
589 if (word_index
>= len
) {
590 // just return 0 since the marking logic does not allow negative bignums
593 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
597 struct instance_scanner
{
599 void (*proc
)(lispobj
*, sword_t
);
602 // Helper function for helper function below, since lambda isn't a thing
603 static void instance_scan_range(void* arg
, int offset
, int nwords
)
605 struct instance_scanner
*scanner
= (struct instance_scanner
*)arg
;
606 scanner
->proc(scanner
->base
+ offset
, nwords
);
609 // Helper function for stepping through the tagged slots of an instance in
610 // scav_instance and verify_space.
612 instance_scan(void (*proc
)(lispobj
*, sword_t
),
613 lispobj
*instance_slots
,
615 lispobj layout_bitmap
)
619 /* This code might be made more efficient by run-length-encoding the ranges
620 of words to scan, but probably not by much */
622 if (fixnump(layout_bitmap
)) {
623 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
624 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
626 proc(instance_slots
+ index
, 1);
627 } else { /* huge bitmap */
628 struct bignum
* bitmap
;
629 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
630 if (forwarding_pointer_p((lispobj
*)bitmap
))
631 bitmap
= (struct bignum
*)
632 native_pointer(forwarding_pointer_value((lispobj
*)bitmap
));
633 struct instance_scanner scanner
;
634 scanner
.base
= instance_slots
;
636 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
637 instance_scan_range
, &scanner
);
641 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
642 void (*proc
)(void*, int, int), void* arg
)
644 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
645 int start_word_index
= 0;
649 flags
= flags
& BIT_SCAN_CLEAR
;
651 // Rather than bzero'ing we can just clear each nonzero word as it's read,
653 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
656 int skip_bits
, start_bit
, start_position
, run_length
;
658 if (++start_word_index
>= n_bitmap_words
) break;
659 BITMAP_REF(start_word_index
);
663 // On each loop iteration, the lowest 1 bit is a "relative"
664 // bit index, since the word was already shifted. This is 'skip_bits'.
665 // Adding back in the total shift amount gives 'start_bit',
666 // the true absolute index within the current word.
667 // 'start_position' is absolute within the entire bitmap.
668 skip_bits
= ffsl(word
) - 1;
669 start_bit
= skip_bits
+ shift
;
670 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
671 // Compute the number of consecutive 1s in the current word.
673 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
674 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
676 shift
+= skip_bits
+ run_length
;
678 int end_word_index
= ++start_word_index
;
680 if (end_word_index
>= n_bitmap_words
) {
682 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
685 BITMAP_REF(end_word_index
);
689 // end_word_index is the exclusive bound on contiguous
690 // words to include in the range. See if the low bits
691 // from the next word can extend the range.
692 shift
= ffsl(~word
) - 1;
694 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
699 start_word_index
= end_word_index
;
701 proc(arg
, start_position
, run_length
);
707 scav_instance(lispobj
*where
, lispobj header
)
709 lispobj
* layout
= (lispobj
*)instance_layout(where
);
710 lispobj lbitmap
= make_fixnum(-1);
713 layout
= native_pointer((lispobj
)layout
);
714 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
715 if (__immobile_obj_gen_bits(layout
) == from_space
)
716 promote_immobile_obj(layout
, 1);
718 if (forwarding_pointer_p(layout
))
719 layout
= native_pointer(forwarding_pointer_value(layout
));
721 lbitmap
= ((struct layout
*)layout
)->bitmap
;
723 sword_t nslots
= instance_length(header
) | 1;
724 if (lbitmap
== make_fixnum(-1))
725 scavenge(where
+1, nslots
);
726 else if (!fixnump(lbitmap
))
727 instance_scan((void(*)(lispobj
*,sword_t
))scavenge
,
728 where
+1, nslots
, lbitmap
);
730 sword_t bitmap
= (sword_t
)lbitmap
>> N_FIXNUM_TAG_BITS
; // 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 /* Note: on the sparc we don't have to do anything special for fdefns, */
772 /* 'cause the raw-addr has a function lowtag. */
773 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
775 scav_fdefn(lispobj
*where
, lispobj object
)
777 struct fdefn
*fdefn
= (struct fdefn
*)where
;
779 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
780 fdefn->fun, fdefn->raw_addr)); */
782 scavenge(where
+ 1, 2); // 'name' and 'fun'
783 #ifndef LISP_FEATURE_IMMOBILE_CODE
784 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
785 if (raw_fun
> READ_ONLY_SPACE_END
) {
786 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
787 scavenge(&simple_fun
, 1);
788 /* Don't write unnecessarily. */
789 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
790 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
792 #elif defined(LISP_FEATURE_X86_64)
793 lispobj obj
= fdefn_raw_referent(fdefn
);
796 scavenge(&new, 1); // enliven
797 gc_dcheck(new == obj
); // must not move
800 # error "Need to implement scav_fdefn"
807 scav_unboxed(lispobj
*where
, lispobj object
)
809 sword_t length
= HeaderValue(object
) + 1;
810 return CEILING(length
, 2);
814 trans_unboxed(lispobj object
)
816 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
817 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
818 return copy_unboxed_object(object
, CEILING(length
, 2));
822 trans_ratio_or_complex(lispobj object
)
824 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
825 lispobj
* x
= native_pointer(object
);
829 /* A zero ratio or complex means it was just allocated by fixed-alloc and
830 a bignum can still be written there. Not a problem with a conservative GC
831 since it will be pinned down. */
832 if (fixnump(a
) && fixnump(b
)
833 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
838 return copy_unboxed_object(object
, 4);
840 return copy_object(object
, 4);
843 /* vector-like objects */
845 trans_vector(lispobj object
)
847 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
850 fixnum_value(((struct vector
*)native_pointer(object
))->length
);
851 return copy_large_object(object
, CEILING(length
+ 2, 2));
855 size_vector(lispobj
*where
)
857 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
858 return CEILING(length
+ 2, 2);
861 static inline uword_t
862 NWORDS(uword_t x
, uword_t n_bits
)
864 /* A good compiler should be able to constant-fold this whole thing,
865 even with the conditional. */
866 if(n_bits
<= N_WORD_BITS
) {
867 uword_t elements_per_word
= N_WORD_BITS
/n_bits
;
869 return CEILING(x
, elements_per_word
)/elements_per_word
;
872 /* FIXME: should have some sort of assertion that N_WORD_BITS
873 evenly divides n_bits */
874 return x
* (n_bits
/N_WORD_BITS
);
878 #define DEF_SCAV_TRANS_SIZE_UB(nbits) \
879 DEF_SPECIALIZED_VECTOR(vector_unsigned_byte_##nbits, NWORDS(length, nbits))
880 #define DEF_SPECIALIZED_VECTOR(name, nwords) \
881 static sword_t __attribute__((unused)) scav_##name(lispobj *where, lispobj header) { \
882 sword_t length = fixnum_value(((struct vector*)where)->length); \
883 return CEILING(nwords + 2, 2); \
885 static lispobj __attribute__((unused)) trans_##name(lispobj object) { \
886 gc_dcheck(lowtag_of(object) == OTHER_POINTER_LOWTAG); \
887 sword_t length = fixnum_value(((struct vector*)(object-OTHER_POINTER_LOWTAG))->length); \
888 return copy_large_unboxed_object(object, CEILING(nwords + 2, 2)); \
890 static sword_t __attribute__((unused)) size_##name(lispobj *where) { \
891 sword_t length = fixnum_value(((struct vector*)where)->length); \
892 return CEILING(nwords + 2, 2); \
895 DEF_SPECIALIZED_VECTOR(vector_nil
, 0*length
)
896 DEF_SPECIALIZED_VECTOR(vector_bit
, NWORDS(length
,1))
897 /* NOTE: strings contain one more element of data (a terminating '\0'
898 * to help interface with C functions) than indicated by the length slot.
899 * This is true even for UCS4 strings, despite that C APIs are unlikely
900 * to have a convention that expects 4 zero bytes. */
901 DEF_SPECIALIZED_VECTOR(base_string
, NWORDS((length
+1), 8))
902 DEF_SPECIALIZED_VECTOR(character_string
, NWORDS((length
+1), 32))
903 DEF_SCAV_TRANS_SIZE_UB(2)
904 DEF_SCAV_TRANS_SIZE_UB(4)
905 DEF_SCAV_TRANS_SIZE_UB(8)
906 DEF_SCAV_TRANS_SIZE_UB(16)
907 DEF_SCAV_TRANS_SIZE_UB(32)
908 DEF_SCAV_TRANS_SIZE_UB(64)
909 DEF_SCAV_TRANS_SIZE_UB(128)
910 #ifdef LONG_FLOAT_SIZE
911 DEF_SPECIALIZED_VECTOR(vector_long_float
, length
* LONG_FLOAT_SIZE
)
912 DEF_SPECIALIZED_VECTOR(vector_complex_long_float
, length
* (2 * LONG_FLOAT_SIZE
))
916 trans_weak_pointer(lispobj object
)
919 gc_dcheck(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
921 #if defined(DEBUG_WEAK)
922 printf("Transporting weak pointer from 0x%08x\n", object
);
925 /* Need to remember where all the weak pointers are that have */
926 /* been transported so they can be fixed up in a post-GC pass. */
928 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
929 #ifndef LISP_FEATURE_GENCGC
930 struct weak_pointer
*wp
= (struct weak_pointer
*) native_pointer(copy
);
932 gc_dcheck(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
933 /* Push the weak pointer onto the list of weak pointers. */
934 if (weak_pointer_breakable_p(wp
)) {
935 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
942 void scan_weak_pointers(void)
944 struct weak_pointer
*wp
, *next_wp
;
945 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
946 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
950 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
953 lispobj pointee
= wp
->value
;
954 gc_assert(is_lisp_pointer(pointee
));
955 lispobj
*objaddr
= native_pointer(pointee
);
957 /* Now, we need to check whether the object has been forwarded. If
958 * it has been, the weak pointer is still good and needs to be
959 * updated. Otherwise, the weak pointer needs to be broken. */
961 if (from_space_p(pointee
)) {
962 wp
->value
= forwarding_pointer_p(objaddr
) ?
963 LOW_WORD(forwarding_pointer_value(objaddr
)) : UNBOUND_MARKER_WIDETAG
;
965 #ifdef LISP_FEATURE_IMMOBILE_SPACE
966 else if (immobile_space_p(pointee
) &&
967 immobile_obj_gen_bits(objaddr
) == from_space
) {
968 wp
->value
= UNBOUND_MARKER_WIDETAG
;
972 lose("unbreakable pointer %p", wp
);
979 #if N_WORD_BITS == 32
980 #define EQ_HASH_MASK 0x1fffffff
981 #elif N_WORD_BITS == 64
982 #define EQ_HASH_MASK 0x1fffffffffffffff
985 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
986 * target-hash-table.lisp. */
987 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
989 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
990 * slot. Set to NULL at the end of a collection.
992 * This is not optimal because, when a table is tenured, it won't be
993 * processed automatically; only the yougest generation is GC'd by
994 * default. On the other hand, all applications will need an
995 * occasional full GC anyway, so it's not that bad either. */
996 struct hash_table
*weak_hash_tables
= NULL
;
998 /* Return true if OBJ has already survived the current GC. */
999 static inline int pointer_survived_gc_yet(lispobj obj
)
1001 #ifdef LISP_FEATURE_CHENEYGC
1002 // This is the most straightforward definition.
1003 return (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
)));
1005 /* Check for a pointer to dynamic space before considering immobile space.
1006 Based on the relative size of the spaces, this should be a win because
1007 if the object is in the dynamic space and not the 'from' generation
1008 we don't want to test immobile_space_p() at all.
1009 Additionally, pinned_p() is both more expensive and less likely than
1010 forwarding_pointer_p(), so we want to reverse those conditions, which
1011 would not be possible with pinned_p() buried inside from_space_p(). */
1012 page_index_t page_index
= find_page_index((void*)obj
);
1013 if (page_index
>= 0)
1014 return page_table
[page_index
].gen
!= from_space
||
1015 forwarding_pointer_p(native_pointer(obj
)) ||
1016 pinned_p(obj
, page_index
);
1017 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1018 if (immobile_space_p(obj
))
1019 return immobile_obj_gen_bits(native_pointer(obj
)) != from_space
;
1025 #ifdef EMPTY_HT_SLOT /* only if it's a static symbol */
1026 // "ish" because EMPTY_HT_SLOT is of course a pointer.
1027 # define ht_cell_nonpointerish(x) (!is_lisp_pointer(x) || x==EMPTY_HT_SLOT)
1029 # define ht_cell_nonpointerish(x) !is_lisp_pointer(x)
1032 static int survived_gc_yet_KEY(lispobj key
, lispobj value
) {
1033 return ht_cell_nonpointerish(key
) || pointer_survived_gc_yet(key
);
1035 static int survived_gc_yet_VALUE(lispobj key
, lispobj value
) {
1036 return ht_cell_nonpointerish(value
) || pointer_survived_gc_yet(value
);
1038 static int survived_gc_yet_AND(lispobj key
, lispobj value
) {
1039 int key_nonpointer
= ht_cell_nonpointerish(key
);
1040 int val_nonpointer
= ht_cell_nonpointerish(value
);
1041 if (key_nonpointer
&& val_nonpointer
) return 1;
1042 return (key_nonpointer
|| pointer_survived_gc_yet(key
))
1043 && (val_nonpointer
|| pointer_survived_gc_yet(value
));
1045 static int survived_gc_yet_OR(lispobj key
, lispobj value
) {
1046 int key_nonpointer
= ht_cell_nonpointerish(key
);
1047 int val_nonpointer
= ht_cell_nonpointerish(value
);
1048 if (key_nonpointer
|| val_nonpointer
) return 1;
1049 // Both MUST be pointers
1050 return pointer_survived_gc_yet(key
) || pointer_survived_gc_yet(value
);
1053 static int (*weak_hash_entry_alivep_fun(lispobj weakness
))(lispobj
,lispobj
)
1056 case KEY
: return survived_gc_yet_KEY
;
1057 case VALUE
: return survived_gc_yet_VALUE
;
1058 case KEY_OR_VALUE
: return survived_gc_yet_OR
;
1059 case KEY_AND_VALUE
: return survived_gc_yet_AND
;
1060 case NIL
: return NULL
;
1061 default: lose("Bad hash table weakness");
1065 /* Return the beginning of data in ARRAY (skipping the header and the
1066 * length) or NULL if it isn't an array of the specified widetag after
1068 static inline lispobj
*
1069 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1071 if (is_lisp_pointer(array
) && widetag_of(*native_pointer(array
)) == widetag
) {
1073 *length
= fixnum_value(native_pointer(array
)[1]);
1074 return native_pointer(array
) + 2;
1080 /* Only need to worry about scavenging the _real_ entries in the
1081 * table. Phantom entries such as the hash table itself at index 0 and
1082 * the empty marker at index 1 were scavenged by scav_vector that
1083 * either called this function directly or arranged for it to be
1084 * called later by pushing the hash table onto weak_hash_tables. */
1086 scav_hash_table_entries (struct hash_table
*hash_table
)
1090 lispobj
*index_vector
;
1092 lispobj
*next_vector
;
1093 uword_t next_vector_length
;
1094 lispobj
*hash_vector
;
1095 uword_t hash_vector_length
;
1096 lispobj empty_symbol
;
1097 lispobj weakness
= hash_table
->weakness
;
1100 kv_vector
= get_array_data(hash_table
->table
,
1101 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1102 if (kv_vector
== NULL
)
1103 lose("invalid kv_vector %x\n", hash_table
->table
);
1105 index_vector
= get_array_data(hash_table
->index_vector
,
1106 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1107 if (index_vector
== NULL
)
1108 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1110 next_vector
= get_array_data(hash_table
->next_vector
,
1111 SIMPLE_ARRAY_WORD_WIDETAG
,
1112 &next_vector_length
);
1113 if (next_vector
== NULL
)
1114 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1116 hash_vector
= get_array_data(hash_table
->hash_vector
,
1117 SIMPLE_ARRAY_WORD_WIDETAG
,
1118 &hash_vector_length
);
1119 if (hash_vector
!= NULL
)
1120 gc_assert(hash_vector_length
== next_vector_length
);
1122 /* These lengths could be different as the index_vector can be a
1123 * different length from the others, a larger index_vector could
1124 * help reduce collisions. */
1125 gc_assert(next_vector_length
*2 == kv_length
);
1127 empty_symbol
= kv_vector
[1];
1128 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1129 if (widetag_of(*native_pointer(empty_symbol
)) != SYMBOL_HEADER_WIDETAG
) {
1130 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1131 *native_pointer(empty_symbol
));
1134 /* Work through the KV vector. */
1135 int (*alivep_test
)(lispobj
,lispobj
) = weak_hash_entry_alivep_fun(weakness
);
1136 #define SCAV_ENTRIES(aliveness_predicate) \
1137 for (i = 1; i < next_vector_length; i++) { \
1138 lispobj old_key = kv_vector[2*i]; \
1139 lispobj __attribute__((unused)) value = kv_vector[2*i+1]; \
1140 if (aliveness_predicate) { \
1141 /* Scavenge the key and value. */ \
1142 scavenge(&kv_vector[2*i], 2); \
1143 /* If an EQ-based key has moved, mark the hash-table for rehash */ \
1144 if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) { \
1145 lispobj new_key = kv_vector[2*i]; \
1146 if (old_key != new_key && new_key != empty_symbol) \
1147 hash_table->needs_rehash_p = T; \
1150 SCAV_ENTRIES(alivep_test(old_key
, value
))
1156 scav_vector (lispobj
*where
, lispobj object
)
1159 struct hash_table
*hash_table
;
1161 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1162 * hash tables in the Lisp HASH-TABLE code to indicate need for
1163 * special GC support. */
1164 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
) {
1165 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
1166 scavenge(where
+ 2, length
);
1167 return CEILING(length
+ 2, 2);
1170 kv_length
= fixnum_value(where
[1]);
1171 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1173 /* Scavenge element 0, which may be a hash-table structure. */
1174 scavenge(where
+2, 1);
1175 if (!is_lisp_pointer(where
[2])) {
1176 /* This'll happen when REHASH clears the header of old-kv-vector
1177 * and fills it with zero, but some other thread simulatenously
1178 * sets the header in %%PUTHASH.
1181 "Warning: no pointer at %p in hash table: this indicates "
1182 "non-fatal corruption caused by concurrent access to a "
1183 "hash-table from multiple threads. Any accesses to "
1184 "hash-tables shared between threads should be protected "
1185 "by locks.\n", (void*)&where
[2]);
1186 // We've scavenged three words.
1189 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1190 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1191 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1192 lose("hash table not instance (%x at %x)\n",
1197 /* Scavenge element 1, which should be some internal symbol that
1198 * the hash table code reserves for marking empty slots. */
1199 scavenge(where
+3, 1);
1200 if (!is_lisp_pointer(where
[3])) {
1201 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1204 /* Scavenge hash table, which will fix the positions of the other
1205 * needed objects. */
1206 scavenge((lispobj
*)hash_table
,
1207 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1209 /* Cross-check the kv_vector. */
1210 if (where
!= native_pointer(hash_table
->table
)) {
1211 lose("hash_table table!=this table %x\n", hash_table
->table
);
1214 if (hash_table
->weakness
== NIL
) {
1215 scav_hash_table_entries(hash_table
);
1217 /* Delay scavenging of this table by pushing it onto
1218 * weak_hash_tables (if it's not there already) for the weak
1220 if (hash_table
->next_weak_hash_table
== NIL
) {
1221 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1222 weak_hash_tables
= hash_table
;
1226 return (CEILING(kv_length
+ 2, 2));
1230 scav_weak_hash_tables (void)
1232 struct hash_table
*table
;
1234 /* Scavenge entries whose triggers are known to survive. */
1235 for (table
= weak_hash_tables
; table
!= NULL
;
1236 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1237 scav_hash_table_entries(table
);
1241 /* Walk through the chain whose first element is *FIRST and remove
1242 * dead weak entries. */
1244 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1245 lispobj
*kv_vector
, lispobj
*index_vector
,
1246 lispobj
*next_vector
, lispobj
*hash_vector
,
1247 lispobj empty_symbol
, int (*alivep_test
)(lispobj
,lispobj
))
1249 unsigned index
= *prev
;
1251 unsigned next
= next_vector
[index
];
1252 lispobj key
= kv_vector
[2 * index
];
1253 lispobj value
= kv_vector
[2 * index
+ 1];
1254 gc_assert(key
!= empty_symbol
);
1255 gc_assert(value
!= empty_symbol
);
1256 if (!alivep_test(key
, value
)) {
1257 unsigned count
= fixnum_value(hash_table
->number_entries
);
1258 gc_assert(count
> 0);
1260 hash_table
->number_entries
= make_fixnum(count
- 1);
1261 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1262 hash_table
->next_free_kv
= make_fixnum(index
);
1263 kv_vector
[2 * index
] = empty_symbol
;
1264 kv_vector
[2 * index
+ 1] = empty_symbol
;
1266 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1268 prev
= &next_vector
[index
];
1275 scan_weak_hash_table (struct hash_table
*hash_table
)
1278 lispobj
*index_vector
;
1279 uword_t length
= 0; /* prevent warning */
1280 lispobj
*next_vector
;
1281 uword_t next_vector_length
= 0; /* prevent warning */
1282 lispobj
*hash_vector
;
1283 lispobj empty_symbol
;
1284 lispobj weakness
= hash_table
->weakness
;
1287 kv_vector
= get_array_data(hash_table
->table
,
1288 SIMPLE_VECTOR_WIDETAG
, NULL
);
1289 index_vector
= get_array_data(hash_table
->index_vector
,
1290 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1291 next_vector
= get_array_data(hash_table
->next_vector
,
1292 SIMPLE_ARRAY_WORD_WIDETAG
,
1293 &next_vector_length
);
1294 hash_vector
= get_array_data(hash_table
->hash_vector
,
1295 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1296 empty_symbol
= kv_vector
[1];
1298 for (i
= 0; i
< length
; i
++) {
1299 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
1300 kv_vector
, index_vector
, next_vector
,
1301 hash_vector
, empty_symbol
,
1302 weak_hash_entry_alivep_fun(weakness
));
1306 /* Remove dead entries from weak hash tables. */
1308 scan_weak_hash_tables (void)
1310 struct hash_table
*table
, *next
;
1312 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1313 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1314 table
->next_weak_hash_table
= NIL
;
1315 scan_weak_hash_table(table
);
1318 weak_hash_tables
= NULL
;
1327 scav_lose(lispobj
*where
, lispobj object
)
1329 lose("no scavenge function for object %p (widetag 0x%x)\n",
1331 widetag_of(*where
));
1333 return 0; /* bogus return value to satisfy static type checking */
1337 trans_lose(lispobj object
)
1339 lose("no transport function for object %p (widetag 0x%x)\n",
1341 widetag_of(*native_pointer(object
)));
1342 return NIL
; /* bogus return value to satisfy static type checking */
1346 size_lose(lispobj
*where
)
1348 lose("no size function for object at %p (widetag 0x%x)\n",
1350 widetag_of(*where
));
1351 return 1; /* bogus return value to satisfy static type checking */
1359 #include "genesis/gc-tables.h"
1362 static lispobj
*search_spaces(void *pointer
)
1365 if (((start
= search_dynamic_space(pointer
)) != NULL
) ||
1366 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1367 ((start
= search_immobile_space(pointer
)) != NULL
) ||
1369 ((start
= search_static_space(pointer
)) != NULL
) ||
1370 ((start
= search_read_only_space(pointer
)) != NULL
))
1375 /* Find the code object for the given pc, or return NULL on
1378 component_ptr_from_pc(lispobj
*pc
)
1380 lispobj
*object
= search_spaces(pc
);
1382 if (object
!= NULL
&& widetag_of(*object
) == CODE_HEADER_WIDETAG
)
1388 /* Scan an area looking for an object which encloses the given pointer.
1389 * Return the object start on success, or NULL on failure. */
1391 gc_search_space3(void *pointer
, lispobj
*start
, void *limit
)
1393 if (pointer
< (void*)start
|| pointer
>= limit
) return NULL
;
1397 /* CAUTION: this code is _significantly_ slower than the production version
1398 due to the extra checks for forwarding. Only use it if debugging */
1399 for ( ; (void*)start
< limit
; start
+= count
) {
1400 lispobj
*forwarded_start
;
1401 if (forwarding_pointer_p(start
))
1402 forwarded_start
= native_pointer(forwarding_pointer_value(start
));
1404 forwarded_start
= start
;
1405 lispobj thing
= *forwarded_start
;
1406 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](forwarded_start
);
1407 /* Check whether the pointer is within this object. */
1408 if (pointer
< (void*)(start
+count
)) return start
;
1411 for ( ; (void*)start
< limit
; start
+= count
) {
1412 lispobj thing
= *start
;
1413 count
= is_cons_half(thing
) ? 2 : sizetab
[widetag_of(thing
)](start
);
1414 /* Check whether the pointer is within this object. */
1415 if (pointer
< (void*)(start
+count
)) return start
;
1421 /* Helper for valid_lisp_pointer_p (below) and
1422 * conservative_root_p (gencgc).
1424 * pointer is the pointer to check validity of,
1425 * and start_addr is the address of the enclosing object.
1427 * This is actually quite simple to check: because the heap state is assumed
1428 * consistent, and 'start_addr' is known good, having come from
1429 * gc_search_space(), only the 'pointer' argument is dubious.
1430 * So make 'start_addr' into a tagged pointer and see if that matches 'pointer'.
1431 * If it does, then 'pointer' is valid.
1434 properly_tagged_p_internal(lispobj pointer
, lispobj
*start_addr
)
1436 // If a headerless object, confirm that 'pointer' is a list pointer.
1437 // Given the precondition that the heap is in a valid state,
1438 // it may be assumed that one check of is_cons_half() suffices;
1439 // we don't need to check the other half.
1440 lispobj header
= *start_addr
;
1441 if (is_cons_half(header
))
1442 return make_lispobj(start_addr
, LIST_POINTER_LOWTAG
) == pointer
;
1444 // Because this heap object was not deemed to be a cons,
1445 // it must be an object header. Don't need a check except when paranoid.
1446 gc_dcheck(other_immediate_lowtag_p(header
));
1448 // The space of potential widetags has 64 elements, not 256,
1449 // because of the constant low 2 bits.
1450 int widetag
= widetag_of(header
);
1451 int lowtag
= lowtag_for_widetag
[widetag
>>2];
1452 if (lowtag
&& make_lispobj(start_addr
, lowtag
) == pointer
)
1453 return 1; // instant win
1455 if (widetag
== CODE_HEADER_WIDETAG
) {
1456 // Check for RETURN_PC_HEADER first since it's quicker.
1457 // Then consider the embedded simple-funs.
1458 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1459 /* The all-architecture test below is good as far as it goes,
1460 * but an LRA object is similar to a FUN-POINTER: It is
1461 * embedded within a CODE-OBJECT pointed to by start_addr, and
1462 * cannot be found by simply walking the heap, therefore we
1463 * need to check for it. -- AB, 2010-Jun-04 */
1464 if (lowtag_of(pointer
) == OTHER_POINTER_LOWTAG
) {
1465 lispobj
*potential_lra
= native_pointer(pointer
);
1466 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
1467 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
1468 return 1; /* It's as good as we can verify. */
1472 if (lowtag_of(pointer
) == FUN_POINTER_LOWTAG
) {
1473 struct simple_fun
*pfun
=
1474 (struct simple_fun
*)(pointer
-FUN_POINTER_LOWTAG
);
1475 for_each_simple_fun(i
, function
, (struct code
*)start_addr
, 0, {
1476 if (pfun
== function
) return 1;
1480 return 0; // no good
1483 /* META: Note the ambiguous word "validate" in the comment below.
1484 * This means "Decide whether <x> is valid".
1485 * But when you see os_validate() elsewhere, that doesn't mean to ask
1486 * whether something is valid, it says to *make* it valid.
1487 * I think it would be nice if we could avoid using the word in the
1488 * sense in which os_validate() uses it, which would entail renaming
1489 * a bunch of stuff, which is harder than just explaining why
1490 * the comments can be deceptive */
1492 /* Used by the debugger to validate possibly bogus pointers before
1493 * calling MAKE-LISP-OBJ on them.
1495 * FIXME: We would like to make this perfect, because if the debugger
1496 * constructs a reference to a bugs lisp object, and it ends up in a
1497 * location scavenged by the GC all hell breaks loose.
1499 * Whereas conservative_root_p has to be conservative
1500 * and return true for all valid pointers, this could actually be eager
1501 * and lie about a few pointers without bad results... but that should
1502 * be reflected in the name.
1505 valid_lisp_pointer_p(lispobj pointer
)
1507 lispobj
*start
= search_spaces((void*)pointer
);
1509 return properly_tagged_descriptor_p((void*)pointer
, start
);
1514 maybe_gc(os_context_t
*context
)
1516 lispobj gc_happened
;
1517 struct thread
*thread
= arch_os_get_current_thread();
1518 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
1521 fake_foreign_function_call(context
);
1524 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
1525 * which case we will be running with no gc trigger barrier
1526 * thing for a while. But it shouldn't be long until the end
1529 * FIXME: It would be good to protect the end of dynamic space for
1530 * CheneyGC and signal a storage condition from there.
1533 /* Restore the signal mask from the interrupted context before
1534 * calling into Lisp if interrupts are enabled. Why not always?
1536 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
1537 * interrupt hits while in SUB-GC, it is deferred and the
1538 * os_context_sigmask of that interrupt is set to block further
1539 * deferrable interrupts (until the first one is
1540 * handled). Unfortunately, that context refers to this place and
1541 * when we return from here the signals will not be blocked.
1543 * A kludgy alternative is to propagate the sigmask change to the
1546 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
1547 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
1548 unblock_gc_signals(0, 0);
1550 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
1551 /* FIXME: Nothing must go wrong during GC else we end up running
1552 * the debugger, error handlers, and user code in general in a
1553 * potentially unsafe place. Running out of the control stack or
1554 * the heap in SUB-GC are ways to lose. Of course, deferrables
1555 * cannot be unblocked because there may be a pending handler, or
1556 * we may even be in a WITHOUT-INTERRUPTS. */
1557 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
1558 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
1559 (gc_happened
== NIL
)
1561 : ((gc_happened
== T
)
1564 /* gc_happened can take three values: T, NIL, 0.
1566 * T means that the thread managed to trigger a GC, and post-gc
1569 * NIL means that the thread is within without-gcing, and no GC
1572 * Finally, 0 means that *a* GC has occurred, but it wasn't
1573 * triggered by this thread; success, but post-gc doesn't have
1576 if ((gc_happened
== T
) &&
1577 /* See if interrupts are enabled or it's possible to enable
1578 * them. POST-GC has a similar check, but we don't want to
1579 * unlock deferrables in that case and get a pending interrupt
1581 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
1582 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
1583 #ifndef LISP_FEATURE_WIN32
1584 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
1585 if (!deferrables_blocked_p(context_sigmask
)) {
1586 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
1587 #ifndef LISP_FEATURE_SB_SAFEPOINT
1588 check_gc_signals_unblocked_or_lose(0);
1591 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
1592 funcall0(StaticSymbolFunction(POST_GC
));
1593 #ifndef LISP_FEATURE_WIN32
1595 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
1601 undo_fake_foreign_function_call(context
);
1603 /* Otherwise done by undo_fake_foreign_function_call. And
1604 something later wants them to be blocked. What a nice
1606 block_blockable_signals(0);
1609 FSHOW((stderr
, "/maybe_gc: returning\n"));
1610 return (gc_happened
!= NIL
);
1613 #define BYTES_ZERO_BEFORE_END (1<<12)
1615 /* There used to be a similar function called SCRUB-CONTROL-STACK in
1616 * Lisp and another called zero_stack() in cheneygc.c, but since it's
1617 * shorter to express in, and more often called from C, I keep only
1618 * the C one after fixing it. -- MG 2009-03-25 */
1620 /* Zero the unused portion of the control stack so that old objects
1621 * are not kept alive because of uninitialized stack variables.
1623 * "To summarize the problem, since not all allocated stack frame
1624 * slots are guaranteed to be written by the time you call an another
1625 * function or GC, there may be garbage pointers retained in your dead
1626 * stack locations. The stack scrubbing only affects the part of the
1627 * stack from the SP to the end of the allocated stack." - ram, on
1628 * cmucl-imp, Tue, 25 Sep 2001
1630 * So, as an (admittedly lame) workaround, from time to time we call
1631 * scrub-control-stack to zero out all the unused portion. This is
1632 * supposed to happen when the stack is mostly empty, so that we have
1633 * a chance of clearing more of it: callers are currently (2002.07.18)
1634 * REPL, SUB-GC and sig_stop_for_gc_handler. */
1636 /* Take care not to tread on the guard page and the hard guard page as
1637 * it would be unkind to sig_stop_for_gc_handler. Touching the return
1638 * guard page is not dangerous. For this to work the guard page must
1639 * be zeroed when protected. */
1641 /* FIXME: I think there is no guarantee that once
1642 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
1643 * may be what the "lame" adjective in the above comment is for. In
1644 * this case, exact gc may lose badly. */
1646 scrub_control_stack()
1648 scrub_thread_control_stack(arch_os_get_current_thread());
1652 scrub_thread_control_stack(struct thread
*th
)
1654 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
1655 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
1656 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1657 /* On these targets scrubbing from C is a bad idea, so we punt to
1658 * a routine in $ARCH-assem.S. */
1659 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
1660 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
1662 lispobj
*sp
= access_control_stack_pointer(th
);
1664 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
1665 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
1666 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
1667 ((os_vm_address_t
)sp
>= guard_page_address
) &&
1668 (th
->control_stack_guard_page_protected
!= NIL
)))
1670 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
1673 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1674 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
1679 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
1683 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1684 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
1689 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
1691 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
1694 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1697 scavenge_control_stack(struct thread
*th
)
1699 lispobj
*object_ptr
;
1701 /* In order to properly support dynamic-extent allocation of
1702 * non-CONS objects, the control stack requires special handling.
1703 * Rather than calling scavenge() directly, grovel over it fixing
1704 * broken hearts, scavenging pointers to oldspace, and pitching a
1705 * fit when encountering unboxed data. This prevents stray object
1706 * headers from causing the scavenger to blow past the end of the
1707 * stack (an error case checked in scavenge()). We don't worry
1708 * about treating unboxed words as boxed or vice versa, because
1709 * the compiler isn't allowed to store unboxed objects on the
1710 * control stack. -- AB, 2011-Dec-02 */
1712 for (object_ptr
= th
->control_stack_start
;
1713 object_ptr
< access_control_stack_pointer(th
);
1716 lispobj object
= *object_ptr
;
1717 #ifdef LISP_FEATURE_GENCGC
1718 if (forwarding_pointer_p(object_ptr
))
1719 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
1720 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
1722 if (is_lisp_pointer(object
) && from_space_p(object
)) {
1723 /* It currently points to old space. Check for a
1724 * forwarding pointer. */
1725 lispobj
*ptr
= native_pointer(object
);
1726 if (forwarding_pointer_p(ptr
)) {
1727 /* Yes, there's a forwarding pointer. */
1728 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
1730 /* Scavenge that pointer. */
1731 long n_words_scavenged
=
1732 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
1733 gc_assert(n_words_scavenged
== 1);
1735 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
1736 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
1737 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
1742 /* Scavenging Interrupt Contexts */
1744 static int boxed_registers
[] = BOXED_REGISTERS
;
1746 /* The GC has a notion of an "interior pointer" register, an unboxed
1747 * register that typically contains a pointer to inside an object
1748 * referenced by another pointer. The most obvious of these is the
1749 * program counter, although many compiler backends define a "Lisp
1750 * Interior Pointer" register known to the runtime as reg_LIP, and
1751 * various CPU architectures have other registers that also partake of
1752 * the interior-pointer nature. As the code for pairing an interior
1753 * pointer value up with its "base" register, and fixing it up after
1754 * scavenging is complete is horribly repetitive, a few macros paper
1755 * over the monotony. --AB, 2010-Jul-14 */
1757 /* These macros are only ever used over a lexical environment which
1758 * defines a pointer to an os_context_t called context, thus we don't
1759 * bother to pass that context in as a parameter. */
1761 /* Define how to access a given interior pointer. */
1762 #define ACCESS_INTERIOR_POINTER_pc \
1763 *os_context_pc_addr(context)
1764 #define ACCESS_INTERIOR_POINTER_lip \
1765 *os_context_register_addr(context, reg_LIP)
1766 #define ACCESS_INTERIOR_POINTER_lr \
1767 *os_context_lr_addr(context)
1768 #define ACCESS_INTERIOR_POINTER_npc \
1769 *os_context_npc_addr(context)
1770 #define ACCESS_INTERIOR_POINTER_ctr \
1771 *os_context_ctr_addr(context)
1773 #define INTERIOR_POINTER_VARS(name) \
1774 uword_t name##_offset; \
1775 int name##_register_pair
1777 #define PAIR_INTERIOR_POINTER(name) \
1778 pair_interior_pointer(context, \
1779 ACCESS_INTERIOR_POINTER_##name, \
1781 &name##_register_pair)
1783 /* One complexity here is that if a paired register is not found for
1784 * an interior pointer, then that pointer does not get updated.
1785 * Originally, there was some commentary about using an index of -1
1786 * when calling os_context_register_addr() on SPARC referring to the
1787 * program counter, but the real reason is to allow an interior
1788 * pointer register to point to the runtime, read-only space, or
1789 * static space without problems. */
1790 #define FIXUP_INTERIOR_POINTER(name) \
1792 if (name##_register_pair >= 0) { \
1793 ACCESS_INTERIOR_POINTER_##name = \
1794 (*os_context_register_addr(context, \
1795 name##_register_pair) \
1803 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
1804 uword_t
*saved_offset
, int *register_pair
)
1809 * I (RLT) think this is trying to find the boxed register that is
1810 * closest to the LIP address, without going past it. Usually, it's
1811 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
1813 /* 0x7FFFFFFF on 32-bit platforms;
1814 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
1815 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
1816 *register_pair
= -1;
1817 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1822 index
= boxed_registers
[i
];
1823 reg
= *os_context_register_addr(context
, index
);
1825 /* An interior pointer is never relative to a non-pointer
1826 * register (an oversight in the original implementation).
1827 * The simplest argument for why this is true is to consider
1828 * the fixnum that happens by coincide to be the word-index in
1829 * memory of the header for some object plus two. This is
1830 * happenstance would cause the register containing the fixnum
1831 * to be selected as the register_pair if the interior pointer
1832 * is to anywhere after the first two words of the object.
1833 * The fixnum won't be changed during GC, but the object might
1834 * move, thus destroying the interior pointer. --AB,
1837 if (is_lisp_pointer(reg
) &&
1838 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
1839 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
1840 if (offset
< *saved_offset
) {
1841 *saved_offset
= offset
;
1842 *register_pair
= index
;
1849 scavenge_interrupt_context(os_context_t
* context
)
1853 /* FIXME: The various #ifdef noise here is precisely that: noise.
1854 * Is it possible to fold it into the macrology so that we have
1855 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
1856 * compile out for the registers that don't exist on a given
1859 INTERIOR_POINTER_VARS(pc
);
1861 INTERIOR_POINTER_VARS(lip
);
1863 #ifdef ARCH_HAS_LINK_REGISTER
1864 INTERIOR_POINTER_VARS(lr
);
1866 #ifdef ARCH_HAS_NPC_REGISTER
1867 INTERIOR_POINTER_VARS(npc
);
1869 #ifdef LISP_FEATURE_PPC
1870 INTERIOR_POINTER_VARS(ctr
);
1873 PAIR_INTERIOR_POINTER(pc
);
1875 PAIR_INTERIOR_POINTER(lip
);
1877 #ifdef ARCH_HAS_LINK_REGISTER
1878 PAIR_INTERIOR_POINTER(lr
);
1880 #ifdef ARCH_HAS_NPC_REGISTER
1881 PAIR_INTERIOR_POINTER(npc
);
1883 #ifdef LISP_FEATURE_PPC
1884 PAIR_INTERIOR_POINTER(ctr
);
1887 /* Scavenge all boxed registers in the context. */
1888 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
1892 index
= boxed_registers
[i
];
1893 foo
= *os_context_register_addr(context
, index
);
1895 *os_context_register_addr(context
, index
) = foo
;
1897 /* this is unlikely to work as intended on bigendian
1898 * 64 bit platforms */
1900 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
1903 /* Now that the scavenging is done, repair the various interior
1905 FIXUP_INTERIOR_POINTER(pc
);
1907 FIXUP_INTERIOR_POINTER(lip
);
1909 #ifdef ARCH_HAS_LINK_REGISTER
1910 FIXUP_INTERIOR_POINTER(lr
);
1912 #ifdef ARCH_HAS_NPC_REGISTER
1913 FIXUP_INTERIOR_POINTER(npc
);
1915 #ifdef LISP_FEATURE_PPC
1916 FIXUP_INTERIOR_POINTER(ctr
);
1921 scavenge_interrupt_contexts(struct thread
*th
)
1924 os_context_t
*context
;
1926 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
1928 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
1929 printf("Number of active contexts: %d\n", index
);
1932 for (i
= 0; i
< index
; i
++) {
1933 context
= th
->interrupt_contexts
[i
];
1934 scavenge_interrupt_context(context
);
1937 #endif /* x86oid targets */
1939 void varint_unpacker_init(struct varint_unpacker
* unpacker
, lispobj integer
)
1941 if (fixnump(integer
)) {
1942 unpacker
->word
= fixnum_value(integer
);
1943 unpacker
->limit
= N_WORD_BYTES
;
1944 unpacker
->data
= (char*)&unpacker
->word
;
1946 struct bignum
* bignum
= (struct bignum
*)(integer
- OTHER_POINTER_LOWTAG
);
1948 unpacker
->limit
= HeaderValue(bignum
->header
) * N_WORD_BYTES
;
1949 unpacker
->data
= (char*)bignum
->digits
;
1951 unpacker
->index
= 0;
1954 // Fetch the next varint from 'unpacker' into 'result'.
1955 // Because there is no length prefix on the number of varints encoded,
1956 // spurious trailing zeros might be observed. The data consumer can
1957 // circumvent that by storing a count as the first value in the series.
1958 // Return 1 for success, 0 for EOF.
1959 int varint_unpack(struct varint_unpacker
* unpacker
, int* result
)
1961 if (unpacker
->index
>= unpacker
->limit
) return 0;
1962 int accumulator
= 0;
1965 #ifdef LISP_FEATURE_LITTLE_ENDIAN
1966 int byte
= unpacker
->data
[unpacker
->index
];
1968 // bignums are little-endian in word order,
1969 // but machine-native within each word.
1970 // We could pack bytes MSB-to-LSB in the bigdigits,
1971 // but that seems less intuitive on the Lisp side.
1972 int word_index
= unpacker
->index
/ N_WORD_BYTES
;
1973 int byte_index
= unpacker
->index
% N_WORD_BYTES
;
1974 int byte
= (((unsigned int*)unpacker
->data
)[word_index
]
1975 >> (byte_index
* 8)) & 0xFF;
1978 accumulator
|= (byte
& 0x7F) << shift
;
1979 if (!(byte
& 0x80)) break;
1980 gc_assert(unpacker
->index
< unpacker
->limit
);
1983 *result
= accumulator
;