2 * Garbage Collection common functions for scavenging, moving and sizing
3 * objects. These are for use with both GC (stop & copy GC) and GENCGC
7 * This software is part of the SBCL system. See the README file for
10 * This software is derived from the CMU CL system, which was
11 * written at Carnegie Mellon University and released into the
12 * public domain. The software is in the public domain and is
13 * provided with absolutely no warranty. See the COPYING and CREDITS
14 * files for more information.
18 * For a review of garbage collection techniques (e.g. generational
19 * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
20 * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
21 * had been accepted for _ACM Computing Surveys_ and was available
22 * as a PostScript preprint through
23 * <http://www.cs.utexas.edu/users/oops/papers.html>
25 * <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
28 #define _GNU_SOURCE /* for ffsl(3) from string.h */
38 #include "interrupt.h"
43 #include "genesis/primitive-objects.h"
44 #include "genesis/static-symbols.h"
45 #include "genesis/layout.h"
46 #include "genesis/hash-table.h"
47 #include "gc-internal.h"
48 #include "forwarding-ptr.h"
51 #ifdef LISP_FEATURE_SPARC
52 #define LONG_FLOAT_SIZE 4
53 #elif defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
54 #define LONG_FLOAT_SIZE 3
57 os_vm_size_t dynamic_space_size
= DEFAULT_DYNAMIC_SPACE_SIZE
;
58 os_vm_size_t thread_control_stack_size
= DEFAULT_CONTROL_STACK_SIZE
;
60 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
61 lispobj (*transother
[256])(lispobj object
);
62 sword_t (*sizetab
[256])(lispobj
*where
);
63 struct weak_pointer
*weak_pointers
;
65 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
71 /* gc_general_copy_object is inline from gc-internal.h */
73 /* to copy a boxed object */
75 copy_object(lispobj object
, sword_t nwords
)
77 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
81 copy_code_object(lispobj object
, sword_t nwords
)
83 return gc_general_copy_object(object
, nwords
, CODE_PAGE_FLAG
);
86 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
89 scavenge(lispobj
*start
, sword_t n_words
)
91 lispobj
*end
= start
+ n_words
;
94 for (object_ptr
= start
; object_ptr
< end
;) {
95 lispobj object
= *object_ptr
;
96 #ifdef LISP_FEATURE_GENCGC
97 if (forwarding_pointer_p(object_ptr
))
98 lose("unexpected forwarding pointer in scavenge: %p, start=%p, n=%ld\n",
99 object_ptr
, start
, n_words
);
101 if (is_lisp_pointer(object
)) {
102 if (from_space_p(object
)) {
103 /* It currently points to old space. Check for a
104 * forwarding pointer. */
105 lispobj
*ptr
= native_pointer(object
);
106 if (forwarding_pointer_p(ptr
)) {
107 /* Yes, there's a forwarding pointer. */
108 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
111 /* Scavenge that pointer. */
113 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
115 #ifdef LISP_FEATURE_IMMOBILE_SPACE
116 } else if (immobile_space_p(object
)) {
117 lispobj
*ptr
= native_pointer(object
);
118 if (immobile_obj_gen_bits(ptr
) == from_space
)
119 promote_immobile_obj(ptr
, 1);
123 /* It points somewhere other than oldspace. Leave it
128 else if (fixnump(object
)) {
129 /* It's a fixnum: really easy.. */
132 /* It's some sort of header object or another. */
133 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
136 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
137 object_ptr
, start
, end
);
140 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
141 static lispobj
trans_short_boxed(lispobj object
);
144 scav_fun_pointer(lispobj
*where
, lispobj object
)
146 lispobj
*first_pointer
;
149 gc_assert(lowtag_of(object
) == FUN_POINTER_LOWTAG
);
151 /* Object is a pointer into from_space - not a FP. */
152 first_pointer
= (lispobj
*) native_pointer(object
);
154 /* must transport object -- object may point to either a function
155 * header, a closure function header, or to a closure header. */
157 switch (widetag_of(*first_pointer
)) {
158 case SIMPLE_FUN_HEADER_WIDETAG
:
159 copy
= trans_fun_header(object
);
162 copy
= trans_short_boxed(object
);
166 if (copy
!= object
) {
167 /* Set forwarding pointer */
168 set_forwarding_pointer(first_pointer
,copy
);
171 gc_assert(lowtag_of(copy
) == FUN_POINTER_LOWTAG
);
172 gc_assert(!from_space_p(copy
));
181 trans_code(struct code
*code
)
183 /* if object has already been transported, just return pointer */
184 if (forwarding_pointer_p((lispobj
*)code
)) {
186 printf("Was already transported\n");
188 return (struct code
*)native_pointer(forwarding_pointer_value((lispobj
*)code
));
191 gc_assert(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
193 /* prepare to transport the code vector */
194 lispobj l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
195 sword_t nheader_words
= code_header_words(code
->header
);
196 sword_t ncode_words
= code_instruction_words(code
->code_size
);
197 sword_t nwords
= nheader_words
+ ncode_words
;
198 lispobj l_new_code
= copy_code_object(l_code
, nwords
);
199 struct code
*new_code
= (struct code
*) native_pointer(l_new_code
);
201 #if defined(DEBUG_CODE_GC)
202 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
203 (uword_t
) code
, (uword_t
) new_code
);
204 printf("Code object is %d words long.\n", nwords
);
207 #ifdef LISP_FEATURE_GENCGC
208 if (new_code
== code
)
212 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
214 /* set forwarding pointers for all the function headers in the */
215 /* code object. also fix all self pointers */
216 /* Do this by scanning the new code, since the old header is unusable */
218 uword_t displacement
= l_new_code
- l_code
;
220 for_each_simple_fun(i
, nfheaderp
, new_code
, 1, {
221 /* Calculate the old raw function pointer */
222 struct simple_fun
* fheaderp
=
223 (struct simple_fun
*)LOW_WORD((char*)nfheaderp
- displacement
);
224 /* Calculate the new lispobj */
225 lispobj nfheaderl
= make_lispobj(nfheaderp
, FUN_POINTER_LOWTAG
);
228 printf("fheaderp->header (at %x) <- %x\n",
229 &(fheaderp
->header
) , nfheaderl
);
231 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
233 /* fix self pointer. */
235 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
236 FUN_RAW_ADDR_OFFSET
+
240 #ifdef LISP_FEATURE_GENCGC
241 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
242 spaces once when all copying is done. */
243 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
244 ncode_words
* sizeof(sword_t
));
248 #ifdef LISP_FEATURE_X86
249 gencgc_apply_code_fixups(code
, new_code
);
256 scav_code_header(lispobj
*where
, lispobj header
)
258 struct code
*code
= (struct code
*) where
;
259 sword_t n_header_words
= code_header_words(header
);
261 /* Scavenge the boxed section of the code data block. */
262 scavenge(where
+ 1, n_header_words
- 1);
264 /* Scavenge the boxed section of each function object in the
265 * code data block. */
266 for_each_simple_fun(i
, function_ptr
, code
, 1, {
267 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
268 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
271 return n_header_words
+ code_instruction_words(code
->code_size
);
275 trans_code_header(lispobj object
)
279 ncode
= trans_code((struct code
*) native_pointer(object
));
280 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
285 size_code_header(lispobj
*where
)
287 return code_header_words(((struct code
*)where
)->header
)
288 + code_instruction_words(((struct code
*)where
)->code_size
);
291 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
293 scav_return_pc_header(lispobj
*where
, lispobj object
)
295 lose("attempted to scavenge a return PC header where=%p object=%#lx\n",
296 where
, (uword_t
) object
);
297 return 0; /* bogus return value to satisfy static type checking */
299 #endif /* LISP_FEATURE_X86 */
302 trans_return_pc_header(lispobj object
)
304 struct simple_fun
*return_pc
;
306 struct code
*code
, *ncode
;
308 return_pc
= (struct simple_fun
*) native_pointer(object
);
309 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
311 /* Transport the whole code object */
312 code
= (struct code
*) ((uword_t
) return_pc
- offset
);
313 ncode
= trans_code(code
);
315 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
318 /* On the 386, closures hold a pointer to the raw address instead of the
319 * function object, so we can use CALL [$FDEFN+const] to invoke
320 * the function without loading it into a register. Given that code
321 * objects don't move, we don't need to update anything, but we do
322 * have to figure out that the function is still live. */
324 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
326 scav_closure_header(lispobj
*where
, lispobj object
)
328 struct closure
*closure
;
331 closure
= (struct closure
*)where
;
332 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
334 #ifdef LISP_FEATURE_GENCGC
335 /* The function may have moved so update the raw address. But
336 * don't write unnecessarily. */
337 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
338 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
344 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
346 scav_fun_header(lispobj
*where
, lispobj object
)
348 lose("attempted to scavenge a function header where=%p object=%#lx\n",
349 where
, (uword_t
) object
);
350 return 0; /* bogus return value to satisfy static type checking */
352 #endif /* LISP_FEATURE_X86 */
355 trans_fun_header(lispobj object
)
357 struct simple_fun
*fheader
;
359 struct code
*code
, *ncode
;
361 fheader
= (struct simple_fun
*) native_pointer(object
);
362 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
364 /* Transport the whole code object */
365 code
= (struct code
*) ((uword_t
) fheader
- offset
);
366 ncode
= trans_code(code
);
368 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
377 trans_instance(lispobj object
)
379 gc_assert(lowtag_of(object
) == INSTANCE_POINTER_LOWTAG
);
380 lispobj header
= *(lispobj
*)(object
- INSTANCE_POINTER_LOWTAG
);
381 return copy_object(object
, 1 + (instance_length(header
)|1));
385 size_instance(lispobj
*where
)
387 return 1 + (instance_length(*where
)|1);
391 scav_instance_pointer(lispobj
*where
, lispobj object
)
393 lispobj copy
, *first_pointer
;
395 /* Object is a pointer into from space - not a FP. */
396 copy
= trans_instance(object
);
398 #ifdef LISP_FEATURE_GENCGC
399 gc_assert(copy
!= object
);
402 first_pointer
= (lispobj
*) native_pointer(object
);
403 set_forwarding_pointer(first_pointer
,copy
);
414 static lispobj
trans_list(lispobj object
);
417 scav_list_pointer(lispobj
*where
, lispobj object
)
420 gc_assert(lowtag_of(object
) == LIST_POINTER_LOWTAG
);
422 first
= trans_list(object
);
423 gc_assert(first
!= object
);
425 gc_assert(lowtag_of(first
) == LIST_POINTER_LOWTAG
);
426 gc_assert(!from_space_p(first
));
434 trans_list(lispobj object
)
436 lispobj new_list_pointer
;
437 struct cons
*cons
, *new_cons
;
440 cons
= (struct cons
*) native_pointer(object
);
443 new_cons
= (struct cons
*)
444 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
445 new_cons
->car
= cons
->car
;
446 new_cons
->cdr
= cons
->cdr
; /* updated later */
447 new_list_pointer
= make_lispobj(new_cons
, LIST_POINTER_LOWTAG
);
449 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
452 set_forwarding_pointer((lispobj
*)cons
, new_list_pointer
);
454 /* Try to linearize the list in the cdr direction to help reduce
458 struct cons
*cdr_cons
, *new_cdr_cons
;
460 if(lowtag_of(cdr
) != LIST_POINTER_LOWTAG
||
461 !from_space_p(cdr
) ||
462 forwarding_pointer_p((lispobj
*)native_pointer(cdr
)))
465 cdr_cons
= (struct cons
*) native_pointer(cdr
);
468 new_cdr_cons
= (struct cons
*)
469 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
470 new_cdr_cons
->car
= cdr_cons
->car
;
471 new_cdr_cons
->cdr
= cdr_cons
->cdr
;
472 new_cdr
= make_lispobj(new_cdr_cons
, LIST_POINTER_LOWTAG
);
474 /* Grab the cdr before it is clobbered. */
476 set_forwarding_pointer((lispobj
*)cdr_cons
, new_cdr
);
478 /* Update the cdr of the last cons copied into new space to
479 * keep the newspace scavenge from having to do it. */
480 new_cons
->cdr
= new_cdr
;
482 new_cons
= new_cdr_cons
;
485 return new_list_pointer
;
490 * scavenging and transporting other pointers
494 scav_other_pointer(lispobj
*where
, lispobj object
)
496 lispobj first
, *first_pointer
;
498 gc_assert(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
500 /* Object is a pointer into from space - not FP. */
501 first_pointer
= (lispobj
*)(object
- OTHER_POINTER_LOWTAG
);
502 first
= (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 (first
!= object
) {
508 set_forwarding_pointer(first_pointer
, first
);
509 #ifdef LISP_FEATURE_GENCGC
513 #ifndef LISP_FEATURE_GENCGC
516 gc_assert(lowtag_of(first
) == OTHER_POINTER_LOWTAG
);
517 gc_assert(!from_space_p(first
));
523 * immediate, boxed, and unboxed objects
527 size_pointer(lispobj
*where
)
533 scav_immediate(lispobj
*where
, lispobj object
)
539 trans_immediate(lispobj object
)
541 lose("trying to transport an immediate\n");
542 return NIL
; /* bogus return value to satisfy static type checking */
546 size_immediate(lispobj
*where
)
553 scav_boxed(lispobj
*where
, lispobj object
)
558 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
560 /* If the bignum in the layout has another pointer to it (besides the layout)
561 acting as a root, and which is scavenged first, then transporting the
562 bignum causes the layout to see a FP, as would copying an instance whose
563 layout that is. This is a nearly impossible scenario to create organically
564 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
565 except for a few things that would cause it to be pinned anyway,
566 such as it being kept in a local variable during structure manipulation.
567 See 'interleaved-raw.impure.lisp' for a way to trigger this */
568 if (forwarding_pointer_p((lispobj
*)bignum
)) {
569 lispobj forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
571 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
572 (void*)bignum
, (void*)forwarded
);
574 bignum
= (struct bignum
*)native_pointer(forwarded
);
577 int len
= HeaderValue(bignum
->header
);
578 int word_index
= index
/ N_WORD_BITS
;
579 int bit_index
= index
% N_WORD_BITS
;
580 if (word_index
>= len
) {
581 // just return 0 since the marking logic does not allow negative bignums
584 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
588 struct instance_scanner
{
590 void (*proc
)(lispobj
*, sword_t
);
593 // Helper function for helper function below, since lambda isn't a thing
594 static void instance_scan_range(void* arg
, int offset
, int nwords
)
596 struct instance_scanner
*scanner
= (struct instance_scanner
*)arg
;
597 scanner
->proc(scanner
->base
+ offset
, nwords
);
600 // Helper function for stepping through the tagged slots of an instance in
601 // scav_instance and verify_space.
603 instance_scan(void (*proc
)(lispobj
*, sword_t
),
604 lispobj
*instance_slots
,
606 lispobj layout_bitmap
)
610 /* This code might be made more efficient by run-length-encoding the ranges
611 of words to scan, but probably not by much */
613 if (fixnump(layout_bitmap
)) {
614 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
615 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
617 proc(instance_slots
+ index
, 1);
618 } else { /* huge bitmap */
619 struct bignum
* bitmap
;
620 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
621 if (forwarding_pointer_p((lispobj
*)bitmap
))
622 bitmap
= (struct bignum
*)
623 native_pointer(forwarding_pointer_value((lispobj
*)bitmap
));
624 struct instance_scanner scanner
;
625 scanner
.base
= instance_slots
;
627 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
628 instance_scan_range
, &scanner
);
632 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
633 void (*proc
)(void*, int, int), void* arg
)
635 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
636 int start_word_index
= 0;
638 in_use_marker_t word
;
640 flags
= flags
& BIT_SCAN_CLEAR
;
642 // Rather than bzero'ing we can just clear each nonzero word as it's read,
644 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
647 int skip_bits
, start_bit
, start_position
, run_length
;
649 if (++start_word_index
>= n_bitmap_words
) break;
650 BITMAP_REF(start_word_index
);
654 // On each loop iteration, the lowest 1 bit is a "relative"
655 // bit index, since the word was already shifted. This is 'skip_bits'.
656 // Adding back in the total shift amount gives 'start_bit',
657 // the true absolute index within the current word.
658 // 'start_position' is absolute within the entire bitmap.
659 skip_bits
= ffsl(word
) - 1;
660 start_bit
= skip_bits
+ shift
;
661 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
662 // Compute the number of consecutive 1s in the current word.
664 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
665 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
667 shift
+= skip_bits
+ run_length
;
669 int end_word_index
= ++start_word_index
;
671 if (end_word_index
>= n_bitmap_words
) {
673 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
676 BITMAP_REF(end_word_index
);
680 // end_word_index is the exclusive bound on contiguous
681 // words to include in the range. See if the low bits
682 // from the next word can extend the range.
683 shift
= ffsl(~word
) - 1;
685 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
690 start_word_index
= end_word_index
;
692 proc(arg
, start_position
, run_length
);
698 scav_instance(lispobj
*where
, lispobj header
)
700 lispobj
* layout
= (lispobj
*)instance_layout(where
);
703 layout
= native_pointer((lispobj
)layout
);
704 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
705 if (__immobile_obj_gen_bits(layout
) == from_space
)
706 promote_immobile_obj(layout
, 1);
708 if (forwarding_pointer_p(layout
))
709 layout
= native_pointer(forwarding_pointer_value(layout
));
712 sword_t nslots
= instance_length(header
) | 1;
713 lispobj bitmap
= ((struct layout
*)layout
)->bitmap
;
714 if (bitmap
== make_fixnum(-1))
715 scavenge(where
+1, nslots
);
717 instance_scan(scavenge
, where
+1, nslots
, bitmap
);
722 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
724 scav_funinstance(lispobj
*where
, lispobj header
)
726 // This works because the layout is in the header word of all instances,
727 // ordinary and funcallable, when compact headers are enabled.
728 // The trampoline slot in the funcallable-instance is raw, but can be
729 // scavenged, because it points to readonly space, never oldspace.
730 // (And for certain backends it looks like a fixnum, not a pointer)
731 return scav_instance(where
, header
);
735 static lispobj
trans_boxed(lispobj object
)
737 gc_assert(is_lisp_pointer(object
));
738 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
739 return copy_object(object
, CEILING(length
, 2));
742 static sword_t
size_boxed(lispobj
*where
)
744 sword_t length
= HeaderValue(*where
) + 1;
745 return CEILING(length
, 2);
748 static lispobj
trans_short_boxed(lispobj object
) // 2 byte size
750 sword_t length
= (HeaderValue(*native_pointer(object
)) & 0xFFFF) + 1;
751 return copy_object(object
, CEILING(length
, 2));
754 static sword_t
size_short_boxed(lispobj
*where
)
756 sword_t length
= (HeaderValue(*where
) & 0xFFFF) + 1;
757 return CEILING(length
, 2);
760 static lispobj
trans_tiny_boxed(lispobj object
)
762 sword_t length
= (HeaderValue(*native_pointer(object
)) & 0xFF) + 1;
763 return copy_object(object
, CEILING(length
, 2));
766 static sword_t
size_tiny_boxed(lispobj
*where
)
768 sword_t length
= (HeaderValue(*where
) & 0xFF) + 1;
769 return CEILING(length
, 2);
772 /* Note: on the sparc we don't have to do anything special for fdefns, */
773 /* 'cause the raw-addr has a function lowtag. */
774 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
776 scav_fdefn(lispobj
*where
, lispobj object
)
780 fdefn
= (struct fdefn
*)where
;
782 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
783 fdefn->fun, fdefn->raw_addr)); */
785 scavenge(where
+ 1, 2); // 'name' and 'fun'
786 #ifndef LISP_FEATURE_IMMOBILE_CODE
787 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
788 if (raw_fun
> READ_ONLY_SPACE_END
) {
789 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
790 scavenge(&simple_fun
, 1);
791 /* Don't write unnecessarily. */
792 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
793 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
795 #elif defined(LISP_FEATURE_X86_64)
796 lispobj obj
= fdefn_raw_referent(fdefn
);
799 scavenge(&new, 1); // enliven
800 gc_assert(new == obj
); // must not move
803 # error "Need to implement scav_fdefn"
810 scav_unboxed(lispobj
*where
, lispobj object
)
812 sword_t length
= HeaderValue(object
) + 1;
813 return CEILING(length
, 2);
817 trans_unboxed(lispobj object
)
819 gc_assert(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
820 sword_t length
= HeaderValue(*native_pointer(object
)) + 1;
821 return copy_unboxed_object(object
, CEILING(length
, 2));
825 size_unboxed(lispobj
*where
)
827 sword_t length
= HeaderValue(*where
) + 1;
828 return CEILING(length
, 2);
832 /* vector-like objects */
834 trans_vector(lispobj object
)
836 gc_assert(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
839 fixnum_value(((struct vector
*)native_pointer(object
))->length
);
840 return copy_large_object(object
, CEILING(length
+ 2, 2));
844 size_vector(lispobj
*where
)
846 sword_t length
= fixnum_value(((struct vector
*)where
)->length
);
847 return CEILING(length
+ 2, 2);
850 #define DEF_SCAV_TRANS_SIZE_UB(nbits) \
851 DEF_SPECIALIZED_VECTOR(vector_unsigned_byte_##nbits, NWORDS(length, nbits))
852 #define DEF_SPECIALIZED_VECTOR(name, nwords) \
853 static sword_t __attribute__((unused)) scav_##name(lispobj *where, lispobj header) { \
854 sword_t length = fixnum_value(((struct vector*)where)->length); \
855 return CEILING(nwords + 2, 2); \
857 static lispobj __attribute__((unused)) trans_##name(lispobj object) { \
858 gc_assert(lowtag_of(object)==OTHER_POINTER_LOWTAG); \
859 sword_t length = fixnum_value(((struct vector*)(object-OTHER_POINTER_LOWTAG))->length); \
860 return copy_large_unboxed_object(object, CEILING(nwords + 2, 2)); \
862 static sword_t __attribute__((unused)) size_##name(lispobj *where) { \
863 sword_t length = fixnum_value(((struct vector*)where)->length); \
864 return CEILING(nwords + 2, 2); \
867 DEF_SPECIALIZED_VECTOR(vector_nil
, 0*length
)
868 DEF_SPECIALIZED_VECTOR(vector_bit
, NWORDS(length
,1))
869 /* NOTE: strings contain one more element of data (a terminating '\0'
870 * to help interface with C functions) than indicated by the length slot.
871 * This is true even for UCS4 strings, despite that C APIs are unlikely
872 * to have a convention that expects 4 zero bytes. */
873 DEF_SPECIALIZED_VECTOR(base_string
, NWORDS((length
+1), 8))
874 DEF_SPECIALIZED_VECTOR(character_string
, NWORDS((length
+1), 32))
875 DEF_SCAV_TRANS_SIZE_UB(2)
876 DEF_SCAV_TRANS_SIZE_UB(4)
877 DEF_SCAV_TRANS_SIZE_UB(8)
878 DEF_SCAV_TRANS_SIZE_UB(16)
879 DEF_SCAV_TRANS_SIZE_UB(32)
880 DEF_SCAV_TRANS_SIZE_UB(64)
881 DEF_SCAV_TRANS_SIZE_UB(128)
882 #ifdef LONG_FLOAT_SIZE
883 DEF_SPECIALIZED_VECTOR(vector_long_float
, length
* LONG_FLOAT_SIZE
)
884 DEF_SPECIALIZED_VECTOR(vector_complex_long_float
, length
* (2 * LONG_FLOAT_SIZE
))
887 #define WEAK_POINTER_NWORDS \
888 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
891 trans_weak_pointer(lispobj object
)
894 #ifndef LISP_FEATURE_GENCGC
895 struct weak_pointer
*wp
;
897 gc_assert(lowtag_of(object
) == OTHER_POINTER_LOWTAG
);
899 #if defined(DEBUG_WEAK)
900 printf("Transporting weak pointer from 0x%08x\n", object
);
903 /* Need to remember where all the weak pointers are that have */
904 /* been transported so they can be fixed up in a post-GC pass. */
906 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
907 #ifndef LISP_FEATURE_GENCGC
908 wp
= (struct weak_pointer
*) native_pointer(copy
);
910 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
911 /* Push the weak pointer onto the list of weak pointers. */
912 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
919 size_weak_pointer(lispobj
*where
)
921 return WEAK_POINTER_NWORDS
;
925 void scan_weak_pointers(void)
927 struct weak_pointer
*wp
, *next_wp
;
928 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
929 lispobj value
= wp
->value
;
930 lispobj
*first_pointer
;
931 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
935 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
938 if (!is_lisp_pointer(value
))
941 /* Now, we need to check whether the object has been forwarded. If
942 * it has been, the weak pointer is still good and needs to be
943 * updated. Otherwise, the weak pointer needs to be nil'ed
946 if (from_space_p(value
)) {
947 first_pointer
= (lispobj
*)native_pointer(value
);
949 if (forwarding_pointer_p(first_pointer
)) {
950 wp
->value
= LOW_WORD(forwarding_pointer_value(first_pointer
));
957 #ifdef LISP_FEATURE_IMMOBILE_SPACE
958 else if (immobile_space_p(value
) &&
959 immobile_obj_gen_bits(native_pointer(value
)) == from_space
) {
970 #if N_WORD_BITS == 32
971 #define EQ_HASH_MASK 0x1fffffff
972 #elif N_WORD_BITS == 64
973 #define EQ_HASH_MASK 0x1fffffffffffffff
976 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
977 * target-hash-table.lisp. */
978 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
980 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
981 * slot. Set to NULL at the end of a collection.
983 * This is not optimal because, when a table is tenured, it won't be
984 * processed automatically; only the yougest generation is GC'd by
985 * default. On the other hand, all applications will need an
986 * occasional full GC anyway, so it's not that bad either. */
987 struct hash_table
*weak_hash_tables
= NULL
;
989 /* Return true if OBJ has already survived the current GC. */
991 survived_gc_yet (lispobj obj
)
993 #ifdef LISP_FEATURE_IMMOBILE_SPACE
994 /* If an immobile object's generation# is that of 'from_space', but has been
995 visited (i.e. is live), then it is conceptually not in 'from_space'.
996 This can happen when and only when _not_ raising the generation number.
997 Since the gen_bits() accessor returns the visited bit, the byte value
998 is numerically unequal to 'from_space', which is what we want */
999 return !is_lisp_pointer(obj
)
1000 || (immobile_space_p(obj
)
1001 ? immobile_obj_gen_bits(native_pointer(obj
)) != from_space
1002 : (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
))));
1004 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1005 forwarding_pointer_p(native_pointer(obj
)));
1009 static int survived_gc_yet_KEY(lispobj key
, lispobj value
) {
1010 return survived_gc_yet(key
);
1012 static int survived_gc_yet_VALUE(lispobj key
, lispobj value
) {
1013 return survived_gc_yet(value
);
1015 static int survived_gc_yet_AND(lispobj key
, lispobj value
) {
1016 return survived_gc_yet(key
) && survived_gc_yet(value
);
1018 static int survived_gc_yet_OR(lispobj key
, lispobj value
) {
1019 return survived_gc_yet(key
) || survived_gc_yet(value
);
1022 static int (*weak_hash_entry_alivep_fun(lispobj weakness
))(lispobj
,lispobj
)
1025 case KEY
: return survived_gc_yet_KEY
;
1026 case VALUE
: return survived_gc_yet_VALUE
;
1027 case KEY_OR_VALUE
: return survived_gc_yet_OR
;
1028 case KEY_AND_VALUE
: return survived_gc_yet_AND
;
1029 case NIL
: return NULL
;
1030 default: lose("Bad hash table weakness");
1034 /* Return the beginning of data in ARRAY (skipping the header and the
1035 * length) or NULL if it isn't an array of the specified widetag after
1037 static inline lispobj
*
1038 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1040 if (is_lisp_pointer(array
) &&
1041 (widetag_of(*(lispobj
*)native_pointer(array
)) == widetag
)) {
1043 *length
= fixnum_value(((lispobj
*)native_pointer(array
))[1]);
1044 return ((lispobj
*)native_pointer(array
)) + 2;
1050 /* Only need to worry about scavenging the _real_ entries in the
1051 * table. Phantom entries such as the hash table itself at index 0 and
1052 * the empty marker at index 1 were scavenged by scav_vector that
1053 * either called this function directly or arranged for it to be
1054 * called later by pushing the hash table onto weak_hash_tables. */
1056 scav_hash_table_entries (struct hash_table
*hash_table
)
1060 lispobj
*index_vector
;
1062 lispobj
*next_vector
;
1063 uword_t next_vector_length
;
1064 lispobj
*hash_vector
;
1065 uword_t hash_vector_length
;
1066 lispobj empty_symbol
;
1067 lispobj weakness
= hash_table
->weakness
;
1070 kv_vector
= get_array_data(hash_table
->table
,
1071 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1072 if (kv_vector
== NULL
)
1073 lose("invalid kv_vector %x\n", hash_table
->table
);
1075 index_vector
= get_array_data(hash_table
->index_vector
,
1076 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1077 if (index_vector
== NULL
)
1078 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1080 next_vector
= get_array_data(hash_table
->next_vector
,
1081 SIMPLE_ARRAY_WORD_WIDETAG
,
1082 &next_vector_length
);
1083 if (next_vector
== NULL
)
1084 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1086 hash_vector
= get_array_data(hash_table
->hash_vector
,
1087 SIMPLE_ARRAY_WORD_WIDETAG
,
1088 &hash_vector_length
);
1089 if (hash_vector
!= NULL
)
1090 gc_assert(hash_vector_length
== next_vector_length
);
1092 /* These lengths could be different as the index_vector can be a
1093 * different length from the others, a larger index_vector could
1094 * help reduce collisions. */
1095 gc_assert(next_vector_length
*2 == kv_length
);
1097 empty_symbol
= kv_vector
[1];
1098 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1099 if (widetag_of(*(lispobj
*)native_pointer(empty_symbol
)) !=
1100 SYMBOL_HEADER_WIDETAG
) {
1101 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1102 *(lispobj
*)native_pointer(empty_symbol
));
1105 /* Work through the KV vector. */
1106 int (*alivep_test
)(lispobj
,lispobj
) = weak_hash_entry_alivep_fun(weakness
);
1107 #define SCAV_ENTRIES(aliveness_predicate) \
1108 for (i = 1; i < next_vector_length; i++) { \
1109 lispobj old_key = kv_vector[2*i]; \
1110 lispobj __attribute__((unused)) value = kv_vector[2*i+1]; \
1111 if (aliveness_predicate) { \
1112 /* Scavenge the key and value. */ \
1113 scavenge(&kv_vector[2*i], 2); \
1114 /* If an EQ-based key has moved, mark the hash-table for rehash */ \
1115 if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) { \
1116 lispobj new_key = kv_vector[2*i]; \
1117 if (old_key != new_key && new_key != empty_symbol) \
1118 hash_table->needs_rehash_p = T; \
1121 SCAV_ENTRIES(alivep_test(old_key
, value
))
1127 scav_vector (lispobj
*where
, lispobj object
)
1130 struct hash_table
*hash_table
;
1132 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1133 * hash tables in the Lisp HASH-TABLE code to indicate need for
1134 * special GC support. */
1135 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
)
1138 kv_length
= fixnum_value(where
[1]);
1139 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1141 /* Scavenge element 0, which may be a hash-table structure. */
1142 scavenge(where
+2, 1);
1143 if (!is_lisp_pointer(where
[2])) {
1144 /* This'll happen when REHASH clears the header of old-kv-vector
1145 * and fills it with zero, but some other thread simulatenously
1146 * sets the header in %%PUTHASH.
1149 "Warning: no pointer at %p in hash table: this indicates "
1150 "non-fatal corruption caused by concurrent access to a "
1151 "hash-table from multiple threads. Any accesses to "
1152 "hash-tables shared between threads should be protected "
1153 "by locks.\n", (void*)&where
[2]);
1154 // We've scavenged three words.
1157 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1158 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1159 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1160 lose("hash table not instance (%x at %x)\n",
1165 /* Scavenge element 1, which should be some internal symbol that
1166 * the hash table code reserves for marking empty slots. */
1167 scavenge(where
+3, 1);
1168 if (!is_lisp_pointer(where
[3])) {
1169 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1172 /* Scavenge hash table, which will fix the positions of the other
1173 * needed objects. */
1174 scavenge((lispobj
*)hash_table
,
1175 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1177 /* Cross-check the kv_vector. */
1178 if (where
!= (lispobj
*)native_pointer(hash_table
->table
)) {
1179 lose("hash_table table!=this table %x\n", hash_table
->table
);
1182 if (hash_table
->weakness
== NIL
) {
1183 scav_hash_table_entries(hash_table
);
1185 /* Delay scavenging of this table by pushing it onto
1186 * weak_hash_tables (if it's not there already) for the weak
1188 if (hash_table
->next_weak_hash_table
== NIL
) {
1189 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1190 weak_hash_tables
= hash_table
;
1194 return (CEILING(kv_length
+ 2, 2));
1198 scav_weak_hash_tables (void)
1200 struct hash_table
*table
;
1202 /* Scavenge entries whose triggers are known to survive. */
1203 for (table
= weak_hash_tables
; table
!= NULL
;
1204 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1205 scav_hash_table_entries(table
);
1209 /* Walk through the chain whose first element is *FIRST and remove
1210 * dead weak entries. */
1212 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1213 lispobj
*kv_vector
, lispobj
*index_vector
,
1214 lispobj
*next_vector
, lispobj
*hash_vector
,
1215 lispobj empty_symbol
, int (*alivep_test
)(lispobj
,lispobj
))
1217 unsigned index
= *prev
;
1219 unsigned next
= next_vector
[index
];
1220 lispobj key
= kv_vector
[2 * index
];
1221 lispobj value
= kv_vector
[2 * index
+ 1];
1222 gc_assert(key
!= empty_symbol
);
1223 gc_assert(value
!= empty_symbol
);
1224 if (!alivep_test(key
, value
)) {
1225 unsigned count
= fixnum_value(hash_table
->number_entries
);
1226 gc_assert(count
> 0);
1228 hash_table
->number_entries
= make_fixnum(count
- 1);
1229 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1230 hash_table
->next_free_kv
= make_fixnum(index
);
1231 kv_vector
[2 * index
] = empty_symbol
;
1232 kv_vector
[2 * index
+ 1] = empty_symbol
;
1234 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1236 prev
= &next_vector
[index
];
1243 scan_weak_hash_table (struct hash_table
*hash_table
)
1246 lispobj
*index_vector
;
1247 uword_t length
= 0; /* prevent warning */
1248 lispobj
*next_vector
;
1249 uword_t next_vector_length
= 0; /* prevent warning */
1250 lispobj
*hash_vector
;
1251 lispobj empty_symbol
;
1252 lispobj weakness
= hash_table
->weakness
;
1255 kv_vector
= get_array_data(hash_table
->table
,
1256 SIMPLE_VECTOR_WIDETAG
, NULL
);
1257 index_vector
= get_array_data(hash_table
->index_vector
,
1258 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1259 next_vector
= get_array_data(hash_table
->next_vector
,
1260 SIMPLE_ARRAY_WORD_WIDETAG
,
1261 &next_vector_length
);
1262 hash_vector
= get_array_data(hash_table
->hash_vector
,
1263 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1264 empty_symbol
= kv_vector
[1];
1266 for (i
= 0; i
< length
; i
++) {
1267 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
1268 kv_vector
, index_vector
, next_vector
,
1269 hash_vector
, empty_symbol
,
1270 weak_hash_entry_alivep_fun(weakness
));
1274 /* Remove dead entries from weak hash tables. */
1276 scan_weak_hash_tables (void)
1278 struct hash_table
*table
, *next
;
1280 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1281 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1282 table
->next_weak_hash_table
= NIL
;
1283 scan_weak_hash_table(table
);
1286 weak_hash_tables
= NULL
;
1295 scav_lose(lispobj
*where
, lispobj object
)
1297 lose("no scavenge function for object %p (widetag 0x%x)\n",
1299 widetag_of(*where
));
1301 return 0; /* bogus return value to satisfy static type checking */
1305 trans_lose(lispobj object
)
1307 lose("no transport function for object %p (widetag 0x%x)\n",
1309 widetag_of(*(lispobj
*)native_pointer(object
)));
1310 return NIL
; /* bogus return value to satisfy static type checking */
1314 size_lose(lispobj
*where
)
1316 lose("no size function for object at %p (widetag 0x%x)\n",
1318 widetag_of(*where
));
1319 return 1; /* bogus return value to satisfy static type checking */
1328 gc_init_tables(void)
1332 /* Set default value in all slots of scavenge table. FIXME
1333 * replace this gnarly sizeof with something based on
1335 for (i
= 0; i
< ((sizeof scavtab
)/(sizeof scavtab
[0])); i
++) {
1336 scavtab
[i
] = scav_lose
;
1339 /* For each type which can be selected by the lowtag alone, set
1340 * multiple entries in our widetag scavenge table (one for each
1341 * possible value of the high bits).
1344 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
1345 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
1347 scavtab
[j
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
1350 scavtab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_fun_pointer
;
1351 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1352 scavtab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_list_pointer
;
1353 scavtab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] =
1354 scav_instance_pointer
;
1355 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1356 scavtab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_other_pointer
;
1359 /* Other-pointer types (those selected by all eight bits of the
1360 * tag) get one entry each in the scavenge table. */
1361 scavtab
[BIGNUM_WIDETAG
] = scav_unboxed
;
1362 scavtab
[RATIO_WIDETAG
] = scav_boxed
;
1363 #if N_WORD_BITS == 64
1364 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_immediate
;
1366 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
1368 scavtab
[DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
1369 #ifdef LONG_FLOAT_WIDETAG
1370 scavtab
[LONG_FLOAT_WIDETAG
] = scav_unboxed
;
1372 scavtab
[COMPLEX_WIDETAG
] = scav_boxed
;
1373 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1374 scavtab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
1376 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1377 scavtab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
1379 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1380 scavtab
[COMPLEX_LONG_FLOAT_WIDETAG
] = scav_unboxed
;
1382 #ifdef SIMD_PACK_WIDETAG
1383 scavtab
[SIMD_PACK_WIDETAG
] = scav_unboxed
;
1385 scavtab
[SIMPLE_ARRAY_WIDETAG
] = scav_boxed
;
1386 scavtab
[SIMPLE_BASE_STRING_WIDETAG
] = scav_base_string
;
1387 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1388 scavtab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = scav_character_string
;
1390 scavtab
[SIMPLE_BIT_VECTOR_WIDETAG
] = scav_vector_bit
;
1391 scavtab
[SIMPLE_ARRAY_NIL_WIDETAG
] = scav_vector_nil
;
1392 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
1393 scav_vector_unsigned_byte_2
;
1394 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
1395 scav_vector_unsigned_byte_4
;
1396 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
1397 scav_vector_unsigned_byte_8
;
1398 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
1399 scav_vector_unsigned_byte_8
;
1400 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
1401 scav_vector_unsigned_byte_16
;
1402 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
1403 scav_vector_unsigned_byte_16
;
1404 #if (N_WORD_BITS == 32)
1405 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1406 scav_vector_unsigned_byte_32
;
1408 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
1409 scav_vector_unsigned_byte_32
;
1410 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
1411 scav_vector_unsigned_byte_32
;
1412 #if (N_WORD_BITS == 64)
1413 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1414 scav_vector_unsigned_byte_64
;
1416 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1417 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
1418 scav_vector_unsigned_byte_64
;
1420 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1421 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
1422 scav_vector_unsigned_byte_64
;
1424 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1425 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = scav_vector_unsigned_byte_8
;
1427 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1428 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
1429 scav_vector_unsigned_byte_16
;
1431 #if (N_WORD_BITS == 32)
1432 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1433 scav_vector_unsigned_byte_32
;
1435 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1436 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
1437 scav_vector_unsigned_byte_32
;
1439 #if (N_WORD_BITS == 64)
1440 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1441 scav_vector_unsigned_byte_64
;
1443 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1444 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
1445 scav_vector_unsigned_byte_64
;
1447 scavtab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = scav_vector_unsigned_byte_32
;
1448 scavtab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = scav_vector_unsigned_byte_64
;
1449 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1450 scavtab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = scav_vector_long_float
;
1452 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1453 scavtab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_vector_unsigned_byte_64
;
1455 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1456 scavtab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_vector_unsigned_byte_128
;
1458 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1459 scavtab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
1460 scav_vector_complex_long_float
;
1462 scavtab
[COMPLEX_BASE_STRING_WIDETAG
] = scav_boxed
;
1463 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1464 scavtab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = scav_boxed
;
1466 scavtab
[COMPLEX_VECTOR_NIL_WIDETAG
] = scav_boxed
;
1467 scavtab
[COMPLEX_BIT_VECTOR_WIDETAG
] = scav_boxed
;
1468 scavtab
[COMPLEX_VECTOR_WIDETAG
] = scav_boxed
;
1469 scavtab
[COMPLEX_ARRAY_WIDETAG
] = scav_boxed
;
1470 scavtab
[CODE_HEADER_WIDETAG
] = scav_code_header
;
1471 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1472 scavtab
[SIMPLE_FUN_HEADER_WIDETAG
] = scav_fun_header
;
1473 scavtab
[RETURN_PC_HEADER_WIDETAG
] = scav_return_pc_header
;
1475 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
1476 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_funinstance
;
1478 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_boxed
;
1480 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
1481 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_closure_header
;
1483 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_boxed
;
1485 scavtab
[VALUE_CELL_HEADER_WIDETAG
] = scav_boxed
;
1486 scavtab
[SYMBOL_HEADER_WIDETAG
] = scav_boxed
;
1487 scavtab
[CHARACTER_WIDETAG
] = scav_immediate
;
1488 scavtab
[SAP_WIDETAG
] = scav_unboxed
;
1489 scavtab
[UNBOUND_MARKER_WIDETAG
] = scav_immediate
;
1490 scavtab
[NO_TLS_VALUE_MARKER_WIDETAG
] = scav_immediate
;
1491 scavtab
[INSTANCE_HEADER_WIDETAG
] = scav_instance
;
1492 #if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
1493 scavtab
[FDEFN_WIDETAG
] = scav_boxed
;
1495 scavtab
[FDEFN_WIDETAG
] = scav_fdefn
;
1497 scavtab
[SIMPLE_VECTOR_WIDETAG
] = scav_vector
;
1499 /* transport other table, initialized same way as scavtab */
1500 for (i
= 0; i
< ((sizeof transother
)/(sizeof transother
[0])); i
++)
1501 transother
[i
] = trans_lose
;
1502 transother
[BIGNUM_WIDETAG
] = trans_unboxed
;
1503 transother
[RATIO_WIDETAG
] = trans_boxed
;
1505 #if N_WORD_BITS == 64
1506 transother
[SINGLE_FLOAT_WIDETAG
] = trans_immediate
;
1508 transother
[SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
1510 transother
[DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
1511 #ifdef LONG_FLOAT_WIDETAG
1512 transother
[LONG_FLOAT_WIDETAG
] = trans_unboxed
;
1514 transother
[COMPLEX_WIDETAG
] = trans_boxed
;
1515 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1516 transother
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
1518 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1519 transother
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
1521 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1522 transother
[COMPLEX_LONG_FLOAT_WIDETAG
] = trans_unboxed
;
1524 transother
[SIMPLE_ARRAY_WIDETAG
] = trans_boxed
; /* but not GENCGC */
1525 transother
[SIMPLE_BASE_STRING_WIDETAG
] = trans_base_string
;
1526 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1527 transother
[SIMPLE_CHARACTER_STRING_WIDETAG
] = trans_character_string
;
1529 transother
[SIMPLE_BIT_VECTOR_WIDETAG
] = trans_vector_bit
;
1530 transother
[SIMPLE_VECTOR_WIDETAG
] = trans_vector
;
1531 transother
[SIMPLE_ARRAY_NIL_WIDETAG
] = trans_vector_nil
;
1532 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
1533 trans_vector_unsigned_byte_2
;
1534 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
1535 trans_vector_unsigned_byte_4
;
1536 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
1537 trans_vector_unsigned_byte_8
;
1538 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
1539 trans_vector_unsigned_byte_8
;
1540 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
1541 trans_vector_unsigned_byte_16
;
1542 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
1543 trans_vector_unsigned_byte_16
;
1544 #if (N_WORD_BITS == 32)
1545 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1546 trans_vector_unsigned_byte_32
;
1548 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
1549 trans_vector_unsigned_byte_32
;
1550 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
1551 trans_vector_unsigned_byte_32
;
1552 #if (N_WORD_BITS == 64)
1553 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1554 trans_vector_unsigned_byte_64
;
1556 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1557 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
1558 trans_vector_unsigned_byte_64
;
1560 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1561 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
1562 trans_vector_unsigned_byte_64
;
1564 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1565 transother
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] =
1566 trans_vector_unsigned_byte_8
;
1568 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1569 transother
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
1570 trans_vector_unsigned_byte_16
;
1572 #if (N_WORD_BITS == 32)
1573 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1574 trans_vector_unsigned_byte_32
;
1576 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1577 transother
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
1578 trans_vector_unsigned_byte_32
;
1580 #if (N_WORD_BITS == 64)
1581 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1582 trans_vector_unsigned_byte_64
;
1584 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1585 transother
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
1586 trans_vector_unsigned_byte_64
;
1588 transother
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = trans_vector_unsigned_byte_32
;
1589 transother
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = trans_vector_unsigned_byte_64
;
1590 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1591 transother
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] =
1592 trans_vector_long_float
;
1594 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1595 transother
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_vector_unsigned_byte_64
;
1597 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1598 transother
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_vector_unsigned_byte_128
;
1600 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1601 transother
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
1602 trans_vector_complex_long_float
;
1604 transother
[COMPLEX_BASE_STRING_WIDETAG
] = trans_boxed
;
1605 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1606 transother
[COMPLEX_CHARACTER_STRING_WIDETAG
] = trans_boxed
;
1608 transother
[COMPLEX_BIT_VECTOR_WIDETAG
] = trans_boxed
;
1609 transother
[COMPLEX_VECTOR_NIL_WIDETAG
] = trans_boxed
;
1610 transother
[COMPLEX_VECTOR_WIDETAG
] = trans_boxed
;
1611 transother
[COMPLEX_ARRAY_WIDETAG
] = trans_boxed
;
1612 transother
[CODE_HEADER_WIDETAG
] = trans_code_header
;
1613 transother
[SIMPLE_FUN_HEADER_WIDETAG
] = trans_fun_header
;
1614 transother
[RETURN_PC_HEADER_WIDETAG
] = trans_return_pc_header
;
1615 transother
[CLOSURE_HEADER_WIDETAG
] = trans_short_boxed
;
1616 transother
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = trans_short_boxed
;
1617 transother
[VALUE_CELL_HEADER_WIDETAG
] = trans_boxed
;
1618 transother
[SYMBOL_HEADER_WIDETAG
] = trans_tiny_boxed
;
1619 transother
[CHARACTER_WIDETAG
] = trans_immediate
;
1620 transother
[SAP_WIDETAG
] = trans_unboxed
;
1621 #ifdef SIMD_PACK_WIDETAG
1622 transother
[SIMD_PACK_WIDETAG
] = trans_unboxed
;
1624 transother
[UNBOUND_MARKER_WIDETAG
] = trans_immediate
;
1625 transother
[NO_TLS_VALUE_MARKER_WIDETAG
] = trans_immediate
;
1626 transother
[WEAK_POINTER_WIDETAG
] = trans_weak_pointer
;
1627 transother
[INSTANCE_HEADER_WIDETAG
] = trans_instance
;
1628 transother
[FDEFN_WIDETAG
] = trans_tiny_boxed
;
1630 /* size table, initialized the same way as scavtab */
1631 for (i
= 0; i
< ((sizeof sizetab
)/(sizeof sizetab
[0])); i
++)
1632 sizetab
[i
] = size_lose
;
1633 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
1634 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
1636 sizetab
[j
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
1639 sizetab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
1640 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1641 sizetab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
1642 sizetab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
1643 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1644 sizetab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
1646 sizetab
[BIGNUM_WIDETAG
] = size_unboxed
;
1647 sizetab
[RATIO_WIDETAG
] = size_boxed
;
1648 #if N_WORD_BITS == 64
1649 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_immediate
;
1651 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
1653 sizetab
[DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
1654 #ifdef LONG_FLOAT_WIDETAG
1655 sizetab
[LONG_FLOAT_WIDETAG
] = size_unboxed
;
1657 sizetab
[COMPLEX_WIDETAG
] = size_boxed
;
1658 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1659 sizetab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
1661 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1662 sizetab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
1664 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1665 sizetab
[COMPLEX_LONG_FLOAT_WIDETAG
] = size_unboxed
;
1667 sizetab
[SIMPLE_ARRAY_WIDETAG
] = size_boxed
;
1668 sizetab
[SIMPLE_BASE_STRING_WIDETAG
] = size_base_string
;
1669 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1670 sizetab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = size_character_string
;
1672 sizetab
[SIMPLE_BIT_VECTOR_WIDETAG
] = size_vector_bit
;
1673 sizetab
[SIMPLE_VECTOR_WIDETAG
] = size_vector
;
1674 sizetab
[SIMPLE_ARRAY_NIL_WIDETAG
] = size_vector_nil
;
1675 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
1676 size_vector_unsigned_byte_2
;
1677 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
1678 size_vector_unsigned_byte_4
;
1679 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
1680 size_vector_unsigned_byte_8
;
1681 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
1682 size_vector_unsigned_byte_8
;
1683 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
1684 size_vector_unsigned_byte_16
;
1685 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
1686 size_vector_unsigned_byte_16
;
1687 #if (N_WORD_BITS == 32)
1688 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1689 size_vector_unsigned_byte_32
;
1691 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
1692 size_vector_unsigned_byte_32
;
1693 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
1694 size_vector_unsigned_byte_32
;
1695 #if (N_WORD_BITS == 64)
1696 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
1697 size_vector_unsigned_byte_64
;
1699 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1700 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
1701 size_vector_unsigned_byte_64
;
1703 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1704 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
1705 size_vector_unsigned_byte_64
;
1707 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1708 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = size_vector_unsigned_byte_8
;
1710 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1711 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
1712 size_vector_unsigned_byte_16
;
1714 #if (N_WORD_BITS == 32)
1715 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1716 size_vector_unsigned_byte_32
;
1718 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1719 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
1720 size_vector_unsigned_byte_32
;
1722 #if (N_WORD_BITS == 64)
1723 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
1724 size_vector_unsigned_byte_64
;
1726 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1727 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
1728 size_vector_unsigned_byte_64
;
1730 sizetab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = size_vector_unsigned_byte_32
;
1731 sizetab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = size_vector_unsigned_byte_64
;
1732 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1733 sizetab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = size_vector_long_float
;
1735 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1736 sizetab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_vector_unsigned_byte_64
;
1738 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1739 sizetab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_vector_unsigned_byte_128
;
1741 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1742 sizetab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
1743 size_vector_complex_long_float
;
1745 sizetab
[COMPLEX_BASE_STRING_WIDETAG
] = size_boxed
;
1746 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1747 sizetab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = size_boxed
;
1749 sizetab
[COMPLEX_VECTOR_NIL_WIDETAG
] = size_boxed
;
1750 sizetab
[COMPLEX_BIT_VECTOR_WIDETAG
] = size_boxed
;
1751 sizetab
[COMPLEX_VECTOR_WIDETAG
] = size_boxed
;
1752 sizetab
[COMPLEX_ARRAY_WIDETAG
] = size_boxed
;
1753 sizetab
[CODE_HEADER_WIDETAG
] = size_code_header
;
1755 /* We shouldn't see these, so just lose if it happens. */
1756 sizetab
[SIMPLE_FUN_HEADER_WIDETAG
] = size_function_header
;
1757 sizetab
[RETURN_PC_HEADER_WIDETAG
] = size_return_pc_header
;
1759 sizetab
[CLOSURE_HEADER_WIDETAG
] = size_short_boxed
;
1760 sizetab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = size_short_boxed
;
1761 sizetab
[VALUE_CELL_HEADER_WIDETAG
] = size_boxed
;
1762 sizetab
[SYMBOL_HEADER_WIDETAG
] = size_tiny_boxed
;
1763 sizetab
[CHARACTER_WIDETAG
] = size_immediate
;
1764 sizetab
[SAP_WIDETAG
] = size_unboxed
;
1765 #ifdef SIMD_PACK_WIDETAG
1766 sizetab
[SIMD_PACK_WIDETAG
] = size_unboxed
;
1768 sizetab
[UNBOUND_MARKER_WIDETAG
] = size_immediate
;
1769 sizetab
[NO_TLS_VALUE_MARKER_WIDETAG
] = size_immediate
;
1770 sizetab
[WEAK_POINTER_WIDETAG
] = size_weak_pointer
;
1771 sizetab
[INSTANCE_HEADER_WIDETAG
] = size_instance
;
1772 sizetab
[FDEFN_WIDETAG
] = size_tiny_boxed
;
1776 /* Find the code object for the given pc, or return NULL on
1779 component_ptr_from_pc(lispobj
*pc
)
1781 lispobj
*object
= NULL
;
1783 if ( (object
= search_read_only_space(pc
)) )
1785 else if ( (object
= search_static_space(pc
)) )
1787 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1788 else if ( (object
= search_immobile_space(pc
)) )
1792 object
= search_dynamic_space(pc
);
1794 if (object
) /* if we found something */
1795 if (widetag_of(*object
) == CODE_HEADER_WIDETAG
)
1801 /* Scan an area looking for an object which encloses the given pointer.
1802 * Return the object start on success, or NULL on failure. */
1804 gc_search_space3(lispobj
*start
, void* limit
, void *pointer
)
1806 if (pointer
< (void*)start
|| pointer
>= limit
) return NULL
;
1808 while ((void*)start
< limit
) {
1809 lispobj
*forwarded_start
;
1810 if (forwarding_pointer_p(start
))
1811 forwarded_start
= native_pointer(forwarding_pointer_value(start
));
1813 forwarded_start
= start
;
1814 lispobj thing
= *forwarded_start
;
1816 if (!is_cons_half(thing
))
1817 count
= (sizetab
[widetag_of(thing
)])(forwarded_start
);
1819 /* Check whether the pointer is within this object. */
1820 if (pointer
< (void*)(start
+count
)) return start
;
1827 /* Helper for valid_lisp_pointer_p (below) and
1828 * conservative_root_p (gencgc).
1830 * pointer is the pointer to check validity of,
1831 * and start_addr is the address of the enclosing object.
1834 properly_tagged_descriptor_p(lispobj pointer
, lispobj
*start_addr
)
1836 if (!is_lisp_pointer(pointer
)) {
1840 /* Check that the object pointed to is consistent with the pointer
1842 switch (lowtag_of(pointer
)) {
1843 case FUN_POINTER_LOWTAG
:
1844 /* Start_addr should be the enclosing code object, or a closure
1846 switch (widetag_of(*start_addr
)) {
1847 case CODE_HEADER_WIDETAG
:
1848 /* Make sure we actually point to a function in the code object,
1849 * as opposed to a random point there. */
1850 for_each_simple_fun(i
, function
, (struct code
*)start_addr
, 0, {
1851 if ((lispobj
)function
== pointer
-FUN_POINTER_LOWTAG
) return 1;
1854 case CLOSURE_HEADER_WIDETAG
:
1855 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
1856 return make_lispobj(start_addr
, FUN_POINTER_LOWTAG
) == pointer
;
1861 case LIST_POINTER_LOWTAG
:
1862 return make_lispobj(start_addr
, LIST_POINTER_LOWTAG
) == pointer
1863 && is_cons_half(start_addr
[0]) // Is it plausible?
1864 && is_cons_half(start_addr
[1]);
1866 case INSTANCE_POINTER_LOWTAG
:
1867 return make_lispobj(start_addr
, INSTANCE_POINTER_LOWTAG
) == pointer
1868 && widetag_of(*start_addr
) == INSTANCE_HEADER_WIDETAG
;
1870 case OTHER_POINTER_LOWTAG
:
1872 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
1873 /* The all-architecture test below is good as far as it goes,
1874 * but an LRA object is similar to a FUN-POINTER: It is
1875 * embedded within a CODE-OBJECT pointed to by start_addr, and
1876 * cannot be found by simply walking the heap, therefore we
1877 * need to check for it. -- AB, 2010-Jun-04 */
1878 if ((widetag_of(start_addr
[0]) == CODE_HEADER_WIDETAG
)) {
1879 lispobj
*potential_lra
= native_pointer(pointer
);
1880 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
1881 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
1882 return 1; /* It's as good as we can verify. */
1887 if (pointer
!= make_lispobj(start_addr
, OTHER_POINTER_LOWTAG
)
1888 || !other_immediate_lowtag_p(*start_addr
))
1891 switch (widetag_of(start_addr
[0])) {
1892 case UNBOUND_MARKER_WIDETAG
:
1893 case NO_TLS_VALUE_MARKER_WIDETAG
:
1894 case CHARACTER_WIDETAG
:
1895 #if N_WORD_BITS == 64
1896 case SINGLE_FLOAT_WIDETAG
:
1900 /* only pointed to by function pointers? */
1901 case CLOSURE_HEADER_WIDETAG
:
1902 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
1905 case INSTANCE_HEADER_WIDETAG
:
1908 /* the valid other immediate pointer objects */
1909 case SIMPLE_VECTOR_WIDETAG
:
1911 case COMPLEX_WIDETAG
:
1912 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1913 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
1915 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1916 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
1918 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1919 case COMPLEX_LONG_FLOAT_WIDETAG
:
1921 #ifdef SIMD_PACK_WIDETAG
1922 case SIMD_PACK_WIDETAG
:
1924 case SIMPLE_ARRAY_WIDETAG
:
1925 case COMPLEX_BASE_STRING_WIDETAG
:
1926 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
1927 case COMPLEX_CHARACTER_STRING_WIDETAG
:
1929 case COMPLEX_VECTOR_NIL_WIDETAG
:
1930 case COMPLEX_BIT_VECTOR_WIDETAG
:
1931 case COMPLEX_VECTOR_WIDETAG
:
1932 case COMPLEX_ARRAY_WIDETAG
:
1933 case VALUE_CELL_HEADER_WIDETAG
:
1934 case SYMBOL_HEADER_WIDETAG
:
1936 case CODE_HEADER_WIDETAG
:
1937 case BIGNUM_WIDETAG
:
1938 #if N_WORD_BITS != 64
1939 case SINGLE_FLOAT_WIDETAG
:
1941 case DOUBLE_FLOAT_WIDETAG
:
1942 #ifdef LONG_FLOAT_WIDETAG
1943 case LONG_FLOAT_WIDETAG
:
1945 case SIMPLE_BASE_STRING_WIDETAG
:
1946 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1947 case SIMPLE_CHARACTER_STRING_WIDETAG
:
1949 case SIMPLE_BIT_VECTOR_WIDETAG
:
1950 case SIMPLE_ARRAY_NIL_WIDETAG
:
1951 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
1952 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
1953 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
1954 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
1955 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
1956 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
1958 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
1960 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
1961 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
1962 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1963 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
1965 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1966 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
1968 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1969 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
1971 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1972 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
1975 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
1977 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1978 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
1980 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
1981 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
1983 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
1984 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
1985 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1986 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
1988 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1989 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
1991 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1992 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
1994 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1995 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
1998 case WEAK_POINTER_WIDETAG
:
2013 /* META: Note the ambiguous word "validate" in the comment below.
2014 * This means "Decide whether <x> is valid".
2015 * But when you see os_validate() elsewhere, that doesn't mean to ask
2016 * whether something is valid, it says to *make* it valid.
2017 * I think it would be nice if we could avoid using the word in the
2018 * sense in which os_validate() uses it, which would entail renaming
2019 * a bunch of stuff, which is harder than just explaining why
2020 * the comments can be deceptive */
2022 /* Used by the debugger to validate possibly bogus pointers before
2023 * calling MAKE-LISP-OBJ on them.
2025 * FIXME: We would like to make this perfect, because if the debugger
2026 * constructs a reference to a bugs lisp object, and it ends up in a
2027 * location scavenged by the GC all hell breaks loose.
2029 * Whereas conservative_root_p has to be conservative
2030 * and return true for all valid pointers, this could actually be eager
2031 * and lie about a few pointers without bad results... but that should
2032 * be reflected in the name.
2035 valid_lisp_pointer_p(lispobj
*pointer
)
2038 if (((start
=search_dynamic_space(pointer
))!=NULL
) ||
2039 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2040 ((start
=search_immobile_space(pointer
))!=NULL
) ||
2042 ((start
=search_static_space(pointer
))!=NULL
) ||
2043 ((start
=search_read_only_space(pointer
))!=NULL
))
2044 return properly_tagged_descriptor_p((lispobj
)pointer
, start
);
2050 maybe_gc(os_context_t
*context
)
2052 lispobj gc_happened
;
2053 struct thread
*thread
= arch_os_get_current_thread();
2054 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
2057 fake_foreign_function_call(context
);
2060 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2061 * which case we will be running with no gc trigger barrier
2062 * thing for a while. But it shouldn't be long until the end
2065 * FIXME: It would be good to protect the end of dynamic space for
2066 * CheneyGC and signal a storage condition from there.
2069 /* Restore the signal mask from the interrupted context before
2070 * calling into Lisp if interrupts are enabled. Why not always?
2072 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2073 * interrupt hits while in SUB-GC, it is deferred and the
2074 * os_context_sigmask of that interrupt is set to block further
2075 * deferrable interrupts (until the first one is
2076 * handled). Unfortunately, that context refers to this place and
2077 * when we return from here the signals will not be blocked.
2079 * A kludgy alternative is to propagate the sigmask change to the
2082 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2083 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
2084 unblock_gc_signals(0, 0);
2086 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
2087 /* FIXME: Nothing must go wrong during GC else we end up running
2088 * the debugger, error handlers, and user code in general in a
2089 * potentially unsafe place. Running out of the control stack or
2090 * the heap in SUB-GC are ways to lose. Of course, deferrables
2091 * cannot be unblocked because there may be a pending handler, or
2092 * we may even be in a WITHOUT-INTERRUPTS. */
2093 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
2094 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
2095 (gc_happened
== NIL
)
2097 : ((gc_happened
== T
)
2100 /* gc_happened can take three values: T, NIL, 0.
2102 * T means that the thread managed to trigger a GC, and post-gc
2105 * NIL means that the thread is within without-gcing, and no GC
2108 * Finally, 0 means that *a* GC has occurred, but it wasn't
2109 * triggered by this thread; success, but post-gc doesn't have
2112 if ((gc_happened
== T
) &&
2113 /* See if interrupts are enabled or it's possible to enable
2114 * them. POST-GC has a similar check, but we don't want to
2115 * unlock deferrables in that case and get a pending interrupt
2117 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
2118 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
2119 #ifndef LISP_FEATURE_WIN32
2120 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
2121 if (!deferrables_blocked_p(context_sigmask
)) {
2122 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
2123 #ifndef LISP_FEATURE_SB_SAFEPOINT
2124 check_gc_signals_unblocked_or_lose(0);
2127 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
2128 funcall0(StaticSymbolFunction(POST_GC
));
2129 #ifndef LISP_FEATURE_WIN32
2131 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
2137 undo_fake_foreign_function_call(context
);
2139 /* Otherwise done by undo_fake_foreign_function_call. And
2140 something later wants them to be blocked. What a nice
2142 block_blockable_signals(0);
2145 FSHOW((stderr
, "/maybe_gc: returning\n"));
2146 return (gc_happened
!= NIL
);
2149 #define BYTES_ZERO_BEFORE_END (1<<12)
2151 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2152 * Lisp and another called zero_stack() in cheneygc.c, but since it's
2153 * shorter to express in, and more often called from C, I keep only
2154 * the C one after fixing it. -- MG 2009-03-25 */
2156 /* Zero the unused portion of the control stack so that old objects
2157 * are not kept alive because of uninitialized stack variables.
2159 * "To summarize the problem, since not all allocated stack frame
2160 * slots are guaranteed to be written by the time you call an another
2161 * function or GC, there may be garbage pointers retained in your dead
2162 * stack locations. The stack scrubbing only affects the part of the
2163 * stack from the SP to the end of the allocated stack." - ram, on
2164 * cmucl-imp, Tue, 25 Sep 2001
2166 * So, as an (admittedly lame) workaround, from time to time we call
2167 * scrub-control-stack to zero out all the unused portion. This is
2168 * supposed to happen when the stack is mostly empty, so that we have
2169 * a chance of clearing more of it: callers are currently (2002.07.18)
2170 * REPL, SUB-GC and sig_stop_for_gc_handler. */
2172 /* Take care not to tread on the guard page and the hard guard page as
2173 * it would be unkind to sig_stop_for_gc_handler. Touching the return
2174 * guard page is not dangerous. For this to work the guard page must
2175 * be zeroed when protected. */
2177 /* FIXME: I think there is no guarantee that once
2178 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2179 * may be what the "lame" adjective in the above comment is for. In
2180 * this case, exact gc may lose badly. */
2182 scrub_control_stack()
2184 scrub_thread_control_stack(arch_os_get_current_thread());
2188 scrub_thread_control_stack(struct thread
*th
)
2190 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
2191 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
2192 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2193 /* On these targets scrubbing from C is a bad idea, so we punt to
2194 * a routine in $ARCH-assem.S. */
2195 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
2196 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
2198 lispobj
*sp
= access_control_stack_pointer(th
);
2200 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
2201 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
2202 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
2203 ((os_vm_address_t
)sp
>= guard_page_address
) &&
2204 (th
->control_stack_guard_page_protected
!= NIL
)))
2206 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2209 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
2210 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
2215 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
2219 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
2220 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
2225 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
2227 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2230 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2233 scavenge_control_stack(struct thread
*th
)
2235 lispobj
*object_ptr
;
2237 /* In order to properly support dynamic-extent allocation of
2238 * non-CONS objects, the control stack requires special handling.
2239 * Rather than calling scavenge() directly, grovel over it fixing
2240 * broken hearts, scavenging pointers to oldspace, and pitching a
2241 * fit when encountering unboxed data. This prevents stray object
2242 * headers from causing the scavenger to blow past the end of the
2243 * stack (an error case checked in scavenge()). We don't worry
2244 * about treating unboxed words as boxed or vice versa, because
2245 * the compiler isn't allowed to store unboxed objects on the
2246 * control stack. -- AB, 2011-Dec-02 */
2248 for (object_ptr
= th
->control_stack_start
;
2249 object_ptr
< access_control_stack_pointer(th
);
2252 lispobj object
= *object_ptr
;
2253 #ifdef LISP_FEATURE_GENCGC
2254 if (forwarding_pointer_p(object_ptr
))
2255 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
2256 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
2258 if (is_lisp_pointer(object
) && from_space_p(object
)) {
2259 /* It currently points to old space. Check for a
2260 * forwarding pointer. */
2261 lispobj
*ptr
= native_pointer(object
);
2262 if (forwarding_pointer_p(ptr
)) {
2263 /* Yes, there's a forwarding pointer. */
2264 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
2266 /* Scavenge that pointer. */
2267 long n_words_scavenged
=
2268 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
2269 gc_assert(n_words_scavenged
== 1);
2271 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
2272 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
2273 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
2278 /* Scavenging Interrupt Contexts */
2280 static int boxed_registers
[] = BOXED_REGISTERS
;
2282 /* The GC has a notion of an "interior pointer" register, an unboxed
2283 * register that typically contains a pointer to inside an object
2284 * referenced by another pointer. The most obvious of these is the
2285 * program counter, although many compiler backends define a "Lisp
2286 * Interior Pointer" register known to the runtime as reg_LIP, and
2287 * various CPU architectures have other registers that also partake of
2288 * the interior-pointer nature. As the code for pairing an interior
2289 * pointer value up with its "base" register, and fixing it up after
2290 * scavenging is complete is horribly repetitive, a few macros paper
2291 * over the monotony. --AB, 2010-Jul-14 */
2293 /* These macros are only ever used over a lexical environment which
2294 * defines a pointer to an os_context_t called context, thus we don't
2295 * bother to pass that context in as a parameter. */
2297 /* Define how to access a given interior pointer. */
2298 #define ACCESS_INTERIOR_POINTER_pc \
2299 *os_context_pc_addr(context)
2300 #define ACCESS_INTERIOR_POINTER_lip \
2301 *os_context_register_addr(context, reg_LIP)
2302 #define ACCESS_INTERIOR_POINTER_lr \
2303 *os_context_lr_addr(context)
2304 #define ACCESS_INTERIOR_POINTER_npc \
2305 *os_context_npc_addr(context)
2306 #define ACCESS_INTERIOR_POINTER_ctr \
2307 *os_context_ctr_addr(context)
2309 #define INTERIOR_POINTER_VARS(name) \
2310 uword_t name##_offset; \
2311 int name##_register_pair
2313 #define PAIR_INTERIOR_POINTER(name) \
2314 pair_interior_pointer(context, \
2315 ACCESS_INTERIOR_POINTER_##name, \
2317 &name##_register_pair)
2319 /* One complexity here is that if a paired register is not found for
2320 * an interior pointer, then that pointer does not get updated.
2321 * Originally, there was some commentary about using an index of -1
2322 * when calling os_context_register_addr() on SPARC referring to the
2323 * program counter, but the real reason is to allow an interior
2324 * pointer register to point to the runtime, read-only space, or
2325 * static space without problems. */
2326 #define FIXUP_INTERIOR_POINTER(name) \
2328 if (name##_register_pair >= 0) { \
2329 ACCESS_INTERIOR_POINTER_##name = \
2330 (*os_context_register_addr(context, \
2331 name##_register_pair) \
2339 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
2340 uword_t
*saved_offset
, int *register_pair
)
2345 * I (RLT) think this is trying to find the boxed register that is
2346 * closest to the LIP address, without going past it. Usually, it's
2347 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
2349 /* 0x7FFFFFFF on 32-bit platforms;
2350 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2351 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
2352 *register_pair
= -1;
2353 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
2358 index
= boxed_registers
[i
];
2359 reg
= *os_context_register_addr(context
, index
);
2361 /* An interior pointer is never relative to a non-pointer
2362 * register (an oversight in the original implementation).
2363 * The simplest argument for why this is true is to consider
2364 * the fixnum that happens by coincide to be the word-index in
2365 * memory of the header for some object plus two. This is
2366 * happenstance would cause the register containing the fixnum
2367 * to be selected as the register_pair if the interior pointer
2368 * is to anywhere after the first two words of the object.
2369 * The fixnum won't be changed during GC, but the object might
2370 * move, thus destroying the interior pointer. --AB,
2373 if (is_lisp_pointer(reg
) &&
2374 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
2375 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
2376 if (offset
< *saved_offset
) {
2377 *saved_offset
= offset
;
2378 *register_pair
= index
;
2385 scavenge_interrupt_context(os_context_t
* context
)
2389 /* FIXME: The various #ifdef noise here is precisely that: noise.
2390 * Is it possible to fold it into the macrology so that we have
2391 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2392 * compile out for the registers that don't exist on a given
2395 INTERIOR_POINTER_VARS(pc
);
2397 INTERIOR_POINTER_VARS(lip
);
2399 #ifdef ARCH_HAS_LINK_REGISTER
2400 INTERIOR_POINTER_VARS(lr
);
2402 #ifdef ARCH_HAS_NPC_REGISTER
2403 INTERIOR_POINTER_VARS(npc
);
2405 #ifdef LISP_FEATURE_PPC
2406 INTERIOR_POINTER_VARS(ctr
);
2409 PAIR_INTERIOR_POINTER(pc
);
2411 PAIR_INTERIOR_POINTER(lip
);
2413 #ifdef ARCH_HAS_LINK_REGISTER
2414 PAIR_INTERIOR_POINTER(lr
);
2416 #ifdef ARCH_HAS_NPC_REGISTER
2417 PAIR_INTERIOR_POINTER(npc
);
2419 #ifdef LISP_FEATURE_PPC
2420 PAIR_INTERIOR_POINTER(ctr
);
2423 /* Scavenge all boxed registers in the context. */
2424 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
2428 index
= boxed_registers
[i
];
2429 foo
= *os_context_register_addr(context
, index
);
2431 *os_context_register_addr(context
, index
) = foo
;
2433 /* this is unlikely to work as intended on bigendian
2434 * 64 bit platforms */
2436 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
2439 /* Now that the scavenging is done, repair the various interior
2441 FIXUP_INTERIOR_POINTER(pc
);
2443 FIXUP_INTERIOR_POINTER(lip
);
2445 #ifdef ARCH_HAS_LINK_REGISTER
2446 FIXUP_INTERIOR_POINTER(lr
);
2448 #ifdef ARCH_HAS_NPC_REGISTER
2449 FIXUP_INTERIOR_POINTER(npc
);
2451 #ifdef LISP_FEATURE_PPC
2452 FIXUP_INTERIOR_POINTER(ctr
);
2457 scavenge_interrupt_contexts(struct thread
*th
)
2460 os_context_t
*context
;
2462 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
2464 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2465 printf("Number of active contexts: %d\n", index
);
2468 for (i
= 0; i
< index
; i
++) {
2469 context
= th
->interrupt_contexts
[i
];
2470 scavenge_interrupt_context(context
);
2473 #endif /* x86oid targets */
2475 void varint_unpacker_init(struct varint_unpacker
* unpacker
, lispobj integer
)
2477 if (fixnump(integer
)) {
2478 unpacker
->word
= fixnum_value(integer
);
2479 unpacker
->limit
= N_WORD_BYTES
;
2480 unpacker
->data
= (char*)&unpacker
->word
;
2482 struct bignum
* bignum
= (struct bignum
*)(integer
- OTHER_POINTER_LOWTAG
);
2484 unpacker
->limit
= HeaderValue(bignum
->header
) * N_WORD_BYTES
;
2485 unpacker
->data
= (char*)bignum
->digits
;
2487 unpacker
->index
= 0;
2490 // Fetch the next varint from 'unpacker' into 'result'.
2491 // Because there is no length prefix on the number of varints encoded,
2492 // spurious trailing zeros might be observed. The data consumer can
2493 // circumvent that by storing a count as the first value in the series.
2494 // Return 1 for success, 0 for EOF.
2495 int varint_unpack(struct varint_unpacker
* unpacker
, int* result
)
2497 if (unpacker
->index
>= unpacker
->limit
) return 0;
2498 int accumulator
= 0;
2501 #ifdef LISP_FEATURE_LITTLE_ENDIAN
2502 int byte
= unpacker
->data
[unpacker
->index
];
2504 // bignums are little-endian in word order,
2505 // but machine-native within each word.
2506 // We could pack bytes MSB-to-LSB in the bigdigits,
2507 // but that seems less intuitive on the Lisp side.
2508 int word_index
= unpacker
->index
/ N_WORD_BYTES
;
2509 int byte_index
= unpacker
->index
% N_WORD_BYTES
;
2510 int byte
= (((unsigned int*)unpacker
->data
)[word_index
]
2511 >> (byte_index
* 8)) & 0xFF;
2514 accumulator
|= (byte
& 0x7F) << shift
;
2515 if (!(byte
& 0x80)) break;
2516 gc_assert(unpacker
->index
< unpacker
->limit
);
2519 *result
= accumulator
;
2523 // The following accessors, which take a valid native pointer as input
2524 // and return a Lisp string, are designed to be foolproof during GC,
2525 // hence all the forwarding checks.
2527 #if defined(LISP_FEATURE_SB_LDB)
2528 #include "genesis/classoid.h"
2529 struct vector
* symbol_name(lispobj
* sym
)
2531 if (forwarding_pointer_p(sym
))
2532 sym
= native_pointer(forwarding_pointer_value(sym
));
2533 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
2535 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
2536 if (forwarding_pointer_p(name
))
2537 name
= native_pointer(forwarding_pointer_value(name
));
2538 return (struct vector
*)name
;
2540 struct vector
* classoid_name(lispobj
* classoid
)
2542 if (forwarding_pointer_p(classoid
))
2543 classoid
= native_pointer(forwarding_pointer_value(classoid
));
2544 lispobj sym
= ((struct classoid
*)classoid
)->name
;
2545 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
2546 : symbol_name(native_pointer(sym
));
2548 struct vector
* layout_classoid_name(lispobj
* layout
)
2550 if (forwarding_pointer_p(layout
))
2551 layout
= native_pointer(forwarding_pointer_value(layout
));
2552 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
2553 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
2554 : classoid_name(native_pointer(classoid
));
2556 struct vector
* instance_classoid_name(lispobj
* instance
)
2558 if (forwarding_pointer_p(instance
))
2559 instance
= native_pointer(forwarding_pointer_value(instance
));
2560 lispobj layout
= instance_layout(instance
);
2561 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
2562 : layout_classoid_name(native_pointer(layout
));
2564 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
2566 extern void show_lstring(struct vector
*, int, FILE*);
2567 if (forwarding_pointer_p((lispobj
*)string
))
2568 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
2570 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2571 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
2573 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
2574 show_lstring(string
, quotes
, s
);
2576 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));