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"
49 #ifdef LISP_FEATURE_SPARC
50 #define LONG_FLOAT_SIZE 4
52 #ifdef LISP_FEATURE_X86
53 #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 #ifndef LISP_FEATURE_GENCGC
63 return current_dynamic_space
== from_space
;
68 forwarding_pointer_p(lispobj
*pointer
) {
69 lispobj first_word
=*pointer
;
70 #ifdef LISP_FEATURE_GENCGC
71 return (first_word
== 0x01);
73 return (is_lisp_pointer(first_word
)
74 && in_gc_p() /* cheneygc new_space_p() is broken when not in gc */
75 && new_space_p(first_word
));
79 static inline lispobj
*
80 forwarding_pointer_value(lispobj
*pointer
) {
81 #ifdef LISP_FEATURE_GENCGC
82 return (lispobj
*) ((pointer_sized_uint_t
) pointer
[1]);
84 return (lispobj
*) ((pointer_sized_uint_t
) pointer
[0]);
88 set_forwarding_pointer(lispobj
* pointer
, lispobj newspace_copy
) {
89 #ifdef LISP_FEATURE_GENCGC
91 pointer
[1]=newspace_copy
;
93 pointer
[0]=newspace_copy
;
98 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
99 lispobj (*transother
[256])(lispobj object
);
100 sword_t (*sizetab
[256])(lispobj
*where
);
101 struct weak_pointer
*weak_pointers
;
103 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
109 /* gc_general_copy_object is inline from gc-internal.h */
111 /* to copy a boxed object */
113 copy_object(lispobj object
, sword_t nwords
)
115 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
119 copy_code_object(lispobj object
, sword_t nwords
)
121 return gc_general_copy_object(object
, nwords
, CODE_PAGE_FLAG
);
124 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
126 /* FIXME: Most calls end up going to some trouble to compute an
127 * 'n_words' value for this function. The system might be a little
128 * simpler if this function used an 'end' parameter instead. */
130 scavenge(lispobj
*start
, sword_t n_words
)
132 lispobj
*end
= start
+ n_words
;
135 for (object_ptr
= start
; object_ptr
< end
;) {
136 lispobj object
= *object_ptr
;
137 #ifdef LISP_FEATURE_GENCGC
138 if (forwarding_pointer_p(object_ptr
))
139 lose("unexpected forwarding pointer in scavenge: %p, start=%p, n=%ld\n",
140 object_ptr
, start
, n_words
);
142 if (is_lisp_pointer(object
)) {
143 if (from_space_p(object
)) {
144 /* It currently points to old space. Check for a
145 * forwarding pointer. */
146 lispobj
*ptr
= native_pointer(object
);
147 if (forwarding_pointer_p(ptr
)) {
148 /* Yes, there's a forwarding pointer. */
149 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
152 /* Scavenge that pointer. */
154 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
156 #ifdef LISP_FEATURE_IMMOBILE_SPACE
157 } else if (immobile_space_p(object
)) {
158 lispobj
*ptr
= native_pointer(object
);
159 if (immobile_obj_gen_bits(ptr
) == from_space
)
160 promote_immobile_obj(ptr
);
164 /* It points somewhere other than oldspace. Leave it
169 else if (fixnump(object
)) {
170 /* It's a fixnum: really easy.. */
173 /* It's some sort of header object or another. */
174 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
177 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
178 object_ptr
, start
, end
);
181 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
182 static lispobj
trans_boxed(lispobj object
);
185 scav_fun_pointer(lispobj
*where
, lispobj object
)
187 lispobj
*first_pointer
;
190 gc_assert(is_lisp_pointer(object
));
192 /* Object is a pointer into from_space - not a FP. */
193 first_pointer
= (lispobj
*) native_pointer(object
);
195 /* must transport object -- object may point to either a function
196 * header, a closure function header, or to a closure header. */
198 switch (widetag_of(*first_pointer
)) {
199 case SIMPLE_FUN_HEADER_WIDETAG
:
200 copy
= trans_fun_header(object
);
203 copy
= trans_boxed(object
);
207 if (copy
!= object
) {
208 /* Set forwarding pointer */
209 set_forwarding_pointer(first_pointer
,copy
);
212 gc_assert(is_lisp_pointer(copy
));
213 gc_assert(!from_space_p(copy
));
222 trans_code(struct code
*code
)
224 struct code
*new_code
;
225 lispobj l_code
, l_new_code
;
226 uword_t nheader_words
, ncode_words
, nwords
;
227 uword_t displacement
;
228 lispobj fheaderl
, *prev_pointer
;
230 /* if object has already been transported, just return pointer */
231 if (forwarding_pointer_p((lispobj
*)code
)) {
233 printf("Was already transported\n");
235 return (struct code
*) forwarding_pointer_value
236 ((lispobj
*)((pointer_sized_uint_t
) code
));
239 gc_assert(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
241 /* prepare to transport the code vector */
242 l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
244 ncode_words
= code_instruction_words(code
->code_size
);
245 nheader_words
= code_header_words(code
->header
);
246 nwords
= ncode_words
+ nheader_words
;
247 nwords
= CEILING(nwords
, 2);
249 l_new_code
= copy_code_object(l_code
, nwords
);
250 new_code
= (struct code
*) native_pointer(l_new_code
);
252 #if defined(DEBUG_CODE_GC)
253 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
254 (uword_t
) code
, (uword_t
) new_code
);
255 printf("Code object is %d words long.\n", nwords
);
258 #ifdef LISP_FEATURE_GENCGC
259 if (new_code
== code
)
263 displacement
= l_new_code
- l_code
;
265 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
267 /* set forwarding pointers for all the function headers in the */
268 /* code object. also fix all self pointers */
270 fheaderl
= code
->entry_points
;
271 prev_pointer
= &new_code
->entry_points
;
273 while (fheaderl
!= NIL
) {
274 struct simple_fun
*fheaderp
, *nfheaderp
;
277 fheaderp
= (struct simple_fun
*) native_pointer(fheaderl
);
278 gc_assert(widetag_of(fheaderp
->header
) == SIMPLE_FUN_HEADER_WIDETAG
);
280 /* Calculate the new function pointer and the new */
281 /* function header. */
282 nfheaderl
= fheaderl
+ displacement
;
283 nfheaderp
= (struct simple_fun
*) native_pointer(nfheaderl
);
286 printf("fheaderp->header (at %x) <- %x\n",
287 &(fheaderp
->header
) , nfheaderl
);
289 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
291 /* fix self pointer. */
293 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
294 FUN_RAW_ADDR_OFFSET
+
298 *prev_pointer
= nfheaderl
;
300 fheaderl
= fheaderp
->next
;
301 prev_pointer
= &nfheaderp
->next
;
303 #ifdef LISP_FEATURE_GENCGC
304 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
305 spaces once when all copying is done. */
306 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
307 ncode_words
* sizeof(sword_t
));
311 #ifdef LISP_FEATURE_X86
312 gencgc_apply_code_fixups(code
, new_code
);
319 scav_code_header(lispobj
*where
, lispobj object
)
322 sword_t n_header_words
, n_code_words
, n_words
;
323 lispobj entry_point
; /* tagged pointer to entry point */
324 struct simple_fun
*function_ptr
; /* untagged pointer to entry point */
326 code
= (struct code
*) where
;
327 n_code_words
= code_instruction_words(code
->code_size
);
328 n_header_words
= code_header_words(object
);
329 n_words
= n_code_words
+ n_header_words
;
330 n_words
= CEILING(n_words
, 2);
332 /* Scavenge the boxed section of the code data block. */
333 scavenge(where
+ 1, n_header_words
- 1);
335 /* Scavenge the boxed section of each function object in the
336 * code data block. */
337 for (entry_point
= code
->entry_points
;
339 entry_point
= function_ptr
->next
) {
341 gc_assert_verbose(is_lisp_pointer(entry_point
),
342 "Entry point %lx\n is not a lisp pointer.",
343 (sword_t
)entry_point
);
345 function_ptr
= (struct simple_fun
*) native_pointer(entry_point
);
346 gc_assert(widetag_of(function_ptr
->header
)==SIMPLE_FUN_HEADER_WIDETAG
);
347 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
348 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
355 trans_code_header(lispobj object
)
359 ncode
= trans_code((struct code
*) native_pointer(object
));
360 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
365 size_code_header(lispobj
*where
)
368 sword_t nheader_words
, ncode_words
, nwords
;
370 code
= (struct code
*) where
;
372 ncode_words
= code_instruction_words(code
->code_size
);
373 nheader_words
= code_header_words(code
->header
);
374 nwords
= ncode_words
+ nheader_words
;
375 nwords
= CEILING(nwords
, 2);
380 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
382 scav_return_pc_header(lispobj
*where
, lispobj object
)
384 lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
387 return 0; /* bogus return value to satisfy static type checking */
389 #endif /* LISP_FEATURE_X86 */
392 trans_return_pc_header(lispobj object
)
394 struct simple_fun
*return_pc
;
396 struct code
*code
, *ncode
;
398 return_pc
= (struct simple_fun
*) native_pointer(object
);
399 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
400 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
402 /* Transport the whole code object */
403 code
= (struct code
*) ((uword_t
) return_pc
- offset
);
404 ncode
= trans_code(code
);
406 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
409 /* On the 386, closures hold a pointer to the raw address instead of the
410 * function object, so we can use CALL [$FDEFN+const] to invoke
411 * the function without loading it into a register. Given that code
412 * objects don't move, we don't need to update anything, but we do
413 * have to figure out that the function is still live. */
415 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
417 scav_closure_header(lispobj
*where
, lispobj object
)
419 struct closure
*closure
;
422 closure
= (struct closure
*)where
;
423 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
425 #ifdef LISP_FEATURE_GENCGC
426 /* The function may have moved so update the raw address. But
427 * don't write unnecessarily. */
428 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
429 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
435 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
437 scav_fun_header(lispobj
*where
, lispobj object
)
439 lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
442 return 0; /* bogus return value to satisfy static type checking */
444 #endif /* LISP_FEATURE_X86 */
447 trans_fun_header(lispobj object
)
449 struct simple_fun
*fheader
;
451 struct code
*code
, *ncode
;
453 fheader
= (struct simple_fun
*) native_pointer(object
);
454 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
455 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
457 /* Transport the whole code object */
458 code
= (struct code
*) ((uword_t
) fheader
- offset
);
459 ncode
= trans_code(code
);
461 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
470 trans_instance(lispobj object
)
475 gc_assert(is_lisp_pointer(object
));
477 header
= *((lispobj
*) native_pointer(object
));
478 length
= instance_length(header
) + 1;
479 length
= CEILING(length
, 2);
481 return copy_object(object
, length
);
485 size_instance(lispobj
*where
)
491 length
= instance_length(header
) + 1;
492 length
= CEILING(length
, 2);
498 scav_instance_pointer(lispobj
*where
, lispobj object
)
500 lispobj copy
, *first_pointer
;
502 /* Object is a pointer into from space - not a FP. */
503 copy
= trans_instance(object
);
505 #ifdef LISP_FEATURE_GENCGC
506 gc_assert(copy
!= object
);
509 first_pointer
= (lispobj
*) native_pointer(object
);
510 set_forwarding_pointer(first_pointer
,copy
);
521 static lispobj
trans_list(lispobj object
);
524 scav_list_pointer(lispobj
*where
, lispobj object
)
526 lispobj first
, *first_pointer
;
528 gc_assert(is_lisp_pointer(object
));
530 /* Object is a pointer into from space - not FP. */
531 first_pointer
= (lispobj
*) native_pointer(object
);
533 first
= trans_list(object
);
534 gc_assert(first
!= object
);
536 gc_assert(is_lisp_pointer(first
));
537 gc_assert(!from_space_p(first
));
545 trans_list(lispobj object
)
547 lispobj new_list_pointer
;
548 struct cons
*cons
, *new_cons
;
551 cons
= (struct cons
*) native_pointer(object
);
554 new_cons
= (struct cons
*)
555 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
556 new_cons
->car
= cons
->car
;
557 new_cons
->cdr
= cons
->cdr
; /* updated later */
558 new_list_pointer
= make_lispobj(new_cons
,lowtag_of(object
));
560 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
563 set_forwarding_pointer((lispobj
*)cons
, new_list_pointer
);
565 /* Try to linearize the list in the cdr direction to help reduce
569 struct cons
*cdr_cons
, *new_cdr_cons
;
571 if(lowtag_of(cdr
) != LIST_POINTER_LOWTAG
||
572 !from_space_p(cdr
) ||
573 forwarding_pointer_p((lispobj
*)native_pointer(cdr
)))
576 cdr_cons
= (struct cons
*) native_pointer(cdr
);
579 new_cdr_cons
= (struct cons
*)
580 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
581 new_cdr_cons
->car
= cdr_cons
->car
;
582 new_cdr_cons
->cdr
= cdr_cons
->cdr
;
583 new_cdr
= make_lispobj(new_cdr_cons
, lowtag_of(cdr
));
585 /* Grab the cdr before it is clobbered. */
587 set_forwarding_pointer((lispobj
*)cdr_cons
, new_cdr
);
589 /* Update the cdr of the last cons copied into new space to
590 * keep the newspace scavenge from having to do it. */
591 new_cons
->cdr
= new_cdr
;
593 new_cons
= new_cdr_cons
;
596 return new_list_pointer
;
601 * scavenging and transporting other pointers
605 scav_other_pointer(lispobj
*where
, lispobj object
)
607 lispobj first
, *first_pointer
;
609 gc_assert(is_lisp_pointer(object
));
611 /* Object is a pointer into from space - not FP. */
612 first_pointer
= (lispobj
*) native_pointer(object
);
613 first
= (transother
[widetag_of(*first_pointer
)])(object
);
615 if (first
!= object
) {
616 set_forwarding_pointer(first_pointer
, first
);
617 #ifdef LISP_FEATURE_GENCGC
621 #ifndef LISP_FEATURE_GENCGC
624 gc_assert(is_lisp_pointer(first
));
625 gc_assert(!from_space_p(first
));
631 * immediate, boxed, and unboxed objects
635 size_pointer(lispobj
*where
)
641 scav_immediate(lispobj
*where
, lispobj object
)
647 trans_immediate(lispobj object
)
649 lose("trying to transport an immediate\n");
650 return NIL
; /* bogus return value to satisfy static type checking */
654 size_immediate(lispobj
*where
)
661 scav_boxed(lispobj
*where
, lispobj object
)
666 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
668 /* If the bignum in the layout has another pointer to it (besides the layout)
669 acting as a root, and which is scavenged first, then transporting the
670 bignum causes the layout to see a FP, as would copying an instance whose
671 layout that is. This is a nearly impossible scenario to create organically
672 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
673 except for a few things that would cause it to be pinned anyway,
674 such as it being kept in a local variable during structure manipulation.
675 See 'interleaved-raw.impure.lisp' for a way to trigger this */
676 if (forwarding_pointer_p((lispobj
*)bignum
)) {
677 lispobj
*forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
679 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
680 (void*)bignum
, (void*)forwarded
);
682 bignum
= (struct bignum
*)native_pointer((lispobj
)forwarded
);
685 int len
= HeaderValue(bignum
->header
);
686 int word_index
= index
/ N_WORD_BITS
;
687 int bit_index
= index
% N_WORD_BITS
;
688 if (word_index
>= len
) {
689 // just return 0 since the marking logic does not allow negative bignums
692 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
696 // Helper function for helper function below, since lambda isn't a thing
697 static void instance_scan_range(void* instance_ptr
, int offset
, int nwords
)
699 scavenge((lispobj
*)instance_ptr
+ offset
, nwords
);
702 // Helper function for stepping through the tagged slots of an instance in
703 // scav_instance and verify_space.
705 instance_scan_interleaved(void (*proc
)(lispobj
*, sword_t
),
706 lispobj
*instance_ptr
,
710 struct layout
*layout
= (struct layout
*)layout_obj
;
711 lispobj layout_bitmap
= layout
->bitmap
;
714 /* This code might be made more efficient by run-length-encoding the ranges
715 of words to scan, but probably not by much */
717 ++instance_ptr
; // was supplied as the address of the header word
718 if (fixnump(layout_bitmap
)) {
719 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
720 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
722 proc(instance_ptr
+ index
, 1);
723 } else { /* huge bitmap */
724 struct bignum
* bitmap
;
725 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
726 if (forwarding_pointer_p((lispobj
*)bitmap
))
727 bitmap
= (struct bignum
*)
728 native_pointer((lispobj
)forwarding_pointer_value((lispobj
*)bitmap
));
729 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
730 instance_scan_range
, instance_ptr
);
734 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
735 void (*proc
)(void*, int, int), void* arg
)
737 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
738 int start_word_index
= 0;
740 in_use_marker_t word
;
742 flags
= flags
& BIT_SCAN_CLEAR
;
744 // Rather than bzero'ing we can just clear each nonzero word as it's read,
746 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
749 int skip_bits
, start_bit
, start_position
, run_length
;
751 if (++start_word_index
>= n_bitmap_words
) break;
752 BITMAP_REF(start_word_index
);
756 // On each loop iteration, the lowest 1 bit is a "relative"
757 // bit index, since the word was already shifted. This is 'skip_bits'.
758 // Adding back in the total shift amount gives 'start_bit',
759 // the true absolute index within the current word.
760 // 'start_position' is absolute within the entire bitmap.
761 skip_bits
= ffsl(word
) - 1;
762 start_bit
= skip_bits
+ shift
;
763 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
764 // Compute the number of consecutive 1s in the current word.
766 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
767 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
769 shift
+= skip_bits
+ run_length
;
771 int end_word_index
= ++start_word_index
;
773 if (end_word_index
>= n_bitmap_words
) {
775 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
778 BITMAP_REF(end_word_index
);
782 // end_word_index is the exclusive bound on contiguous
783 // words to include in the range. See if the low bits
784 // from the next word can extend the range.
785 shift
= ffsl(~word
) - 1;
787 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
792 start_word_index
= end_word_index
;
794 proc(arg
, start_position
, run_length
);
800 scav_instance(lispobj
*where
, lispobj header
)
802 // instance_length() is the number of words following the header including
803 // the layout. If this is an even number, it should be made odd so that
804 // scav_instance() always consumes an even number of words in total.
805 sword_t ntotal
= instance_length(header
) | 1;
806 lispobj
* layout
= (lispobj
*)instance_layout(where
);
810 layout
= native_pointer((lispobj
)layout
);
811 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
812 if (__immobile_obj_gen_bits(layout
) == from_space
)
813 promote_immobile_obj(layout
);
815 if (forwarding_pointer_p(layout
))
816 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
819 if (((struct layout
*)layout
)->bitmap
== make_fixnum(-1))
820 scavenge(where
+1, ntotal
);
822 instance_scan_interleaved(scavenge
, where
, ntotal
, layout
);
828 trans_boxed(lispobj object
)
833 gc_assert(is_lisp_pointer(object
));
835 header
= *((lispobj
*) native_pointer(object
));
836 length
= HeaderValue(header
) + 1;
837 length
= CEILING(length
, 2);
839 return copy_object(object
, length
);
843 size_boxed(lispobj
*where
)
849 length
= HeaderValue(header
) + 1;
850 length
= CEILING(length
, 2);
856 trans_tiny_boxed(lispobj object
)
861 gc_assert(is_lisp_pointer(object
));
863 header
= *((lispobj
*) native_pointer(object
));
864 length
= (HeaderValue(header
) & 0xFF) + 1;
865 length
= CEILING(length
, 2);
867 return copy_object(object
, length
);
871 size_tiny_boxed(lispobj
*where
)
877 length
= (HeaderValue(header
) & 0xFF) + 1;
878 length
= CEILING(length
, 2);
883 /* Note: on the sparc we don't have to do anything special for fdefns, */
884 /* 'cause the raw-addr has a function lowtag. */
885 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
887 scav_fdefn(lispobj
*where
, lispobj object
)
891 fdefn
= (struct fdefn
*)where
;
893 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
894 fdefn->fun, fdefn->raw_addr)); */
896 scavenge(where
+ 1, 2); // 'name' and 'fun'
897 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
898 if (raw_fun
> READ_ONLY_SPACE_END
) {
899 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
900 scavenge(&simple_fun
, 1);
901 /* Don't write unnecessarily. */
902 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
903 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
910 scav_unboxed(lispobj
*where
, lispobj object
)
914 length
= HeaderValue(object
) + 1;
915 length
= CEILING(length
, 2);
921 trans_unboxed(lispobj object
)
927 gc_assert(is_lisp_pointer(object
));
929 header
= *((lispobj
*) native_pointer(object
));
930 length
= HeaderValue(header
) + 1;
931 length
= CEILING(length
, 2);
933 return copy_unboxed_object(object
, length
);
937 size_unboxed(lispobj
*where
)
943 length
= HeaderValue(header
) + 1;
944 length
= CEILING(length
, 2);
950 /* vector-like objects */
952 scav_base_string(lispobj
*where
, lispobj object
)
954 struct vector
*vector
;
955 sword_t length
, nwords
;
957 /* NOTE: Strings contain one more byte of data than the length */
958 /* slot indicates. */
960 vector
= (struct vector
*) where
;
961 length
= fixnum_value(vector
->length
) + 1;
962 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
967 trans_base_string(lispobj object
)
969 struct vector
*vector
;
970 sword_t length
, nwords
;
972 gc_assert(is_lisp_pointer(object
));
974 /* NOTE: A string contains one more byte of data (a terminating
975 * '\0' to help when interfacing with C functions) than indicated
976 * by the length slot. */
978 vector
= (struct vector
*) native_pointer(object
);
979 length
= fixnum_value(vector
->length
) + 1;
980 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
982 return copy_large_unboxed_object(object
, nwords
);
986 size_base_string(lispobj
*where
)
988 struct vector
*vector
;
989 sword_t length
, nwords
;
991 /* NOTE: A string contains one more byte of data (a terminating
992 * '\0' to help when interfacing with C functions) than indicated
993 * by the length slot. */
995 vector
= (struct vector
*) where
;
996 length
= fixnum_value(vector
->length
) + 1;
997 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1002 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1004 scav_character_string(lispobj
*where
, lispobj object
)
1006 struct vector
*vector
;
1009 /* NOTE: Strings contain one more byte of data than the length */
1010 /* slot indicates. */
1012 vector
= (struct vector
*) where
;
1013 length
= fixnum_value(vector
->length
) + 1;
1014 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1019 trans_character_string(lispobj object
)
1021 struct vector
*vector
;
1024 gc_assert(is_lisp_pointer(object
));
1026 /* NOTE: A string contains one more byte of data (a terminating
1027 * '\0' to help when interfacing with C functions) than indicated
1028 * by the length slot. */
1030 vector
= (struct vector
*) native_pointer(object
);
1031 length
= fixnum_value(vector
->length
) + 1;
1032 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1034 return copy_large_unboxed_object(object
, nwords
);
1038 size_character_string(lispobj
*where
)
1040 struct vector
*vector
;
1043 /* NOTE: A string contains one more byte of data (a terminating
1044 * '\0' to help when interfacing with C functions) than indicated
1045 * by the length slot. */
1047 vector
= (struct vector
*) where
;
1048 length
= fixnum_value(vector
->length
) + 1;
1049 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1056 trans_vector(lispobj object
)
1058 struct vector
*vector
;
1059 sword_t length
, nwords
;
1061 gc_assert(is_lisp_pointer(object
));
1063 vector
= (struct vector
*) native_pointer(object
);
1065 length
= fixnum_value(vector
->length
);
1066 nwords
= CEILING(length
+ 2, 2);
1068 return copy_large_object(object
, nwords
);
1072 size_vector(lispobj
*where
)
1074 struct vector
*vector
;
1075 sword_t length
, nwords
;
1077 vector
= (struct vector
*) where
;
1078 length
= fixnum_value(vector
->length
);
1079 nwords
= CEILING(length
+ 2, 2);
1085 scav_vector_nil(lispobj
*where
, lispobj object
)
1091 trans_vector_nil(lispobj object
)
1093 gc_assert(is_lisp_pointer(object
));
1094 return copy_unboxed_object(object
, 2);
1098 size_vector_nil(lispobj
*where
)
1100 /* Just the header word and the length word */
1105 scav_vector_bit(lispobj
*where
, lispobj object
)
1107 struct vector
*vector
;
1108 sword_t length
, nwords
;
1110 vector
= (struct vector
*) where
;
1111 length
= fixnum_value(vector
->length
);
1112 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1118 trans_vector_bit(lispobj object
)
1120 struct vector
*vector
;
1121 sword_t length
, nwords
;
1123 gc_assert(is_lisp_pointer(object
));
1125 vector
= (struct vector
*) native_pointer(object
);
1126 length
= fixnum_value(vector
->length
);
1127 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1129 return copy_large_unboxed_object(object
, nwords
);
1133 size_vector_bit(lispobj
*where
)
1135 struct vector
*vector
;
1136 sword_t length
, nwords
;
1138 vector
= (struct vector
*) where
;
1139 length
= fixnum_value(vector
->length
);
1140 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1146 scav_vector_unsigned_byte_2(lispobj
*where
, lispobj object
)
1148 struct vector
*vector
;
1149 sword_t length
, nwords
;
1151 vector
= (struct vector
*) where
;
1152 length
= fixnum_value(vector
->length
);
1153 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1159 trans_vector_unsigned_byte_2(lispobj object
)
1161 struct vector
*vector
;
1162 sword_t length
, nwords
;
1164 gc_assert(is_lisp_pointer(object
));
1166 vector
= (struct vector
*) native_pointer(object
);
1167 length
= fixnum_value(vector
->length
);
1168 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1170 return copy_large_unboxed_object(object
, nwords
);
1174 size_vector_unsigned_byte_2(lispobj
*where
)
1176 struct vector
*vector
;
1177 sword_t length
, nwords
;
1179 vector
= (struct vector
*) where
;
1180 length
= fixnum_value(vector
->length
);
1181 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1187 scav_vector_unsigned_byte_4(lispobj
*where
, lispobj object
)
1189 struct vector
*vector
;
1190 sword_t length
, nwords
;
1192 vector
= (struct vector
*) where
;
1193 length
= fixnum_value(vector
->length
);
1194 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1200 trans_vector_unsigned_byte_4(lispobj object
)
1202 struct vector
*vector
;
1203 sword_t length
, nwords
;
1205 gc_assert(is_lisp_pointer(object
));
1207 vector
= (struct vector
*) native_pointer(object
);
1208 length
= fixnum_value(vector
->length
);
1209 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1211 return copy_large_unboxed_object(object
, nwords
);
1214 size_vector_unsigned_byte_4(lispobj
*where
)
1216 struct vector
*vector
;
1217 sword_t length
, nwords
;
1219 vector
= (struct vector
*) where
;
1220 length
= fixnum_value(vector
->length
);
1221 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1228 scav_vector_unsigned_byte_8(lispobj
*where
, lispobj object
)
1230 struct vector
*vector
;
1231 sword_t length
, nwords
;
1233 vector
= (struct vector
*) where
;
1234 length
= fixnum_value(vector
->length
);
1235 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1240 /*********************/
1245 trans_vector_unsigned_byte_8(lispobj object
)
1247 struct vector
*vector
;
1248 sword_t length
, nwords
;
1250 gc_assert(is_lisp_pointer(object
));
1252 vector
= (struct vector
*) native_pointer(object
);
1253 length
= fixnum_value(vector
->length
);
1254 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1256 return copy_large_unboxed_object(object
, nwords
);
1260 size_vector_unsigned_byte_8(lispobj
*where
)
1262 struct vector
*vector
;
1263 sword_t length
, nwords
;
1265 vector
= (struct vector
*) where
;
1266 length
= fixnum_value(vector
->length
);
1267 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1274 scav_vector_unsigned_byte_16(lispobj
*where
, lispobj object
)
1276 struct vector
*vector
;
1277 sword_t length
, nwords
;
1279 vector
= (struct vector
*) where
;
1280 length
= fixnum_value(vector
->length
);
1281 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1287 trans_vector_unsigned_byte_16(lispobj object
)
1289 struct vector
*vector
;
1290 sword_t length
, nwords
;
1292 gc_assert(is_lisp_pointer(object
));
1294 vector
= (struct vector
*) native_pointer(object
);
1295 length
= fixnum_value(vector
->length
);
1296 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1298 return copy_large_unboxed_object(object
, nwords
);
1302 size_vector_unsigned_byte_16(lispobj
*where
)
1304 struct vector
*vector
;
1305 sword_t length
, nwords
;
1307 vector
= (struct vector
*) where
;
1308 length
= fixnum_value(vector
->length
);
1309 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1315 scav_vector_unsigned_byte_32(lispobj
*where
, lispobj object
)
1317 struct vector
*vector
;
1318 sword_t length
, nwords
;
1320 vector
= (struct vector
*) where
;
1321 length
= fixnum_value(vector
->length
);
1322 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1328 trans_vector_unsigned_byte_32(lispobj object
)
1330 struct vector
*vector
;
1331 sword_t length
, nwords
;
1333 gc_assert(is_lisp_pointer(object
));
1335 vector
= (struct vector
*) native_pointer(object
);
1336 length
= fixnum_value(vector
->length
);
1337 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1339 return copy_large_unboxed_object(object
, nwords
);
1343 size_vector_unsigned_byte_32(lispobj
*where
)
1345 struct vector
*vector
;
1346 sword_t length
, nwords
;
1348 vector
= (struct vector
*) where
;
1349 length
= fixnum_value(vector
->length
);
1350 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1355 #if N_WORD_BITS == 64
1357 scav_vector_unsigned_byte_64(lispobj
*where
, lispobj object
)
1359 struct vector
*vector
;
1360 sword_t length
, nwords
;
1362 vector
= (struct vector
*) where
;
1363 length
= fixnum_value(vector
->length
);
1364 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1370 trans_vector_unsigned_byte_64(lispobj object
)
1372 struct vector
*vector
;
1373 sword_t length
, nwords
;
1375 gc_assert(is_lisp_pointer(object
));
1377 vector
= (struct vector
*) native_pointer(object
);
1378 length
= fixnum_value(vector
->length
);
1379 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1381 return copy_large_unboxed_object(object
, nwords
);
1385 size_vector_unsigned_byte_64(lispobj
*where
)
1387 struct vector
*vector
;
1388 sword_t length
, nwords
;
1390 vector
= (struct vector
*) where
;
1391 length
= fixnum_value(vector
->length
);
1392 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1399 scav_vector_single_float(lispobj
*where
, lispobj object
)
1401 struct vector
*vector
;
1402 sword_t length
, nwords
;
1404 vector
= (struct vector
*) where
;
1405 length
= fixnum_value(vector
->length
);
1406 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1412 trans_vector_single_float(lispobj object
)
1414 struct vector
*vector
;
1415 sword_t length
, nwords
;
1417 gc_assert(is_lisp_pointer(object
));
1419 vector
= (struct vector
*) native_pointer(object
);
1420 length
= fixnum_value(vector
->length
);
1421 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1423 return copy_large_unboxed_object(object
, nwords
);
1427 size_vector_single_float(lispobj
*where
)
1429 struct vector
*vector
;
1430 sword_t length
, nwords
;
1432 vector
= (struct vector
*) where
;
1433 length
= fixnum_value(vector
->length
);
1434 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1440 scav_vector_double_float(lispobj
*where
, lispobj object
)
1442 struct vector
*vector
;
1443 sword_t length
, nwords
;
1445 vector
= (struct vector
*) where
;
1446 length
= fixnum_value(vector
->length
);
1447 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1453 trans_vector_double_float(lispobj object
)
1455 struct vector
*vector
;
1456 sword_t length
, nwords
;
1458 gc_assert(is_lisp_pointer(object
));
1460 vector
= (struct vector
*) native_pointer(object
);
1461 length
= fixnum_value(vector
->length
);
1462 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1464 return copy_large_unboxed_object(object
, nwords
);
1468 size_vector_double_float(lispobj
*where
)
1470 struct vector
*vector
;
1471 sword_t length
, nwords
;
1473 vector
= (struct vector
*) where
;
1474 length
= fixnum_value(vector
->length
);
1475 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1480 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1482 scav_vector_long_float(lispobj
*where
, lispobj object
)
1484 struct vector
*vector
;
1485 long length
, nwords
;
1487 vector
= (struct vector
*) where
;
1488 length
= fixnum_value(vector
->length
);
1489 nwords
= CEILING(length
*
1496 trans_vector_long_float(lispobj object
)
1498 struct vector
*vector
;
1499 long length
, nwords
;
1501 gc_assert(is_lisp_pointer(object
));
1503 vector
= (struct vector
*) native_pointer(object
);
1504 length
= fixnum_value(vector
->length
);
1505 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1507 return copy_large_unboxed_object(object
, nwords
);
1511 size_vector_long_float(lispobj
*where
)
1513 struct vector
*vector
;
1514 sword_t length
, nwords
;
1516 vector
= (struct vector
*) where
;
1517 length
= fixnum_value(vector
->length
);
1518 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1525 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1527 scav_vector_complex_single_float(lispobj
*where
, lispobj object
)
1529 struct vector
*vector
;
1530 sword_t length
, nwords
;
1532 vector
= (struct vector
*) where
;
1533 length
= fixnum_value(vector
->length
);
1534 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1540 trans_vector_complex_single_float(lispobj object
)
1542 struct vector
*vector
;
1543 sword_t length
, nwords
;
1545 gc_assert(is_lisp_pointer(object
));
1547 vector
= (struct vector
*) native_pointer(object
);
1548 length
= fixnum_value(vector
->length
);
1549 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1551 return copy_large_unboxed_object(object
, nwords
);
1555 size_vector_complex_single_float(lispobj
*where
)
1557 struct vector
*vector
;
1558 sword_t length
, nwords
;
1560 vector
= (struct vector
*) where
;
1561 length
= fixnum_value(vector
->length
);
1562 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1568 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1570 scav_vector_complex_double_float(lispobj
*where
, lispobj object
)
1572 struct vector
*vector
;
1573 sword_t length
, nwords
;
1575 vector
= (struct vector
*) where
;
1576 length
= fixnum_value(vector
->length
);
1577 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1583 trans_vector_complex_double_float(lispobj object
)
1585 struct vector
*vector
;
1586 sword_t length
, nwords
;
1588 gc_assert(is_lisp_pointer(object
));
1590 vector
= (struct vector
*) native_pointer(object
);
1591 length
= fixnum_value(vector
->length
);
1592 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1594 return copy_large_unboxed_object(object
, nwords
);
1598 size_vector_complex_double_float(lispobj
*where
)
1600 struct vector
*vector
;
1601 sword_t length
, nwords
;
1603 vector
= (struct vector
*) where
;
1604 length
= fixnum_value(vector
->length
);
1605 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1612 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1614 scav_vector_complex_long_float(lispobj
*where
, lispobj object
)
1616 struct vector
*vector
;
1617 sword_t length
, nwords
;
1619 vector
= (struct vector
*) where
;
1620 length
= fixnum_value(vector
->length
);
1621 nwords
= CEILING(length
* (2* LONG_FLOAT_SIZE
) + 2, 2);
1627 trans_vector_complex_long_float(lispobj object
)
1629 struct vector
*vector
;
1630 long length
, nwords
;
1632 gc_assert(is_lisp_pointer(object
));
1634 vector
= (struct vector
*) native_pointer(object
);
1635 length
= fixnum_value(vector
->length
);
1636 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1638 return copy_large_unboxed_object(object
, nwords
);
1642 size_vector_complex_long_float(lispobj
*where
)
1644 struct vector
*vector
;
1645 long length
, nwords
;
1647 vector
= (struct vector
*) where
;
1648 length
= fixnum_value(vector
->length
);
1649 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1655 #define WEAK_POINTER_NWORDS \
1656 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1659 trans_weak_pointer(lispobj object
)
1662 #ifndef LISP_FEATURE_GENCGC
1663 struct weak_pointer
*wp
;
1665 gc_assert(is_lisp_pointer(object
));
1667 #if defined(DEBUG_WEAK)
1668 printf("Transporting weak pointer from 0x%08x\n", object
);
1671 /* Need to remember where all the weak pointers are that have */
1672 /* been transported so they can be fixed up in a post-GC pass. */
1674 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
1675 #ifndef LISP_FEATURE_GENCGC
1676 wp
= (struct weak_pointer
*) native_pointer(copy
);
1678 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1679 /* Push the weak pointer onto the list of weak pointers. */
1680 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
1687 size_weak_pointer(lispobj
*where
)
1689 return WEAK_POINTER_NWORDS
;
1693 void scan_weak_pointers(void)
1695 struct weak_pointer
*wp
, *next_wp
;
1696 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
1697 lispobj value
= wp
->value
;
1698 lispobj
*first_pointer
;
1699 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1703 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
1706 if (!is_lisp_pointer(value
))
1709 /* Now, we need to check whether the object has been forwarded. If
1710 * it has been, the weak pointer is still good and needs to be
1711 * updated. Otherwise, the weak pointer needs to be nil'ed
1714 if (from_space_p(value
)) {
1715 first_pointer
= (lispobj
*)native_pointer(value
);
1717 if (forwarding_pointer_p(first_pointer
)) {
1719 (lispobj
)LOW_WORD(forwarding_pointer_value(first_pointer
));
1726 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1727 else if (immobile_space_p(value
) &&
1728 immobile_obj_gen_bits(native_pointer(value
)) == from_space
) {
1739 #if N_WORD_BITS == 32
1740 #define EQ_HASH_MASK 0x1fffffff
1741 #elif N_WORD_BITS == 64
1742 #define EQ_HASH_MASK 0x1fffffffffffffff
1745 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1746 * target-hash-table.lisp. */
1747 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1749 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1750 * slot. Set to NULL at the end of a collection.
1752 * This is not optimal because, when a table is tenured, it won't be
1753 * processed automatically; only the yougest generation is GC'd by
1754 * default. On the other hand, all applications will need an
1755 * occasional full GC anyway, so it's not that bad either. */
1756 struct hash_table
*weak_hash_tables
= NULL
;
1758 /* Return true if OBJ has already survived the current GC. */
1760 survived_gc_yet (lispobj obj
)
1762 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1763 /* If an immobile object's generation# is that of 'from_space', but has been
1764 visited (i.e. is live), then it is conceptually not in 'from_space'.
1765 This can happen when and only when _not_ raising the generation number.
1766 Since the gen_bits() accessor returns the visited bit, the byte value
1767 is numerically unequal to 'from_space', which is what we want */
1768 return !is_lisp_pointer(obj
)
1769 || (immobile_space_p(obj
)
1770 ? immobile_obj_gen_bits(native_pointer(obj
)) != from_space
1771 : (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
))));
1773 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1774 forwarding_pointer_p(native_pointer(obj
)));
1779 weak_hash_entry_alivep (lispobj weakness
, lispobj key
, lispobj value
)
1783 return survived_gc_yet(key
);
1785 return survived_gc_yet(value
);
1787 return (survived_gc_yet(key
) || survived_gc_yet(value
));
1789 return (survived_gc_yet(key
) && survived_gc_yet(value
));
1792 /* Shut compiler up. */
1797 /* Return the beginning of data in ARRAY (skipping the header and the
1798 * length) or NULL if it isn't an array of the specified widetag after
1800 static inline lispobj
*
1801 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1803 if (is_lisp_pointer(array
) &&
1804 (widetag_of(*(lispobj
*)native_pointer(array
)) == widetag
)) {
1806 *length
= fixnum_value(((lispobj
*)native_pointer(array
))[1]);
1807 return ((lispobj
*)native_pointer(array
)) + 2;
1813 /* Only need to worry about scavenging the _real_ entries in the
1814 * table. Phantom entries such as the hash table itself at index 0 and
1815 * the empty marker at index 1 were scavenged by scav_vector that
1816 * either called this function directly or arranged for it to be
1817 * called later by pushing the hash table onto weak_hash_tables. */
1819 scav_hash_table_entries (struct hash_table
*hash_table
)
1823 lispobj
*index_vector
;
1825 lispobj
*next_vector
;
1826 uword_t next_vector_length
;
1827 lispobj
*hash_vector
;
1828 uword_t hash_vector_length
;
1829 lispobj empty_symbol
;
1830 lispobj weakness
= hash_table
->weakness
;
1833 kv_vector
= get_array_data(hash_table
->table
,
1834 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1835 if (kv_vector
== NULL
)
1836 lose("invalid kv_vector %x\n", hash_table
->table
);
1838 index_vector
= get_array_data(hash_table
->index_vector
,
1839 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1840 if (index_vector
== NULL
)
1841 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1843 next_vector
= get_array_data(hash_table
->next_vector
,
1844 SIMPLE_ARRAY_WORD_WIDETAG
,
1845 &next_vector_length
);
1846 if (next_vector
== NULL
)
1847 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1849 hash_vector
= get_array_data(hash_table
->hash_vector
,
1850 SIMPLE_ARRAY_WORD_WIDETAG
,
1851 &hash_vector_length
);
1852 if (hash_vector
!= NULL
)
1853 gc_assert(hash_vector_length
== next_vector_length
);
1855 /* These lengths could be different as the index_vector can be a
1856 * different length from the others, a larger index_vector could
1857 * help reduce collisions. */
1858 gc_assert(next_vector_length
*2 == kv_length
);
1860 empty_symbol
= kv_vector
[1];
1861 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1862 if (widetag_of(*(lispobj
*)native_pointer(empty_symbol
)) !=
1863 SYMBOL_HEADER_WIDETAG
) {
1864 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1865 *(lispobj
*)native_pointer(empty_symbol
));
1868 /* Work through the KV vector. */
1869 for (i
= 1; i
< next_vector_length
; i
++) {
1870 lispobj old_key
= kv_vector
[2*i
];
1871 lispobj value
= kv_vector
[2*i
+1];
1872 if ((weakness
== NIL
) ||
1873 weak_hash_entry_alivep(weakness
, old_key
, value
)) {
1875 /* Scavenge the key and value. */
1876 scavenge(&kv_vector
[2*i
],2);
1878 /* If an EQ-based key has moved, mark the hash-table for
1880 if (!hash_vector
|| hash_vector
[i
] == MAGIC_HASH_VECTOR_VALUE
) {
1881 lispobj new_key
= kv_vector
[2*i
];
1882 // FIXME: many EQ-based sxhash values are insensitive
1883 // to object movement. The most important one is SYMBOL,
1884 // but others also carry around a hash value: LAYOUT, CLASSOID,
1885 // and STANDARD-[FUNCALLABLE-]INSTANCE.
1886 // If old_key is any of those, don't set needs_rehash_p.
1887 if (old_key
!= new_key
&& new_key
!= empty_symbol
) {
1888 hash_table
->needs_rehash_p
= T
;
1896 scav_vector (lispobj
*where
, lispobj object
)
1899 struct hash_table
*hash_table
;
1901 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1902 * hash tables in the Lisp HASH-TABLE code to indicate need for
1903 * special GC support. */
1904 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
)
1907 kv_length
= fixnum_value(where
[1]);
1908 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1910 /* Scavenge element 0, which may be a hash-table structure. */
1911 scavenge(where
+2, 1);
1912 if (!is_lisp_pointer(where
[2])) {
1913 /* This'll happen when REHASH clears the header of old-kv-vector
1914 * and fills it with zero, but some other thread simulatenously
1915 * sets the header in %%PUTHASH.
1918 "Warning: no pointer at %p in hash table: this indicates "
1919 "non-fatal corruption caused by concurrent access to a "
1920 "hash-table from multiple threads. Any accesses to "
1921 "hash-tables shared between threads should be protected "
1922 "by locks.\n", (void*)&where
[2]);
1923 // We've scavenged three words.
1926 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1927 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1928 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1929 lose("hash table not instance (%x at %x)\n",
1934 /* Scavenge element 1, which should be some internal symbol that
1935 * the hash table code reserves for marking empty slots. */
1936 scavenge(where
+3, 1);
1937 if (!is_lisp_pointer(where
[3])) {
1938 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1941 /* Scavenge hash table, which will fix the positions of the other
1942 * needed objects. */
1943 scavenge((lispobj
*)hash_table
,
1944 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1946 /* Cross-check the kv_vector. */
1947 if (where
!= (lispobj
*)native_pointer(hash_table
->table
)) {
1948 lose("hash_table table!=this table %x\n", hash_table
->table
);
1951 if (hash_table
->weakness
== NIL
) {
1952 scav_hash_table_entries(hash_table
);
1954 /* Delay scavenging of this table by pushing it onto
1955 * weak_hash_tables (if it's not there already) for the weak
1957 if (hash_table
->next_weak_hash_table
== NIL
) {
1958 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1959 weak_hash_tables
= hash_table
;
1963 return (CEILING(kv_length
+ 2, 2));
1967 scav_weak_hash_tables (void)
1969 struct hash_table
*table
;
1971 /* Scavenge entries whose triggers are known to survive. */
1972 for (table
= weak_hash_tables
; table
!= NULL
;
1973 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1974 scav_hash_table_entries(table
);
1978 /* Walk through the chain whose first element is *FIRST and remove
1979 * dead weak entries. */
1981 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1982 lispobj
*kv_vector
, lispobj
*index_vector
,
1983 lispobj
*next_vector
, lispobj
*hash_vector
,
1984 lispobj empty_symbol
, lispobj weakness
)
1986 unsigned index
= *prev
;
1988 unsigned next
= next_vector
[index
];
1989 lispobj key
= kv_vector
[2 * index
];
1990 lispobj value
= kv_vector
[2 * index
+ 1];
1991 gc_assert(key
!= empty_symbol
);
1992 gc_assert(value
!= empty_symbol
);
1993 if (!weak_hash_entry_alivep(weakness
, key
, value
)) {
1994 unsigned count
= fixnum_value(hash_table
->number_entries
);
1995 gc_assert(count
> 0);
1997 hash_table
->number_entries
= make_fixnum(count
- 1);
1998 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1999 hash_table
->next_free_kv
= make_fixnum(index
);
2000 kv_vector
[2 * index
] = empty_symbol
;
2001 kv_vector
[2 * index
+ 1] = empty_symbol
;
2003 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
2005 prev
= &next_vector
[index
];
2012 scan_weak_hash_table (struct hash_table
*hash_table
)
2015 lispobj
*index_vector
;
2016 uword_t length
= 0; /* prevent warning */
2017 lispobj
*next_vector
;
2018 uword_t next_vector_length
= 0; /* prevent warning */
2019 lispobj
*hash_vector
;
2020 lispobj empty_symbol
;
2021 lispobj weakness
= hash_table
->weakness
;
2024 kv_vector
= get_array_data(hash_table
->table
,
2025 SIMPLE_VECTOR_WIDETAG
, NULL
);
2026 index_vector
= get_array_data(hash_table
->index_vector
,
2027 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
2028 next_vector
= get_array_data(hash_table
->next_vector
,
2029 SIMPLE_ARRAY_WORD_WIDETAG
,
2030 &next_vector_length
);
2031 hash_vector
= get_array_data(hash_table
->hash_vector
,
2032 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
2033 empty_symbol
= kv_vector
[1];
2035 for (i
= 0; i
< length
; i
++) {
2036 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
2037 kv_vector
, index_vector
, next_vector
,
2038 hash_vector
, empty_symbol
, weakness
);
2042 /* Remove dead entries from weak hash tables. */
2044 scan_weak_hash_tables (void)
2046 struct hash_table
*table
, *next
;
2048 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
2049 next
= (struct hash_table
*)table
->next_weak_hash_table
;
2050 table
->next_weak_hash_table
= NIL
;
2051 scan_weak_hash_table(table
);
2054 weak_hash_tables
= NULL
;
2063 scav_lose(lispobj
*where
, lispobj object
)
2065 lose("no scavenge function for object %p (widetag 0x%x)\n",
2067 widetag_of(*where
));
2069 return 0; /* bogus return value to satisfy static type checking */
2073 trans_lose(lispobj object
)
2075 lose("no transport function for object %p (widetag 0x%x)\n",
2077 widetag_of(*(lispobj
*)native_pointer(object
)));
2078 return NIL
; /* bogus return value to satisfy static type checking */
2082 size_lose(lispobj
*where
)
2084 lose("no size function for object at %p (widetag 0x%x)\n",
2086 widetag_of(*where
));
2087 return 1; /* bogus return value to satisfy static type checking */
2096 gc_init_tables(void)
2100 /* Set default value in all slots of scavenge table. FIXME
2101 * replace this gnarly sizeof with something based on
2103 for (i
= 0; i
< ((sizeof scavtab
)/(sizeof scavtab
[0])); i
++) {
2104 scavtab
[i
] = scav_lose
;
2107 /* For each type which can be selected by the lowtag alone, set
2108 * multiple entries in our widetag scavenge table (one for each
2109 * possible value of the high bits).
2112 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2113 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2115 scavtab
[j
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
2118 scavtab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_fun_pointer
;
2119 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2120 scavtab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_list_pointer
;
2121 scavtab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] =
2122 scav_instance_pointer
;
2123 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2124 scavtab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_other_pointer
;
2127 /* Other-pointer types (those selected by all eight bits of the
2128 * tag) get one entry each in the scavenge table. */
2129 scavtab
[BIGNUM_WIDETAG
] = scav_unboxed
;
2130 scavtab
[RATIO_WIDETAG
] = scav_boxed
;
2131 #if N_WORD_BITS == 64
2132 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_immediate
;
2134 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2136 scavtab
[DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2137 #ifdef LONG_FLOAT_WIDETAG
2138 scavtab
[LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2140 scavtab
[COMPLEX_WIDETAG
] = scav_boxed
;
2141 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2142 scavtab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2144 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2145 scavtab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2147 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2148 scavtab
[COMPLEX_LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2150 #ifdef SIMD_PACK_WIDETAG
2151 scavtab
[SIMD_PACK_WIDETAG
] = scav_unboxed
;
2153 scavtab
[SIMPLE_ARRAY_WIDETAG
] = scav_boxed
;
2154 scavtab
[SIMPLE_BASE_STRING_WIDETAG
] = scav_base_string
;
2155 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2156 scavtab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = scav_character_string
;
2158 scavtab
[SIMPLE_BIT_VECTOR_WIDETAG
] = scav_vector_bit
;
2159 scavtab
[SIMPLE_ARRAY_NIL_WIDETAG
] = scav_vector_nil
;
2160 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2161 scav_vector_unsigned_byte_2
;
2162 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2163 scav_vector_unsigned_byte_4
;
2164 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2165 scav_vector_unsigned_byte_8
;
2166 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2167 scav_vector_unsigned_byte_8
;
2168 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2169 scav_vector_unsigned_byte_16
;
2170 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2171 scav_vector_unsigned_byte_16
;
2172 #if (N_WORD_BITS == 32)
2173 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2174 scav_vector_unsigned_byte_32
;
2176 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2177 scav_vector_unsigned_byte_32
;
2178 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2179 scav_vector_unsigned_byte_32
;
2180 #if (N_WORD_BITS == 64)
2181 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2182 scav_vector_unsigned_byte_64
;
2184 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2185 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2186 scav_vector_unsigned_byte_64
;
2188 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2189 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2190 scav_vector_unsigned_byte_64
;
2192 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2193 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = scav_vector_unsigned_byte_8
;
2195 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2196 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2197 scav_vector_unsigned_byte_16
;
2199 #if (N_WORD_BITS == 32)
2200 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2201 scav_vector_unsigned_byte_32
;
2203 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2204 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2205 scav_vector_unsigned_byte_32
;
2207 #if (N_WORD_BITS == 64)
2208 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2209 scav_vector_unsigned_byte_64
;
2211 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2212 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2213 scav_vector_unsigned_byte_64
;
2215 scavtab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = scav_vector_single_float
;
2216 scavtab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = scav_vector_double_float
;
2217 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2218 scavtab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = scav_vector_long_float
;
2220 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2221 scavtab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2222 scav_vector_complex_single_float
;
2224 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2225 scavtab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2226 scav_vector_complex_double_float
;
2228 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2229 scavtab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2230 scav_vector_complex_long_float
;
2232 scavtab
[COMPLEX_BASE_STRING_WIDETAG
] = scav_boxed
;
2233 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2234 scavtab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = scav_boxed
;
2236 scavtab
[COMPLEX_VECTOR_NIL_WIDETAG
] = scav_boxed
;
2237 scavtab
[COMPLEX_BIT_VECTOR_WIDETAG
] = scav_boxed
;
2238 scavtab
[COMPLEX_VECTOR_WIDETAG
] = scav_boxed
;
2239 scavtab
[COMPLEX_ARRAY_WIDETAG
] = scav_boxed
;
2240 scavtab
[CODE_HEADER_WIDETAG
] = scav_code_header
;
2241 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2242 scavtab
[SIMPLE_FUN_HEADER_WIDETAG
] = scav_fun_header
;
2243 scavtab
[RETURN_PC_HEADER_WIDETAG
] = scav_return_pc_header
;
2245 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_boxed
;
2246 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2247 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_closure_header
;
2249 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_boxed
;
2251 scavtab
[VALUE_CELL_HEADER_WIDETAG
] = scav_boxed
;
2252 scavtab
[SYMBOL_HEADER_WIDETAG
] = scav_boxed
;
2253 scavtab
[CHARACTER_WIDETAG
] = scav_immediate
;
2254 scavtab
[SAP_WIDETAG
] = scav_unboxed
;
2255 scavtab
[UNBOUND_MARKER_WIDETAG
] = scav_immediate
;
2256 scavtab
[NO_TLS_VALUE_MARKER_WIDETAG
] = scav_immediate
;
2257 scavtab
[INSTANCE_HEADER_WIDETAG
] = scav_instance
;
2258 #if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
2259 scavtab
[FDEFN_WIDETAG
] = scav_boxed
;
2261 scavtab
[FDEFN_WIDETAG
] = scav_fdefn
;
2263 scavtab
[SIMPLE_VECTOR_WIDETAG
] = scav_vector
;
2265 /* transport other table, initialized same way as scavtab */
2266 for (i
= 0; i
< ((sizeof transother
)/(sizeof transother
[0])); i
++)
2267 transother
[i
] = trans_lose
;
2268 transother
[BIGNUM_WIDETAG
] = trans_unboxed
;
2269 transother
[RATIO_WIDETAG
] = trans_boxed
;
2271 #if N_WORD_BITS == 64
2272 transother
[SINGLE_FLOAT_WIDETAG
] = trans_immediate
;
2274 transother
[SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2276 transother
[DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2277 #ifdef LONG_FLOAT_WIDETAG
2278 transother
[LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2280 transother
[COMPLEX_WIDETAG
] = trans_boxed
;
2281 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2282 transother
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2284 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2285 transother
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2287 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2288 transother
[COMPLEX_LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2290 transother
[SIMPLE_ARRAY_WIDETAG
] = trans_boxed
; /* but not GENCGC */
2291 transother
[SIMPLE_BASE_STRING_WIDETAG
] = trans_base_string
;
2292 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2293 transother
[SIMPLE_CHARACTER_STRING_WIDETAG
] = trans_character_string
;
2295 transother
[SIMPLE_BIT_VECTOR_WIDETAG
] = trans_vector_bit
;
2296 transother
[SIMPLE_VECTOR_WIDETAG
] = trans_vector
;
2297 transother
[SIMPLE_ARRAY_NIL_WIDETAG
] = trans_vector_nil
;
2298 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2299 trans_vector_unsigned_byte_2
;
2300 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2301 trans_vector_unsigned_byte_4
;
2302 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2303 trans_vector_unsigned_byte_8
;
2304 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2305 trans_vector_unsigned_byte_8
;
2306 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2307 trans_vector_unsigned_byte_16
;
2308 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2309 trans_vector_unsigned_byte_16
;
2310 #if (N_WORD_BITS == 32)
2311 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2312 trans_vector_unsigned_byte_32
;
2314 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2315 trans_vector_unsigned_byte_32
;
2316 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2317 trans_vector_unsigned_byte_32
;
2318 #if (N_WORD_BITS == 64)
2319 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2320 trans_vector_unsigned_byte_64
;
2322 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2323 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2324 trans_vector_unsigned_byte_64
;
2326 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2327 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2328 trans_vector_unsigned_byte_64
;
2330 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2331 transother
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] =
2332 trans_vector_unsigned_byte_8
;
2334 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2335 transother
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2336 trans_vector_unsigned_byte_16
;
2338 #if (N_WORD_BITS == 32)
2339 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2340 trans_vector_unsigned_byte_32
;
2342 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2343 transother
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2344 trans_vector_unsigned_byte_32
;
2346 #if (N_WORD_BITS == 64)
2347 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2348 trans_vector_unsigned_byte_64
;
2350 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2351 transother
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2352 trans_vector_unsigned_byte_64
;
2354 transother
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] =
2355 trans_vector_single_float
;
2356 transother
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] =
2357 trans_vector_double_float
;
2358 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2359 transother
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] =
2360 trans_vector_long_float
;
2362 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2363 transother
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2364 trans_vector_complex_single_float
;
2366 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2367 transother
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2368 trans_vector_complex_double_float
;
2370 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2371 transother
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2372 trans_vector_complex_long_float
;
2374 transother
[COMPLEX_BASE_STRING_WIDETAG
] = trans_boxed
;
2375 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2376 transother
[COMPLEX_CHARACTER_STRING_WIDETAG
] = trans_boxed
;
2378 transother
[COMPLEX_BIT_VECTOR_WIDETAG
] = trans_boxed
;
2379 transother
[COMPLEX_VECTOR_NIL_WIDETAG
] = trans_boxed
;
2380 transother
[COMPLEX_VECTOR_WIDETAG
] = trans_boxed
;
2381 transother
[COMPLEX_ARRAY_WIDETAG
] = trans_boxed
;
2382 transother
[CODE_HEADER_WIDETAG
] = trans_code_header
;
2383 transother
[SIMPLE_FUN_HEADER_WIDETAG
] = trans_fun_header
;
2384 transother
[RETURN_PC_HEADER_WIDETAG
] = trans_return_pc_header
;
2385 transother
[CLOSURE_HEADER_WIDETAG
] = trans_boxed
;
2386 transother
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = trans_boxed
;
2387 transother
[VALUE_CELL_HEADER_WIDETAG
] = trans_boxed
;
2388 transother
[SYMBOL_HEADER_WIDETAG
] = trans_tiny_boxed
;
2389 transother
[CHARACTER_WIDETAG
] = trans_immediate
;
2390 transother
[SAP_WIDETAG
] = trans_unboxed
;
2391 #ifdef SIMD_PACK_WIDETAG
2392 transother
[SIMD_PACK_WIDETAG
] = trans_unboxed
;
2394 transother
[UNBOUND_MARKER_WIDETAG
] = trans_immediate
;
2395 transother
[NO_TLS_VALUE_MARKER_WIDETAG
] = trans_immediate
;
2396 transother
[WEAK_POINTER_WIDETAG
] = trans_weak_pointer
;
2397 transother
[INSTANCE_HEADER_WIDETAG
] = trans_instance
;
2398 transother
[FDEFN_WIDETAG
] = trans_tiny_boxed
;
2400 /* size table, initialized the same way as scavtab */
2401 for (i
= 0; i
< ((sizeof sizetab
)/(sizeof sizetab
[0])); i
++)
2402 sizetab
[i
] = size_lose
;
2403 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2404 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2406 sizetab
[j
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
2409 sizetab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2410 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2411 sizetab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2412 sizetab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2413 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2414 sizetab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2416 sizetab
[BIGNUM_WIDETAG
] = size_unboxed
;
2417 sizetab
[RATIO_WIDETAG
] = size_boxed
;
2418 #if N_WORD_BITS == 64
2419 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_immediate
;
2421 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2423 sizetab
[DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2424 #ifdef LONG_FLOAT_WIDETAG
2425 sizetab
[LONG_FLOAT_WIDETAG
] = size_unboxed
;
2427 sizetab
[COMPLEX_WIDETAG
] = size_boxed
;
2428 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2429 sizetab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2431 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2432 sizetab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2434 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2435 sizetab
[COMPLEX_LONG_FLOAT_WIDETAG
] = size_unboxed
;
2437 sizetab
[SIMPLE_ARRAY_WIDETAG
] = size_boxed
;
2438 sizetab
[SIMPLE_BASE_STRING_WIDETAG
] = size_base_string
;
2439 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2440 sizetab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = size_character_string
;
2442 sizetab
[SIMPLE_BIT_VECTOR_WIDETAG
] = size_vector_bit
;
2443 sizetab
[SIMPLE_VECTOR_WIDETAG
] = size_vector
;
2444 sizetab
[SIMPLE_ARRAY_NIL_WIDETAG
] = size_vector_nil
;
2445 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2446 size_vector_unsigned_byte_2
;
2447 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2448 size_vector_unsigned_byte_4
;
2449 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2450 size_vector_unsigned_byte_8
;
2451 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2452 size_vector_unsigned_byte_8
;
2453 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2454 size_vector_unsigned_byte_16
;
2455 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2456 size_vector_unsigned_byte_16
;
2457 #if (N_WORD_BITS == 32)
2458 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2459 size_vector_unsigned_byte_32
;
2461 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2462 size_vector_unsigned_byte_32
;
2463 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2464 size_vector_unsigned_byte_32
;
2465 #if (N_WORD_BITS == 64)
2466 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2467 size_vector_unsigned_byte_64
;
2469 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2470 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2471 size_vector_unsigned_byte_64
;
2473 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2474 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2475 size_vector_unsigned_byte_64
;
2477 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2478 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = size_vector_unsigned_byte_8
;
2480 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2481 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2482 size_vector_unsigned_byte_16
;
2484 #if (N_WORD_BITS == 32)
2485 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2486 size_vector_unsigned_byte_32
;
2488 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2489 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2490 size_vector_unsigned_byte_32
;
2492 #if (N_WORD_BITS == 64)
2493 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2494 size_vector_unsigned_byte_64
;
2496 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2497 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2498 size_vector_unsigned_byte_64
;
2500 sizetab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = size_vector_single_float
;
2501 sizetab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = size_vector_double_float
;
2502 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2503 sizetab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = size_vector_long_float
;
2505 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2506 sizetab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2507 size_vector_complex_single_float
;
2509 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2510 sizetab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2511 size_vector_complex_double_float
;
2513 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2514 sizetab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2515 size_vector_complex_long_float
;
2517 sizetab
[COMPLEX_BASE_STRING_WIDETAG
] = size_boxed
;
2518 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2519 sizetab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = size_boxed
;
2521 sizetab
[COMPLEX_VECTOR_NIL_WIDETAG
] = size_boxed
;
2522 sizetab
[COMPLEX_BIT_VECTOR_WIDETAG
] = size_boxed
;
2523 sizetab
[COMPLEX_VECTOR_WIDETAG
] = size_boxed
;
2524 sizetab
[COMPLEX_ARRAY_WIDETAG
] = size_boxed
;
2525 sizetab
[CODE_HEADER_WIDETAG
] = size_code_header
;
2527 /* We shouldn't see these, so just lose if it happens. */
2528 sizetab
[SIMPLE_FUN_HEADER_WIDETAG
] = size_function_header
;
2529 sizetab
[RETURN_PC_HEADER_WIDETAG
] = size_return_pc_header
;
2531 sizetab
[CLOSURE_HEADER_WIDETAG
] = size_boxed
;
2532 sizetab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = size_boxed
;
2533 sizetab
[VALUE_CELL_HEADER_WIDETAG
] = size_boxed
;
2534 sizetab
[SYMBOL_HEADER_WIDETAG
] = size_tiny_boxed
;
2535 sizetab
[CHARACTER_WIDETAG
] = size_immediate
;
2536 sizetab
[SAP_WIDETAG
] = size_unboxed
;
2537 #ifdef SIMD_PACK_WIDETAG
2538 sizetab
[SIMD_PACK_WIDETAG
] = size_unboxed
;
2540 sizetab
[UNBOUND_MARKER_WIDETAG
] = size_immediate
;
2541 sizetab
[NO_TLS_VALUE_MARKER_WIDETAG
] = size_immediate
;
2542 sizetab
[WEAK_POINTER_WIDETAG
] = size_weak_pointer
;
2543 sizetab
[INSTANCE_HEADER_WIDETAG
] = size_instance
;
2544 sizetab
[FDEFN_WIDETAG
] = size_tiny_boxed
;
2548 /* Find the code object for the given pc, or return NULL on
2551 component_ptr_from_pc(lispobj
*pc
)
2553 lispobj
*object
= NULL
;
2555 if ( (object
= search_read_only_space(pc
)) )
2557 else if ( (object
= search_static_space(pc
)) )
2559 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2560 else if ( (object
= search_immobile_space(pc
)) )
2564 object
= search_dynamic_space(pc
);
2566 if (object
) /* if we found something */
2567 if (widetag_of(*object
) == CODE_HEADER_WIDETAG
)
2573 /* Scan an area looking for an object which encloses the given pointer.
2574 * Return the object start on success or NULL on failure. */
2576 gc_search_space(lispobj
*start
, size_t words
, lispobj
*pointer
)
2580 lispobj
*forwarded_start
;
2582 if (forwarding_pointer_p(start
))
2584 native_pointer((lispobj
)forwarding_pointer_value(start
));
2586 forwarded_start
= start
;
2587 lispobj thing
= *forwarded_start
;
2588 /* If thing is an immediate then this is a cons. */
2589 if (is_lisp_pointer(thing
) || is_lisp_immediate(thing
))
2592 count
= (sizetab
[widetag_of(thing
)])(forwarded_start
);
2594 /* Check whether the pointer is within this object. */
2595 if ((pointer
>= start
) && (pointer
< (start
+count
))) {
2597 /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2601 /* Round up the count. */
2602 count
= CEILING(count
,2);
2610 /* Helper for valid_lisp_pointer_p (below) and
2611 * possibly_valid_dynamic_space_pointer (gencgc).
2613 * pointer is the pointer to validate, and start_addr is the address
2614 * of the enclosing object.
2617 looks_like_valid_lisp_pointer_p(lispobj pointer
, lispobj
*start_addr
)
2619 if (!is_lisp_pointer(pointer
)) {
2623 /* Check that the object pointed to is consistent with the pointer
2625 switch (lowtag_of(pointer
)) {
2626 case FUN_POINTER_LOWTAG
:
2627 /* Start_addr should be the enclosing code object, or a closure
2629 switch (widetag_of(*start_addr
)) {
2630 case CODE_HEADER_WIDETAG
:
2631 /* Make sure we actually point to a function in the code object,
2632 * as opposed to a random point there. */
2633 if (SIMPLE_FUN_HEADER_WIDETAG
==widetag_of(native_pointer(pointer
)[0]))
2637 case CLOSURE_HEADER_WIDETAG
:
2638 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2639 if (pointer
!= make_lispobj(start_addr
, FUN_POINTER_LOWTAG
)) {
2647 case LIST_POINTER_LOWTAG
:
2648 if (pointer
!= make_lispobj(start_addr
, LIST_POINTER_LOWTAG
)) {
2651 /* Is it plausible cons? */
2652 if ((is_lisp_pointer(start_addr
[0]) ||
2653 is_lisp_immediate(start_addr
[0])) &&
2654 (is_lisp_pointer(start_addr
[1]) ||
2655 is_lisp_immediate(start_addr
[1])))
2660 case INSTANCE_POINTER_LOWTAG
:
2661 if (pointer
!= make_lispobj(start_addr
, INSTANCE_POINTER_LOWTAG
)) {
2664 if (widetag_of(start_addr
[0]) != INSTANCE_HEADER_WIDETAG
) {
2668 case OTHER_POINTER_LOWTAG
:
2670 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2671 /* The all-architecture test below is good as far as it goes,
2672 * but an LRA object is similar to a FUN-POINTER: It is
2673 * embedded within a CODE-OBJECT pointed to by start_addr, and
2674 * cannot be found by simply walking the heap, therefore we
2675 * need to check for it. -- AB, 2010-Jun-04 */
2676 if ((widetag_of(start_addr
[0]) == CODE_HEADER_WIDETAG
)) {
2677 lispobj
*potential_lra
= native_pointer(pointer
);
2678 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
2679 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
2680 return 1; /* It's as good as we can verify. */
2685 if (pointer
!= make_lispobj(start_addr
, OTHER_POINTER_LOWTAG
)) {
2688 /* Is it plausible? Not a cons. XXX should check the headers. */
2689 if (is_lisp_pointer(start_addr
[0]) || ((start_addr
[0] & 3) == 0)) {
2692 switch (widetag_of(start_addr
[0])) {
2693 case UNBOUND_MARKER_WIDETAG
:
2694 case NO_TLS_VALUE_MARKER_WIDETAG
:
2695 case CHARACTER_WIDETAG
:
2696 #if N_WORD_BITS == 64
2697 case SINGLE_FLOAT_WIDETAG
:
2701 /* only pointed to by function pointers? */
2702 case CLOSURE_HEADER_WIDETAG
:
2703 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2706 case INSTANCE_HEADER_WIDETAG
:
2709 /* the valid other immediate pointer objects */
2710 case SIMPLE_VECTOR_WIDETAG
:
2712 case COMPLEX_WIDETAG
:
2713 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2714 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
2716 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2717 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2719 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2720 case COMPLEX_LONG_FLOAT_WIDETAG
:
2722 #ifdef SIMD_PACK_WIDETAG
2723 case SIMD_PACK_WIDETAG
:
2725 case SIMPLE_ARRAY_WIDETAG
:
2726 case COMPLEX_BASE_STRING_WIDETAG
:
2727 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2728 case COMPLEX_CHARACTER_STRING_WIDETAG
:
2730 case COMPLEX_VECTOR_NIL_WIDETAG
:
2731 case COMPLEX_BIT_VECTOR_WIDETAG
:
2732 case COMPLEX_VECTOR_WIDETAG
:
2733 case COMPLEX_ARRAY_WIDETAG
:
2734 case VALUE_CELL_HEADER_WIDETAG
:
2735 case SYMBOL_HEADER_WIDETAG
:
2737 case CODE_HEADER_WIDETAG
:
2738 case BIGNUM_WIDETAG
:
2739 #if N_WORD_BITS != 64
2740 case SINGLE_FLOAT_WIDETAG
:
2742 case DOUBLE_FLOAT_WIDETAG
:
2743 #ifdef LONG_FLOAT_WIDETAG
2744 case LONG_FLOAT_WIDETAG
:
2746 case SIMPLE_BASE_STRING_WIDETAG
:
2747 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2748 case SIMPLE_CHARACTER_STRING_WIDETAG
:
2750 case SIMPLE_BIT_VECTOR_WIDETAG
:
2751 case SIMPLE_ARRAY_NIL_WIDETAG
:
2752 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
2753 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
2754 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
2755 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
2756 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
2757 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
2759 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
2761 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
2762 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
2763 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2764 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
2766 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2767 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
2769 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2770 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
2772 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2773 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
2776 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
2778 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2779 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
2781 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2782 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
2784 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
2785 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
2786 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2787 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
2789 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2790 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
2792 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2793 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2795 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2796 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
2799 case WEAK_POINTER_WIDETAG
:
2814 /* META: Note the ambiguous word "validate" in the comment below.
2815 * This means "Decide whether <x> is valid".
2816 * But when you see os_validate() elsewhere, that doesn't mean to ask
2817 * whether something is valid, it says to *make* it valid.
2818 * I think it would be nice if we could avoid using the word in the
2819 * sense in which os_validate() uses it, which would entail renaming
2820 * a bunch of stuff, which is harder than just explaining why
2821 * the comments can be deceptive */
2823 /* Used by the debugger to validate possibly bogus pointers before
2824 * calling MAKE-LISP-OBJ on them.
2826 * FIXME: We would like to make this perfect, because if the debugger
2827 * constructs a reference to a bugs lisp object, and it ends up in a
2828 * location scavenged by the GC all hell breaks loose.
2830 * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2831 * and return true for all valid pointers, this could actually be eager
2832 * and lie about a few pointers without bad results... but that should
2833 * be reflected in the name.
2836 valid_lisp_pointer_p(lispobj
*pointer
)
2839 if (((start
=search_dynamic_space(pointer
))!=NULL
) ||
2840 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2841 ((start
=search_immobile_space(pointer
))!=NULL
) ||
2843 ((start
=search_static_space(pointer
))!=NULL
) ||
2844 ((start
=search_read_only_space(pointer
))!=NULL
))
2845 return looks_like_valid_lisp_pointer_p((lispobj
)pointer
, start
);
2851 maybe_gc(os_context_t
*context
)
2853 lispobj gc_happened
;
2854 struct thread
*thread
= arch_os_get_current_thread();
2855 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
2858 fake_foreign_function_call(context
);
2861 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2862 * which case we will be running with no gc trigger barrier
2863 * thing for a while. But it shouldn't be long until the end
2866 * FIXME: It would be good to protect the end of dynamic space for
2867 * CheneyGC and signal a storage condition from there.
2870 /* Restore the signal mask from the interrupted context before
2871 * calling into Lisp if interrupts are enabled. Why not always?
2873 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2874 * interrupt hits while in SUB-GC, it is deferred and the
2875 * os_context_sigmask of that interrupt is set to block further
2876 * deferrable interrupts (until the first one is
2877 * handled). Unfortunately, that context refers to this place and
2878 * when we return from here the signals will not be blocked.
2880 * A kludgy alternative is to propagate the sigmask change to the
2883 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2884 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
2885 unblock_gc_signals(0, 0);
2887 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
2888 /* FIXME: Nothing must go wrong during GC else we end up running
2889 * the debugger, error handlers, and user code in general in a
2890 * potentially unsafe place. Running out of the control stack or
2891 * the heap in SUB-GC are ways to lose. Of course, deferrables
2892 * cannot be unblocked because there may be a pending handler, or
2893 * we may even be in a WITHOUT-INTERRUPTS. */
2894 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
2895 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
2896 (gc_happened
== NIL
)
2898 : ((gc_happened
== T
)
2901 /* gc_happened can take three values: T, NIL, 0.
2903 * T means that the thread managed to trigger a GC, and post-gc
2906 * NIL means that the thread is within without-gcing, and no GC
2909 * Finally, 0 means that *a* GC has occurred, but it wasn't
2910 * triggered by this thread; success, but post-gc doesn't have
2913 if ((gc_happened
== T
) &&
2914 /* See if interrupts are enabled or it's possible to enable
2915 * them. POST-GC has a similar check, but we don't want to
2916 * unlock deferrables in that case and get a pending interrupt
2918 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
2919 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
2920 #ifndef LISP_FEATURE_WIN32
2921 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
2922 if (!deferrables_blocked_p(context_sigmask
)) {
2923 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
2924 #ifndef LISP_FEATURE_SB_SAFEPOINT
2925 check_gc_signals_unblocked_or_lose(0);
2928 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
2929 funcall0(StaticSymbolFunction(POST_GC
));
2930 #ifndef LISP_FEATURE_WIN32
2932 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
2938 undo_fake_foreign_function_call(context
);
2940 /* Otherwise done by undo_fake_foreign_function_call. And
2941 something later wants them to be blocked. What a nice
2943 block_blockable_signals(0);
2946 FSHOW((stderr
, "/maybe_gc: returning\n"));
2947 return (gc_happened
!= NIL
);
2950 #define BYTES_ZERO_BEFORE_END (1<<12)
2952 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2953 * Lisp and another called zero_stack() in cheneygc.c, but since it's
2954 * shorter to express in, and more often called from C, I keep only
2955 * the C one after fixing it. -- MG 2009-03-25 */
2957 /* Zero the unused portion of the control stack so that old objects
2958 * are not kept alive because of uninitialized stack variables.
2960 * "To summarize the problem, since not all allocated stack frame
2961 * slots are guaranteed to be written by the time you call an another
2962 * function or GC, there may be garbage pointers retained in your dead
2963 * stack locations. The stack scrubbing only affects the part of the
2964 * stack from the SP to the end of the allocated stack." - ram, on
2965 * cmucl-imp, Tue, 25 Sep 2001
2967 * So, as an (admittedly lame) workaround, from time to time we call
2968 * scrub-control-stack to zero out all the unused portion. This is
2969 * supposed to happen when the stack is mostly empty, so that we have
2970 * a chance of clearing more of it: callers are currently (2002.07.18)
2971 * REPL, SUB-GC and sig_stop_for_gc_handler. */
2973 /* Take care not to tread on the guard page and the hard guard page as
2974 * it would be unkind to sig_stop_for_gc_handler. Touching the return
2975 * guard page is not dangerous. For this to work the guard page must
2976 * be zeroed when protected. */
2978 /* FIXME: I think there is no guarantee that once
2979 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2980 * may be what the "lame" adjective in the above comment is for. In
2981 * this case, exact gc may lose badly. */
2983 scrub_control_stack()
2985 scrub_thread_control_stack(arch_os_get_current_thread());
2989 scrub_thread_control_stack(struct thread
*th
)
2991 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
2992 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
2993 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2994 /* On these targets scrubbing from C is a bad idea, so we punt to
2995 * a routine in $ARCH-assem.S. */
2996 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
2997 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
2999 lispobj
*sp
= access_control_stack_pointer(th
);
3001 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
3002 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
3003 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
3004 ((os_vm_address_t
)sp
>= guard_page_address
) &&
3005 (th
->control_stack_guard_page_protected
!= NIL
)))
3007 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
3010 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
3011 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
3016 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
3020 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
3021 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
3026 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
3028 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
3031 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
3034 scavenge_control_stack(struct thread
*th
)
3036 lispobj
*object_ptr
;
3038 /* In order to properly support dynamic-extent allocation of
3039 * non-CONS objects, the control stack requires special handling.
3040 * Rather than calling scavenge() directly, grovel over it fixing
3041 * broken hearts, scavenging pointers to oldspace, and pitching a
3042 * fit when encountering unboxed data. This prevents stray object
3043 * headers from causing the scavenger to blow past the end of the
3044 * stack (an error case checked in scavenge()). We don't worry
3045 * about treating unboxed words as boxed or vice versa, because
3046 * the compiler isn't allowed to store unboxed objects on the
3047 * control stack. -- AB, 2011-Dec-02 */
3049 for (object_ptr
= th
->control_stack_start
;
3050 object_ptr
< access_control_stack_pointer(th
);
3053 lispobj object
= *object_ptr
;
3054 #ifdef LISP_FEATURE_GENCGC
3055 if (forwarding_pointer_p(object_ptr
))
3056 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
3057 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
3059 if (is_lisp_pointer(object
) && from_space_p(object
)) {
3060 /* It currently points to old space. Check for a
3061 * forwarding pointer. */
3062 lispobj
*ptr
= native_pointer(object
);
3063 if (forwarding_pointer_p(ptr
)) {
3064 /* Yes, there's a forwarding pointer. */
3065 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
3067 /* Scavenge that pointer. */
3068 long n_words_scavenged
=
3069 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
3070 gc_assert(n_words_scavenged
== 1);
3072 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
3073 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
3074 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
3079 /* Scavenging Interrupt Contexts */
3081 static int boxed_registers
[] = BOXED_REGISTERS
;
3083 /* The GC has a notion of an "interior pointer" register, an unboxed
3084 * register that typically contains a pointer to inside an object
3085 * referenced by another pointer. The most obvious of these is the
3086 * program counter, although many compiler backends define a "Lisp
3087 * Interior Pointer" register known to the runtime as reg_LIP, and
3088 * various CPU architectures have other registers that also partake of
3089 * the interior-pointer nature. As the code for pairing an interior
3090 * pointer value up with its "base" register, and fixing it up after
3091 * scavenging is complete is horribly repetitive, a few macros paper
3092 * over the monotony. --AB, 2010-Jul-14 */
3094 /* These macros are only ever used over a lexical environment which
3095 * defines a pointer to an os_context_t called context, thus we don't
3096 * bother to pass that context in as a parameter. */
3098 /* Define how to access a given interior pointer. */
3099 #define ACCESS_INTERIOR_POINTER_pc \
3100 *os_context_pc_addr(context)
3101 #define ACCESS_INTERIOR_POINTER_lip \
3102 *os_context_register_addr(context, reg_LIP)
3103 #define ACCESS_INTERIOR_POINTER_lr \
3104 *os_context_lr_addr(context)
3105 #define ACCESS_INTERIOR_POINTER_npc \
3106 *os_context_npc_addr(context)
3107 #define ACCESS_INTERIOR_POINTER_ctr \
3108 *os_context_ctr_addr(context)
3110 #define INTERIOR_POINTER_VARS(name) \
3111 uword_t name##_offset; \
3112 int name##_register_pair
3114 #define PAIR_INTERIOR_POINTER(name) \
3115 pair_interior_pointer(context, \
3116 ACCESS_INTERIOR_POINTER_##name, \
3118 &name##_register_pair)
3120 /* One complexity here is that if a paired register is not found for
3121 * an interior pointer, then that pointer does not get updated.
3122 * Originally, there was some commentary about using an index of -1
3123 * when calling os_context_register_addr() on SPARC referring to the
3124 * program counter, but the real reason is to allow an interior
3125 * pointer register to point to the runtime, read-only space, or
3126 * static space without problems. */
3127 #define FIXUP_INTERIOR_POINTER(name) \
3129 if (name##_register_pair >= 0) { \
3130 ACCESS_INTERIOR_POINTER_##name = \
3131 (*os_context_register_addr(context, \
3132 name##_register_pair) \
3140 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
3141 uword_t
*saved_offset
, int *register_pair
)
3146 * I (RLT) think this is trying to find the boxed register that is
3147 * closest to the LIP address, without going past it. Usually, it's
3148 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
3150 /* 0x7FFFFFFF on 32-bit platforms;
3151 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
3152 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
3153 *register_pair
= -1;
3154 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3159 index
= boxed_registers
[i
];
3160 reg
= *os_context_register_addr(context
, index
);
3162 /* An interior pointer is never relative to a non-pointer
3163 * register (an oversight in the original implementation).
3164 * The simplest argument for why this is true is to consider
3165 * the fixnum that happens by coincide to be the word-index in
3166 * memory of the header for some object plus two. This is
3167 * happenstance would cause the register containing the fixnum
3168 * to be selected as the register_pair if the interior pointer
3169 * is to anywhere after the first two words of the object.
3170 * The fixnum won't be changed during GC, but the object might
3171 * move, thus destroying the interior pointer. --AB,
3174 if (is_lisp_pointer(reg
) &&
3175 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
3176 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
3177 if (offset
< *saved_offset
) {
3178 *saved_offset
= offset
;
3179 *register_pair
= index
;
3186 scavenge_interrupt_context(os_context_t
* context
)
3190 /* FIXME: The various #ifdef noise here is precisely that: noise.
3191 * Is it possible to fold it into the macrology so that we have
3192 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
3193 * compile out for the registers that don't exist on a given
3196 INTERIOR_POINTER_VARS(pc
);
3198 INTERIOR_POINTER_VARS(lip
);
3200 #ifdef ARCH_HAS_LINK_REGISTER
3201 INTERIOR_POINTER_VARS(lr
);
3203 #ifdef ARCH_HAS_NPC_REGISTER
3204 INTERIOR_POINTER_VARS(npc
);
3206 #ifdef LISP_FEATURE_PPC
3207 INTERIOR_POINTER_VARS(ctr
);
3210 PAIR_INTERIOR_POINTER(pc
);
3212 PAIR_INTERIOR_POINTER(lip
);
3214 #ifdef ARCH_HAS_LINK_REGISTER
3215 PAIR_INTERIOR_POINTER(lr
);
3217 #ifdef ARCH_HAS_NPC_REGISTER
3218 PAIR_INTERIOR_POINTER(npc
);
3220 #ifdef LISP_FEATURE_PPC
3221 PAIR_INTERIOR_POINTER(ctr
);
3224 /* Scavenge all boxed registers in the context. */
3225 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3229 index
= boxed_registers
[i
];
3230 foo
= *os_context_register_addr(context
, index
);
3232 *os_context_register_addr(context
, index
) = foo
;
3234 /* this is unlikely to work as intended on bigendian
3235 * 64 bit platforms */
3237 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
3240 /* Now that the scavenging is done, repair the various interior
3242 FIXUP_INTERIOR_POINTER(pc
);
3244 FIXUP_INTERIOR_POINTER(lip
);
3246 #ifdef ARCH_HAS_LINK_REGISTER
3247 FIXUP_INTERIOR_POINTER(lr
);
3249 #ifdef ARCH_HAS_NPC_REGISTER
3250 FIXUP_INTERIOR_POINTER(npc
);
3252 #ifdef LISP_FEATURE_PPC
3253 FIXUP_INTERIOR_POINTER(ctr
);
3258 scavenge_interrupt_contexts(struct thread
*th
)
3261 os_context_t
*context
;
3263 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
3265 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3266 printf("Number of active contexts: %d\n", index
);
3269 for (i
= 0; i
< index
; i
++) {
3270 context
= th
->interrupt_contexts
[i
];
3271 scavenge_interrupt_context(context
);
3274 #endif /* x86oid targets */
3276 // The following accessors, which take a valid native pointer as input
3277 // and return a Lisp string, are designed to be foolproof during GC,
3278 // hence all the forwarding checks.
3280 #if defined(LISP_FEATURE_SB_LDB)
3281 #include "genesis/classoid.h"
3282 struct vector
* symbol_name(lispobj
* sym
)
3284 if (forwarding_pointer_p(sym
))
3285 sym
= native_pointer((lispobj
)forwarding_pointer_value(sym
));
3286 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
3288 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
3289 if (forwarding_pointer_p(name
))
3290 name
= native_pointer((lispobj
)forwarding_pointer_value(name
));
3291 return (struct vector
*)name
;
3293 struct vector
* classoid_name(lispobj
* classoid
)
3295 if (forwarding_pointer_p(classoid
))
3296 classoid
= native_pointer((lispobj
)forwarding_pointer_value(classoid
));
3297 lispobj sym
= ((struct classoid
*)classoid
)->name
;
3298 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
3299 : symbol_name(native_pointer(sym
));
3301 struct vector
* layout_classoid_name(lispobj
* layout
)
3303 if (forwarding_pointer_p(layout
))
3304 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
3305 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
3306 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
3307 : classoid_name(native_pointer(classoid
));
3309 struct vector
* instance_classoid_name(lispobj
* instance
)
3311 if (forwarding_pointer_p(instance
))
3312 instance
= native_pointer((lispobj
)forwarding_pointer_value(instance
));
3313 lispobj layout
= instance_layout(instance
);
3314 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
3315 : layout_classoid_name(native_pointer(layout
));
3317 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
3319 extern void show_lstring(struct vector
*, int, FILE*);
3320 if (forwarding_pointer_p((lispobj
*)string
))
3321 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
3323 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
3324 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
3326 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
3327 show_lstring(string
, quotes
, s
);
3329 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));