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("unexpect 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
);
157 /* It points somewhere other than oldspace. Leave it
162 else if (fixnump(object
)) {
163 /* It's a fixnum: really easy.. */
166 /* It's some sort of header object or another. */
167 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
170 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
171 object_ptr
, start
, end
);
174 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
175 static lispobj
trans_boxed(lispobj object
);
178 scav_fun_pointer(lispobj
*where
, lispobj object
)
180 lispobj
*first_pointer
;
183 gc_assert(is_lisp_pointer(object
));
185 /* Object is a pointer into from_space - not a FP. */
186 first_pointer
= (lispobj
*) native_pointer(object
);
188 /* must transport object -- object may point to either a function
189 * header, a closure function header, or to a closure header. */
191 switch (widetag_of(*first_pointer
)) {
192 case SIMPLE_FUN_HEADER_WIDETAG
:
193 copy
= trans_fun_header(object
);
196 copy
= trans_boxed(object
);
200 if (copy
!= object
) {
201 /* Set forwarding pointer */
202 set_forwarding_pointer(first_pointer
,copy
);
205 gc_assert(is_lisp_pointer(copy
));
206 gc_assert(!from_space_p(copy
));
215 trans_code(struct code
*code
)
217 struct code
*new_code
;
218 lispobj l_code
, l_new_code
;
219 uword_t nheader_words
, ncode_words
, nwords
;
220 uword_t displacement
;
221 lispobj fheaderl
, *prev_pointer
;
223 /* if object has already been transported, just return pointer */
224 if (forwarding_pointer_p((lispobj
*)code
)) {
226 printf("Was already transported\n");
228 return (struct code
*) forwarding_pointer_value
229 ((lispobj
*)((pointer_sized_uint_t
) code
));
232 gc_assert(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
234 /* prepare to transport the code vector */
235 l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
237 ncode_words
= code_instruction_words(code
->code_size
);
238 nheader_words
= code_header_words(code
->header
);
239 nwords
= ncode_words
+ nheader_words
;
240 nwords
= CEILING(nwords
, 2);
242 l_new_code
= copy_code_object(l_code
, nwords
);
243 new_code
= (struct code
*) native_pointer(l_new_code
);
245 #if defined(DEBUG_CODE_GC)
246 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
247 (uword_t
) code
, (uword_t
) new_code
);
248 printf("Code object is %d words long.\n", nwords
);
251 #ifdef LISP_FEATURE_GENCGC
252 if (new_code
== code
)
256 displacement
= l_new_code
- l_code
;
258 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
260 /* set forwarding pointers for all the function headers in the */
261 /* code object. also fix all self pointers */
263 fheaderl
= code
->entry_points
;
264 prev_pointer
= &new_code
->entry_points
;
266 while (fheaderl
!= NIL
) {
267 struct simple_fun
*fheaderp
, *nfheaderp
;
270 fheaderp
= (struct simple_fun
*) native_pointer(fheaderl
);
271 gc_assert(widetag_of(fheaderp
->header
) == SIMPLE_FUN_HEADER_WIDETAG
);
273 /* Calculate the new function pointer and the new */
274 /* function header. */
275 nfheaderl
= fheaderl
+ displacement
;
276 nfheaderp
= (struct simple_fun
*) native_pointer(nfheaderl
);
279 printf("fheaderp->header (at %x) <- %x\n",
280 &(fheaderp
->header
) , nfheaderl
);
282 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
284 /* fix self pointer. */
286 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
287 FUN_RAW_ADDR_OFFSET
+
291 *prev_pointer
= nfheaderl
;
293 fheaderl
= fheaderp
->next
;
294 prev_pointer
= &nfheaderp
->next
;
296 #ifdef LISP_FEATURE_GENCGC
297 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
298 spaces once when all copying is done. */
299 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
300 ncode_words
* sizeof(sword_t
));
304 #ifdef LISP_FEATURE_X86
305 gencgc_apply_code_fixups(code
, new_code
);
312 scav_code_header(lispobj
*where
, lispobj object
)
315 sword_t n_header_words
, n_code_words
, n_words
;
316 lispobj entry_point
; /* tagged pointer to entry point */
317 struct simple_fun
*function_ptr
; /* untagged pointer to entry point */
319 code
= (struct code
*) where
;
320 n_code_words
= code_instruction_words(code
->code_size
);
321 n_header_words
= code_header_words(object
);
322 n_words
= n_code_words
+ n_header_words
;
323 n_words
= CEILING(n_words
, 2);
325 /* Scavenge the boxed section of the code data block. */
326 scavenge(where
+ 1, n_header_words
- 1);
328 /* Scavenge the boxed section of each function object in the
329 * code data block. */
330 for (entry_point
= code
->entry_points
;
332 entry_point
= function_ptr
->next
) {
334 gc_assert_verbose(is_lisp_pointer(entry_point
),
335 "Entry point %lx\n is not a lisp pointer.",
336 (sword_t
)entry_point
);
338 function_ptr
= (struct simple_fun
*) native_pointer(entry_point
);
339 gc_assert(widetag_of(function_ptr
->header
)==SIMPLE_FUN_HEADER_WIDETAG
);
340 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
341 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
348 trans_code_header(lispobj object
)
352 ncode
= trans_code((struct code
*) native_pointer(object
));
353 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
358 size_code_header(lispobj
*where
)
361 sword_t nheader_words
, ncode_words
, nwords
;
363 code
= (struct code
*) where
;
365 ncode_words
= code_instruction_words(code
->code_size
);
366 nheader_words
= code_header_words(code
->header
);
367 nwords
= ncode_words
+ nheader_words
;
368 nwords
= CEILING(nwords
, 2);
373 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
375 scav_return_pc_header(lispobj
*where
, lispobj object
)
377 lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
380 return 0; /* bogus return value to satisfy static type checking */
382 #endif /* LISP_FEATURE_X86 */
385 trans_return_pc_header(lispobj object
)
387 struct simple_fun
*return_pc
;
389 struct code
*code
, *ncode
;
391 return_pc
= (struct simple_fun
*) native_pointer(object
);
392 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
393 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
395 /* Transport the whole code object */
396 code
= (struct code
*) ((uword_t
) return_pc
- offset
);
397 ncode
= trans_code(code
);
399 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
402 /* On the 386, closures hold a pointer to the raw address instead of the
403 * function object, so we can use CALL [$FDEFN+const] to invoke
404 * the function without loading it into a register. Given that code
405 * objects don't move, we don't need to update anything, but we do
406 * have to figure out that the function is still live. */
408 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
410 scav_closure_header(lispobj
*where
, lispobj object
)
412 struct closure
*closure
;
415 closure
= (struct closure
*)where
;
416 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
418 #ifdef LISP_FEATURE_GENCGC
419 /* The function may have moved so update the raw address. But
420 * don't write unnecessarily. */
421 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
422 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
428 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
430 scav_fun_header(lispobj
*where
, lispobj object
)
432 lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
435 return 0; /* bogus return value to satisfy static type checking */
437 #endif /* LISP_FEATURE_X86 */
440 trans_fun_header(lispobj object
)
442 struct simple_fun
*fheader
;
444 struct code
*code
, *ncode
;
446 fheader
= (struct simple_fun
*) native_pointer(object
);
447 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
448 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
450 /* Transport the whole code object */
451 code
= (struct code
*) ((uword_t
) fheader
- offset
);
452 ncode
= trans_code(code
);
454 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
463 trans_instance(lispobj object
)
468 gc_assert(is_lisp_pointer(object
));
470 header
= *((lispobj
*) native_pointer(object
));
471 length
= instance_length(header
) + 1;
472 length
= CEILING(length
, 2);
474 return copy_object(object
, length
);
478 size_instance(lispobj
*where
)
484 length
= instance_length(header
) + 1;
485 length
= CEILING(length
, 2);
491 scav_instance_pointer(lispobj
*where
, lispobj object
)
493 lispobj copy
, *first_pointer
;
495 /* Object is a pointer into from space - not a FP. */
496 copy
= trans_instance(object
);
498 #ifdef LISP_FEATURE_GENCGC
499 gc_assert(copy
!= object
);
502 first_pointer
= (lispobj
*) native_pointer(object
);
503 set_forwarding_pointer(first_pointer
,copy
);
514 static lispobj
trans_list(lispobj object
);
517 scav_list_pointer(lispobj
*where
, lispobj object
)
519 lispobj first
, *first_pointer
;
521 gc_assert(is_lisp_pointer(object
));
523 /* Object is a pointer into from space - not FP. */
524 first_pointer
= (lispobj
*) native_pointer(object
);
526 first
= trans_list(object
);
527 gc_assert(first
!= object
);
529 /* Set forwarding pointer */
530 set_forwarding_pointer(first_pointer
, first
);
532 gc_assert(is_lisp_pointer(first
));
533 gc_assert(!from_space_p(first
));
541 trans_list(lispobj object
)
543 lispobj new_list_pointer
;
544 struct cons
*cons
, *new_cons
;
547 cons
= (struct cons
*) native_pointer(object
);
550 new_cons
= (struct cons
*)
551 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
552 new_cons
->car
= cons
->car
;
553 new_cons
->cdr
= cons
->cdr
; /* updated later */
554 new_list_pointer
= make_lispobj(new_cons
,lowtag_of(object
));
556 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
559 set_forwarding_pointer((lispobj
*)cons
, new_list_pointer
);
561 /* Try to linearize the list in the cdr direction to help reduce
565 struct cons
*cdr_cons
, *new_cdr_cons
;
567 if(lowtag_of(cdr
) != LIST_POINTER_LOWTAG
||
568 !from_space_p(cdr
) ||
569 forwarding_pointer_p((lispobj
*)native_pointer(cdr
)))
572 cdr_cons
= (struct cons
*) native_pointer(cdr
);
575 new_cdr_cons
= (struct cons
*)
576 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
577 new_cdr_cons
->car
= cdr_cons
->car
;
578 new_cdr_cons
->cdr
= cdr_cons
->cdr
;
579 new_cdr
= make_lispobj(new_cdr_cons
, lowtag_of(cdr
));
581 /* Grab the cdr before it is clobbered. */
583 set_forwarding_pointer((lispobj
*)cdr_cons
, new_cdr
);
585 /* Update the cdr of the last cons copied into new space to
586 * keep the newspace scavenge from having to do it. */
587 new_cons
->cdr
= new_cdr
;
589 new_cons
= new_cdr_cons
;
592 return new_list_pointer
;
597 * scavenging and transporting other pointers
601 scav_other_pointer(lispobj
*where
, lispobj object
)
603 lispobj first
, *first_pointer
;
605 gc_assert(is_lisp_pointer(object
));
607 /* Object is a pointer into from space - not FP. */
608 first_pointer
= (lispobj
*) native_pointer(object
);
609 first
= (transother
[widetag_of(*first_pointer
)])(object
);
611 if (first
!= object
) {
612 set_forwarding_pointer(first_pointer
, first
);
613 #ifdef LISP_FEATURE_GENCGC
617 #ifndef LISP_FEATURE_GENCGC
620 gc_assert(is_lisp_pointer(first
));
621 gc_assert(!from_space_p(first
));
627 * immediate, boxed, and unboxed objects
631 size_pointer(lispobj
*where
)
637 scav_immediate(lispobj
*where
, lispobj object
)
643 trans_immediate(lispobj object
)
645 lose("trying to transport an immediate\n");
646 return NIL
; /* bogus return value to satisfy static type checking */
650 size_immediate(lispobj
*where
)
657 scav_boxed(lispobj
*where
, lispobj object
)
662 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
664 /* If the bignum in the layout has another pointer to it (besides the layout)
665 acting as a root, and which is scavenged first, then transporting the
666 bignum causes the layout to see a FP, as would copying an instance whose
667 layout that is. This is a nearly impossible scenario to create organically
668 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
669 except for a few things that would cause it to be pinned anyway,
670 such as it being kept in a local variable during structure manipulation.
671 See 'interleaved-raw.impure.lisp' for a way to trigger this */
672 if (forwarding_pointer_p((lispobj
*)bignum
)) {
673 lispobj
*forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
675 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
676 (void*)bignum
, (void*)forwarded
);
678 bignum
= (struct bignum
*)native_pointer((lispobj
)forwarded
);
681 int len
= HeaderValue(bignum
->header
);
682 int word_index
= index
/ N_WORD_BITS
;
683 int bit_index
= index
% N_WORD_BITS
;
684 if (word_index
>= len
) {
685 // just return 0 since the marking logic does not allow negative bignums
688 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
692 // Helper function for helper function below, since lambda isn't a thing
693 static void instance_scan_range(void* instance_ptr
, int offset
, int nwords
)
695 scavenge((lispobj
*)instance_ptr
+ offset
, nwords
);
698 // Helper function for stepping through the tagged slots of an instance in
699 // scav_instance and verify_space (which, as it happens, is not useful).
701 instance_scan_interleaved(void (*proc
)(lispobj
*, sword_t
),
702 lispobj
*instance_ptr
,
706 struct layout
*layout
= (struct layout
*)layout_obj
;
707 lispobj layout_bitmap
= layout
->bitmap
;
710 /* This code might be made more efficient by run-length-encoding the ranges
711 of words to scan, but probably not by much */
713 ++instance_ptr
; // was supplied as the address of the header word
714 if (fixnump(layout_bitmap
)) {
715 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
716 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
718 proc(instance_ptr
+ index
, 1);
719 } else { /* huge bitmap */
720 struct bignum
* bitmap
;
721 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
722 if (forwarding_pointer_p((lispobj
*)bitmap
))
723 bitmap
= (struct bignum
*)
724 native_pointer((lispobj
)forwarding_pointer_value((lispobj
*)bitmap
));
725 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
726 instance_scan_range
, instance_ptr
);
730 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
731 void (*proc
)(void*, int, int), void* arg
)
733 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
734 int start_word_index
= 0;
736 in_use_marker_t word
;
738 flags
= flags
& BIT_SCAN_CLEAR
;
740 // Rather than bzero'ing we can just clear each nonzero word as it's read,
742 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
745 int skip_bits
, start_bit
, start_position
, run_length
;
747 if (++start_word_index
>= n_bitmap_words
) break;
748 BITMAP_REF(start_word_index
);
752 // On each loop iteration, the lowest 1 bit is a "relative"
753 // bit index, since the word was already shifted. This is 'skip_bits'.
754 // Adding back in the total shift amount gives 'start_bit',
755 // the true absolute index within the current word.
756 // 'start_position' is absolute within the entire bitmap.
757 skip_bits
= ffsl(word
) - 1;
758 start_bit
= skip_bits
+ shift
;
759 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
760 // Compute the number of consecutive 1s in the current word.
762 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
763 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
765 shift
+= skip_bits
+ run_length
;
767 int end_word_index
= ++start_word_index
;
769 if (end_word_index
>= n_bitmap_words
) {
771 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
774 BITMAP_REF(end_word_index
);
778 // end_word_index is the exclusive bound on contiguous
779 // words to include in the range. See if the low bits
780 // from the next word can extend the range.
781 shift
= ffsl(~word
) - 1;
783 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
788 start_word_index
= end_word_index
;
790 proc(arg
, start_position
, run_length
);
796 scav_instance(lispobj
*where
, lispobj header
)
798 // instance_length() is the number of words following the header including
799 // the layout. If this is an even number, it should be made odd so that
800 // scav_instance() always consumes an even number of words in total.
801 sword_t ntotal
= instance_length(header
) | 1;
802 lispobj
* layout
= (lispobj
*)instance_layout(where
);
806 layout
= native_pointer((lispobj
)layout
);
807 if (forwarding_pointer_p(layout
))
808 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
810 if (((struct layout
*)layout
)->bitmap
== make_fixnum(-1))
811 scavenge(where
+1, ntotal
);
813 instance_scan_interleaved(scavenge
, where
, ntotal
, layout
);
819 trans_boxed(lispobj object
)
824 gc_assert(is_lisp_pointer(object
));
826 header
= *((lispobj
*) native_pointer(object
));
827 length
= HeaderValue(header
) + 1;
828 length
= CEILING(length
, 2);
830 return copy_object(object
, length
);
834 size_boxed(lispobj
*where
)
840 length
= HeaderValue(header
) + 1;
841 length
= CEILING(length
, 2);
847 trans_tiny_boxed(lispobj object
)
852 gc_assert(is_lisp_pointer(object
));
854 header
= *((lispobj
*) native_pointer(object
));
855 length
= (HeaderValue(header
) & 0xFF) + 1;
856 length
= CEILING(length
, 2);
858 return copy_object(object
, length
);
862 size_tiny_boxed(lispobj
*where
)
868 length
= (HeaderValue(header
) & 0xFF) + 1;
869 length
= CEILING(length
, 2);
874 /* Note: on the sparc we don't have to do anything special for fdefns, */
875 /* 'cause the raw-addr has a function lowtag. */
876 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
878 scav_fdefn(lispobj
*where
, lispobj object
)
882 fdefn
= (struct fdefn
*)where
;
884 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
885 fdefn->fun, fdefn->raw_addr)); */
887 if ((char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
) == fdefn
->raw_addr
) {
888 scavenge(where
+ 1, sizeof(struct fdefn
)/sizeof(lispobj
) - 1);
890 /* Don't write unnecessarily. */
891 if (fdefn
->raw_addr
!= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
))
892 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
893 /* gc.c has more casts here, which may be relevant or alternatively
894 may be compiler warning defeaters. try
895 fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
897 return sizeof(struct fdefn
) / sizeof(lispobj
);
905 scav_unboxed(lispobj
*where
, lispobj object
)
909 length
= HeaderValue(object
) + 1;
910 length
= CEILING(length
, 2);
916 trans_unboxed(lispobj object
)
922 gc_assert(is_lisp_pointer(object
));
924 header
= *((lispobj
*) native_pointer(object
));
925 length
= HeaderValue(header
) + 1;
926 length
= CEILING(length
, 2);
928 return copy_unboxed_object(object
, length
);
932 size_unboxed(lispobj
*where
)
938 length
= HeaderValue(header
) + 1;
939 length
= CEILING(length
, 2);
945 /* vector-like objects */
947 scav_base_string(lispobj
*where
, lispobj object
)
949 struct vector
*vector
;
950 sword_t length
, nwords
;
952 /* NOTE: Strings contain one more byte of data than the length */
953 /* slot indicates. */
955 vector
= (struct vector
*) where
;
956 length
= fixnum_value(vector
->length
) + 1;
957 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
962 trans_base_string(lispobj object
)
964 struct vector
*vector
;
965 sword_t length
, nwords
;
967 gc_assert(is_lisp_pointer(object
));
969 /* NOTE: A string contains one more byte of data (a terminating
970 * '\0' to help when interfacing with C functions) than indicated
971 * by the length slot. */
973 vector
= (struct vector
*) native_pointer(object
);
974 length
= fixnum_value(vector
->length
) + 1;
975 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
977 return copy_large_unboxed_object(object
, nwords
);
981 size_base_string(lispobj
*where
)
983 struct vector
*vector
;
984 sword_t length
, nwords
;
986 /* NOTE: A string contains one more byte of data (a terminating
987 * '\0' to help when interfacing with C functions) than indicated
988 * by the length slot. */
990 vector
= (struct vector
*) where
;
991 length
= fixnum_value(vector
->length
) + 1;
992 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
997 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
999 scav_character_string(lispobj
*where
, lispobj object
)
1001 struct vector
*vector
;
1004 /* NOTE: Strings contain one more byte of data than the length */
1005 /* slot indicates. */
1007 vector
= (struct vector
*) where
;
1008 length
= fixnum_value(vector
->length
) + 1;
1009 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1014 trans_character_string(lispobj object
)
1016 struct vector
*vector
;
1019 gc_assert(is_lisp_pointer(object
));
1021 /* NOTE: A string contains one more byte of data (a terminating
1022 * '\0' to help when interfacing with C functions) than indicated
1023 * by the length slot. */
1025 vector
= (struct vector
*) native_pointer(object
);
1026 length
= fixnum_value(vector
->length
) + 1;
1027 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1029 return copy_large_unboxed_object(object
, nwords
);
1033 size_character_string(lispobj
*where
)
1035 struct vector
*vector
;
1038 /* NOTE: A string contains one more byte of data (a terminating
1039 * '\0' to help when interfacing with C functions) than indicated
1040 * by the length slot. */
1042 vector
= (struct vector
*) where
;
1043 length
= fixnum_value(vector
->length
) + 1;
1044 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1051 trans_vector(lispobj object
)
1053 struct vector
*vector
;
1054 sword_t length
, nwords
;
1056 gc_assert(is_lisp_pointer(object
));
1058 vector
= (struct vector
*) native_pointer(object
);
1060 length
= fixnum_value(vector
->length
);
1061 nwords
= CEILING(length
+ 2, 2);
1063 return copy_large_object(object
, nwords
);
1067 size_vector(lispobj
*where
)
1069 struct vector
*vector
;
1070 sword_t length
, nwords
;
1072 vector
= (struct vector
*) where
;
1073 length
= fixnum_value(vector
->length
);
1074 nwords
= CEILING(length
+ 2, 2);
1080 scav_vector_nil(lispobj
*where
, lispobj object
)
1086 trans_vector_nil(lispobj object
)
1088 gc_assert(is_lisp_pointer(object
));
1089 return copy_unboxed_object(object
, 2);
1093 size_vector_nil(lispobj
*where
)
1095 /* Just the header word and the length word */
1100 scav_vector_bit(lispobj
*where
, lispobj object
)
1102 struct vector
*vector
;
1103 sword_t length
, nwords
;
1105 vector
= (struct vector
*) where
;
1106 length
= fixnum_value(vector
->length
);
1107 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1113 trans_vector_bit(lispobj object
)
1115 struct vector
*vector
;
1116 sword_t length
, nwords
;
1118 gc_assert(is_lisp_pointer(object
));
1120 vector
= (struct vector
*) native_pointer(object
);
1121 length
= fixnum_value(vector
->length
);
1122 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1124 return copy_large_unboxed_object(object
, nwords
);
1128 size_vector_bit(lispobj
*where
)
1130 struct vector
*vector
;
1131 sword_t length
, nwords
;
1133 vector
= (struct vector
*) where
;
1134 length
= fixnum_value(vector
->length
);
1135 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1141 scav_vector_unsigned_byte_2(lispobj
*where
, lispobj object
)
1143 struct vector
*vector
;
1144 sword_t length
, nwords
;
1146 vector
= (struct vector
*) where
;
1147 length
= fixnum_value(vector
->length
);
1148 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1154 trans_vector_unsigned_byte_2(lispobj object
)
1156 struct vector
*vector
;
1157 sword_t length
, nwords
;
1159 gc_assert(is_lisp_pointer(object
));
1161 vector
= (struct vector
*) native_pointer(object
);
1162 length
= fixnum_value(vector
->length
);
1163 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1165 return copy_large_unboxed_object(object
, nwords
);
1169 size_vector_unsigned_byte_2(lispobj
*where
)
1171 struct vector
*vector
;
1172 sword_t length
, nwords
;
1174 vector
= (struct vector
*) where
;
1175 length
= fixnum_value(vector
->length
);
1176 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1182 scav_vector_unsigned_byte_4(lispobj
*where
, lispobj object
)
1184 struct vector
*vector
;
1185 sword_t length
, nwords
;
1187 vector
= (struct vector
*) where
;
1188 length
= fixnum_value(vector
->length
);
1189 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1195 trans_vector_unsigned_byte_4(lispobj object
)
1197 struct vector
*vector
;
1198 sword_t length
, nwords
;
1200 gc_assert(is_lisp_pointer(object
));
1202 vector
= (struct vector
*) native_pointer(object
);
1203 length
= fixnum_value(vector
->length
);
1204 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1206 return copy_large_unboxed_object(object
, nwords
);
1209 size_vector_unsigned_byte_4(lispobj
*where
)
1211 struct vector
*vector
;
1212 sword_t length
, nwords
;
1214 vector
= (struct vector
*) where
;
1215 length
= fixnum_value(vector
->length
);
1216 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1223 scav_vector_unsigned_byte_8(lispobj
*where
, lispobj object
)
1225 struct vector
*vector
;
1226 sword_t length
, nwords
;
1228 vector
= (struct vector
*) where
;
1229 length
= fixnum_value(vector
->length
);
1230 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1235 /*********************/
1240 trans_vector_unsigned_byte_8(lispobj object
)
1242 struct vector
*vector
;
1243 sword_t length
, nwords
;
1245 gc_assert(is_lisp_pointer(object
));
1247 vector
= (struct vector
*) native_pointer(object
);
1248 length
= fixnum_value(vector
->length
);
1249 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1251 return copy_large_unboxed_object(object
, nwords
);
1255 size_vector_unsigned_byte_8(lispobj
*where
)
1257 struct vector
*vector
;
1258 sword_t length
, nwords
;
1260 vector
= (struct vector
*) where
;
1261 length
= fixnum_value(vector
->length
);
1262 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1269 scav_vector_unsigned_byte_16(lispobj
*where
, lispobj object
)
1271 struct vector
*vector
;
1272 sword_t length
, nwords
;
1274 vector
= (struct vector
*) where
;
1275 length
= fixnum_value(vector
->length
);
1276 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1282 trans_vector_unsigned_byte_16(lispobj object
)
1284 struct vector
*vector
;
1285 sword_t length
, nwords
;
1287 gc_assert(is_lisp_pointer(object
));
1289 vector
= (struct vector
*) native_pointer(object
);
1290 length
= fixnum_value(vector
->length
);
1291 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1293 return copy_large_unboxed_object(object
, nwords
);
1297 size_vector_unsigned_byte_16(lispobj
*where
)
1299 struct vector
*vector
;
1300 sword_t length
, nwords
;
1302 vector
= (struct vector
*) where
;
1303 length
= fixnum_value(vector
->length
);
1304 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1310 scav_vector_unsigned_byte_32(lispobj
*where
, lispobj object
)
1312 struct vector
*vector
;
1313 sword_t length
, nwords
;
1315 vector
= (struct vector
*) where
;
1316 length
= fixnum_value(vector
->length
);
1317 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1323 trans_vector_unsigned_byte_32(lispobj object
)
1325 struct vector
*vector
;
1326 sword_t length
, nwords
;
1328 gc_assert(is_lisp_pointer(object
));
1330 vector
= (struct vector
*) native_pointer(object
);
1331 length
= fixnum_value(vector
->length
);
1332 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1334 return copy_large_unboxed_object(object
, nwords
);
1338 size_vector_unsigned_byte_32(lispobj
*where
)
1340 struct vector
*vector
;
1341 sword_t length
, nwords
;
1343 vector
= (struct vector
*) where
;
1344 length
= fixnum_value(vector
->length
);
1345 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1350 #if N_WORD_BITS == 64
1352 scav_vector_unsigned_byte_64(lispobj
*where
, lispobj object
)
1354 struct vector
*vector
;
1355 sword_t length
, nwords
;
1357 vector
= (struct vector
*) where
;
1358 length
= fixnum_value(vector
->length
);
1359 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1365 trans_vector_unsigned_byte_64(lispobj object
)
1367 struct vector
*vector
;
1368 sword_t length
, nwords
;
1370 gc_assert(is_lisp_pointer(object
));
1372 vector
= (struct vector
*) native_pointer(object
);
1373 length
= fixnum_value(vector
->length
);
1374 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1376 return copy_large_unboxed_object(object
, nwords
);
1380 size_vector_unsigned_byte_64(lispobj
*where
)
1382 struct vector
*vector
;
1383 sword_t length
, nwords
;
1385 vector
= (struct vector
*) where
;
1386 length
= fixnum_value(vector
->length
);
1387 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1394 scav_vector_single_float(lispobj
*where
, lispobj object
)
1396 struct vector
*vector
;
1397 sword_t length
, nwords
;
1399 vector
= (struct vector
*) where
;
1400 length
= fixnum_value(vector
->length
);
1401 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1407 trans_vector_single_float(lispobj object
)
1409 struct vector
*vector
;
1410 sword_t length
, nwords
;
1412 gc_assert(is_lisp_pointer(object
));
1414 vector
= (struct vector
*) native_pointer(object
);
1415 length
= fixnum_value(vector
->length
);
1416 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1418 return copy_large_unboxed_object(object
, nwords
);
1422 size_vector_single_float(lispobj
*where
)
1424 struct vector
*vector
;
1425 sword_t length
, nwords
;
1427 vector
= (struct vector
*) where
;
1428 length
= fixnum_value(vector
->length
);
1429 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1435 scav_vector_double_float(lispobj
*where
, lispobj object
)
1437 struct vector
*vector
;
1438 sword_t length
, nwords
;
1440 vector
= (struct vector
*) where
;
1441 length
= fixnum_value(vector
->length
);
1442 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1448 trans_vector_double_float(lispobj object
)
1450 struct vector
*vector
;
1451 sword_t length
, nwords
;
1453 gc_assert(is_lisp_pointer(object
));
1455 vector
= (struct vector
*) native_pointer(object
);
1456 length
= fixnum_value(vector
->length
);
1457 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1459 return copy_large_unboxed_object(object
, nwords
);
1463 size_vector_double_float(lispobj
*where
)
1465 struct vector
*vector
;
1466 sword_t length
, nwords
;
1468 vector
= (struct vector
*) where
;
1469 length
= fixnum_value(vector
->length
);
1470 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1475 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1477 scav_vector_long_float(lispobj
*where
, lispobj object
)
1479 struct vector
*vector
;
1480 long length
, nwords
;
1482 vector
= (struct vector
*) where
;
1483 length
= fixnum_value(vector
->length
);
1484 nwords
= CEILING(length
*
1491 trans_vector_long_float(lispobj object
)
1493 struct vector
*vector
;
1494 long length
, nwords
;
1496 gc_assert(is_lisp_pointer(object
));
1498 vector
= (struct vector
*) native_pointer(object
);
1499 length
= fixnum_value(vector
->length
);
1500 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1502 return copy_large_unboxed_object(object
, nwords
);
1506 size_vector_long_float(lispobj
*where
)
1508 struct vector
*vector
;
1509 sword_t length
, nwords
;
1511 vector
= (struct vector
*) where
;
1512 length
= fixnum_value(vector
->length
);
1513 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1520 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1522 scav_vector_complex_single_float(lispobj
*where
, lispobj object
)
1524 struct vector
*vector
;
1525 sword_t length
, nwords
;
1527 vector
= (struct vector
*) where
;
1528 length
= fixnum_value(vector
->length
);
1529 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1535 trans_vector_complex_single_float(lispobj object
)
1537 struct vector
*vector
;
1538 sword_t length
, nwords
;
1540 gc_assert(is_lisp_pointer(object
));
1542 vector
= (struct vector
*) native_pointer(object
);
1543 length
= fixnum_value(vector
->length
);
1544 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1546 return copy_large_unboxed_object(object
, nwords
);
1550 size_vector_complex_single_float(lispobj
*where
)
1552 struct vector
*vector
;
1553 sword_t length
, nwords
;
1555 vector
= (struct vector
*) where
;
1556 length
= fixnum_value(vector
->length
);
1557 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1563 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1565 scav_vector_complex_double_float(lispobj
*where
, lispobj object
)
1567 struct vector
*vector
;
1568 sword_t length
, nwords
;
1570 vector
= (struct vector
*) where
;
1571 length
= fixnum_value(vector
->length
);
1572 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1578 trans_vector_complex_double_float(lispobj object
)
1580 struct vector
*vector
;
1581 sword_t length
, nwords
;
1583 gc_assert(is_lisp_pointer(object
));
1585 vector
= (struct vector
*) native_pointer(object
);
1586 length
= fixnum_value(vector
->length
);
1587 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1589 return copy_large_unboxed_object(object
, nwords
);
1593 size_vector_complex_double_float(lispobj
*where
)
1595 struct vector
*vector
;
1596 sword_t length
, nwords
;
1598 vector
= (struct vector
*) where
;
1599 length
= fixnum_value(vector
->length
);
1600 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1607 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1609 scav_vector_complex_long_float(lispobj
*where
, lispobj object
)
1611 struct vector
*vector
;
1612 sword_t length
, nwords
;
1614 vector
= (struct vector
*) where
;
1615 length
= fixnum_value(vector
->length
);
1616 nwords
= CEILING(length
* (2* LONG_FLOAT_SIZE
) + 2, 2);
1622 trans_vector_complex_long_float(lispobj object
)
1624 struct vector
*vector
;
1625 long length
, nwords
;
1627 gc_assert(is_lisp_pointer(object
));
1629 vector
= (struct vector
*) native_pointer(object
);
1630 length
= fixnum_value(vector
->length
);
1631 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1633 return copy_large_unboxed_object(object
, nwords
);
1637 size_vector_complex_long_float(lispobj
*where
)
1639 struct vector
*vector
;
1640 long length
, nwords
;
1642 vector
= (struct vector
*) where
;
1643 length
= fixnum_value(vector
->length
);
1644 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1650 #define WEAK_POINTER_NWORDS \
1651 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1654 trans_weak_pointer(lispobj object
)
1657 #ifndef LISP_FEATURE_GENCGC
1658 struct weak_pointer
*wp
;
1660 gc_assert(is_lisp_pointer(object
));
1662 #if defined(DEBUG_WEAK)
1663 printf("Transporting weak pointer from 0x%08x\n", object
);
1666 /* Need to remember where all the weak pointers are that have */
1667 /* been transported so they can be fixed up in a post-GC pass. */
1669 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
1670 #ifndef LISP_FEATURE_GENCGC
1671 wp
= (struct weak_pointer
*) native_pointer(copy
);
1673 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1674 /* Push the weak pointer onto the list of weak pointers. */
1675 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
1682 size_weak_pointer(lispobj
*where
)
1684 return WEAK_POINTER_NWORDS
;
1688 void scan_weak_pointers(void)
1690 struct weak_pointer
*wp
, *next_wp
;
1691 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
1692 lispobj value
= wp
->value
;
1693 lispobj
*first_pointer
;
1694 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1698 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
1701 if (!(is_lisp_pointer(value
) && from_space_p(value
)))
1704 /* Now, we need to check whether the object has been forwarded. If
1705 * it has been, the weak pointer is still good and needs to be
1706 * updated. Otherwise, the weak pointer needs to be nil'ed
1709 first_pointer
= (lispobj
*)native_pointer(value
);
1711 if (forwarding_pointer_p(first_pointer
)) {
1713 (lispobj
)LOW_WORD(forwarding_pointer_value(first_pointer
));
1725 #if N_WORD_BITS == 32
1726 #define EQ_HASH_MASK 0x1fffffff
1727 #elif N_WORD_BITS == 64
1728 #define EQ_HASH_MASK 0x1fffffffffffffff
1731 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1732 * target-hash-table.lisp. */
1733 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1735 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1736 * slot. Set to NULL at the end of a collection.
1738 * This is not optimal because, when a table is tenured, it won't be
1739 * processed automatically; only the yougest generation is GC'd by
1740 * default. On the other hand, all applications will need an
1741 * occasional full GC anyway, so it's not that bad either. */
1742 struct hash_table
*weak_hash_tables
= NULL
;
1744 /* Return true if OBJ has already survived the current GC. */
1746 survived_gc_yet (lispobj obj
)
1748 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1749 forwarding_pointer_p(native_pointer(obj
)));
1753 weak_hash_entry_alivep (lispobj weakness
, lispobj key
, lispobj value
)
1757 return survived_gc_yet(key
);
1759 return survived_gc_yet(value
);
1761 return (survived_gc_yet(key
) || survived_gc_yet(value
));
1763 return (survived_gc_yet(key
) && survived_gc_yet(value
));
1766 /* Shut compiler up. */
1771 /* Return the beginning of data in ARRAY (skipping the header and the
1772 * length) or NULL if it isn't an array of the specified widetag after
1774 static inline lispobj
*
1775 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1777 if (is_lisp_pointer(array
) &&
1778 (widetag_of(*(lispobj
*)native_pointer(array
)) == widetag
)) {
1780 *length
= fixnum_value(((lispobj
*)native_pointer(array
))[1]);
1781 return ((lispobj
*)native_pointer(array
)) + 2;
1787 /* Only need to worry about scavenging the _real_ entries in the
1788 * table. Phantom entries such as the hash table itself at index 0 and
1789 * the empty marker at index 1 were scavenged by scav_vector that
1790 * either called this function directly or arranged for it to be
1791 * called later by pushing the hash table onto weak_hash_tables. */
1793 scav_hash_table_entries (struct hash_table
*hash_table
)
1797 lispobj
*index_vector
;
1799 lispobj
*next_vector
;
1800 uword_t next_vector_length
;
1801 lispobj
*hash_vector
;
1802 uword_t hash_vector_length
;
1803 lispobj empty_symbol
;
1804 lispobj weakness
= hash_table
->weakness
;
1807 kv_vector
= get_array_data(hash_table
->table
,
1808 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1809 if (kv_vector
== NULL
)
1810 lose("invalid kv_vector %x\n", hash_table
->table
);
1812 index_vector
= get_array_data(hash_table
->index_vector
,
1813 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1814 if (index_vector
== NULL
)
1815 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1817 next_vector
= get_array_data(hash_table
->next_vector
,
1818 SIMPLE_ARRAY_WORD_WIDETAG
,
1819 &next_vector_length
);
1820 if (next_vector
== NULL
)
1821 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1823 hash_vector
= get_array_data(hash_table
->hash_vector
,
1824 SIMPLE_ARRAY_WORD_WIDETAG
,
1825 &hash_vector_length
);
1826 if (hash_vector
!= NULL
)
1827 gc_assert(hash_vector_length
== next_vector_length
);
1829 /* These lengths could be different as the index_vector can be a
1830 * different length from the others, a larger index_vector could
1831 * help reduce collisions. */
1832 gc_assert(next_vector_length
*2 == kv_length
);
1834 empty_symbol
= kv_vector
[1];
1835 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1836 if (widetag_of(*(lispobj
*)native_pointer(empty_symbol
)) !=
1837 SYMBOL_HEADER_WIDETAG
) {
1838 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1839 *(lispobj
*)native_pointer(empty_symbol
));
1842 /* Work through the KV vector. */
1843 for (i
= 1; i
< next_vector_length
; i
++) {
1844 lispobj old_key
= kv_vector
[2*i
];
1845 lispobj value
= kv_vector
[2*i
+1];
1846 if ((weakness
== NIL
) ||
1847 weak_hash_entry_alivep(weakness
, old_key
, value
)) {
1849 /* Scavenge the key and value. */
1850 scavenge(&kv_vector
[2*i
],2);
1852 /* If an EQ-based key has moved, mark the hash-table for
1854 if (!hash_vector
|| hash_vector
[i
] == MAGIC_HASH_VECTOR_VALUE
) {
1855 lispobj new_key
= kv_vector
[2*i
];
1856 // FIXME: many EQ-based sxhash values are insensitive
1857 // to object movement. The most important one is SYMBOL,
1858 // but others also carry around a hash value: LAYOUT, CLASSOID,
1859 // and STANDARD-[FUNCALLABLE-]INSTANCE.
1860 // If old_key is any of those, don't set needs_rehash_p.
1861 if (old_key
!= new_key
&& new_key
!= empty_symbol
) {
1862 hash_table
->needs_rehash_p
= T
;
1870 scav_vector (lispobj
*where
, lispobj object
)
1873 struct hash_table
*hash_table
;
1875 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1876 * hash tables in the Lisp HASH-TABLE code to indicate need for
1877 * special GC support. */
1878 if (HeaderValue(object
) == subtype_VectorNormal
)
1881 kv_length
= fixnum_value(where
[1]);
1882 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1884 /* Scavenge element 0, which may be a hash-table structure. */
1885 scavenge(where
+2, 1);
1886 if (!is_lisp_pointer(where
[2])) {
1887 /* This'll happen when REHASH clears the header of old-kv-vector
1888 * and fills it with zero, but some other thread simulatenously
1889 * sets the header in %%PUTHASH.
1892 "Warning: no pointer at %p in hash table: this indicates "
1893 "non-fatal corruption caused by concurrent access to a "
1894 "hash-table from multiple threads. Any accesses to "
1895 "hash-tables shared between threads should be protected "
1896 "by locks.\n", (void*)&where
[2]);
1897 // We've scavenged three words.
1900 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1901 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1902 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1903 lose("hash table not instance (%x at %x)\n",
1908 /* Scavenge element 1, which should be some internal symbol that
1909 * the hash table code reserves for marking empty slots. */
1910 scavenge(where
+3, 1);
1911 if (!is_lisp_pointer(where
[3])) {
1912 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1915 /* Scavenge hash table, which will fix the positions of the other
1916 * needed objects. */
1917 scavenge((lispobj
*)hash_table
,
1918 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1920 /* Cross-check the kv_vector. */
1921 if (where
!= (lispobj
*)native_pointer(hash_table
->table
)) {
1922 lose("hash_table table!=this table %x\n", hash_table
->table
);
1925 if (hash_table
->weakness
== NIL
) {
1926 scav_hash_table_entries(hash_table
);
1928 /* Delay scavenging of this table by pushing it onto
1929 * weak_hash_tables (if it's not there already) for the weak
1931 if (hash_table
->next_weak_hash_table
== NIL
) {
1932 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1933 weak_hash_tables
= hash_table
;
1937 return (CEILING(kv_length
+ 2, 2));
1941 scav_weak_hash_tables (void)
1943 struct hash_table
*table
;
1945 /* Scavenge entries whose triggers are known to survive. */
1946 for (table
= weak_hash_tables
; table
!= NULL
;
1947 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1948 scav_hash_table_entries(table
);
1952 /* Walk through the chain whose first element is *FIRST and remove
1953 * dead weak entries. */
1955 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1956 lispobj
*kv_vector
, lispobj
*index_vector
,
1957 lispobj
*next_vector
, lispobj
*hash_vector
,
1958 lispobj empty_symbol
, lispobj weakness
)
1960 unsigned index
= *prev
;
1962 unsigned next
= next_vector
[index
];
1963 lispobj key
= kv_vector
[2 * index
];
1964 lispobj value
= kv_vector
[2 * index
+ 1];
1965 gc_assert(key
!= empty_symbol
);
1966 gc_assert(value
!= empty_symbol
);
1967 if (!weak_hash_entry_alivep(weakness
, key
, value
)) {
1968 unsigned count
= fixnum_value(hash_table
->number_entries
);
1969 gc_assert(count
> 0);
1971 hash_table
->number_entries
= make_fixnum(count
- 1);
1972 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1973 hash_table
->next_free_kv
= make_fixnum(index
);
1974 kv_vector
[2 * index
] = empty_symbol
;
1975 kv_vector
[2 * index
+ 1] = empty_symbol
;
1977 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1979 prev
= &next_vector
[index
];
1986 scan_weak_hash_table (struct hash_table
*hash_table
)
1989 lispobj
*index_vector
;
1990 uword_t length
= 0; /* prevent warning */
1991 lispobj
*next_vector
;
1992 uword_t next_vector_length
= 0; /* prevent warning */
1993 lispobj
*hash_vector
;
1994 lispobj empty_symbol
;
1995 lispobj weakness
= hash_table
->weakness
;
1998 kv_vector
= get_array_data(hash_table
->table
,
1999 SIMPLE_VECTOR_WIDETAG
, NULL
);
2000 index_vector
= get_array_data(hash_table
->index_vector
,
2001 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
2002 next_vector
= get_array_data(hash_table
->next_vector
,
2003 SIMPLE_ARRAY_WORD_WIDETAG
,
2004 &next_vector_length
);
2005 hash_vector
= get_array_data(hash_table
->hash_vector
,
2006 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
2007 empty_symbol
= kv_vector
[1];
2009 for (i
= 0; i
< length
; i
++) {
2010 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
2011 kv_vector
, index_vector
, next_vector
,
2012 hash_vector
, empty_symbol
, weakness
);
2016 /* Remove dead entries from weak hash tables. */
2018 scan_weak_hash_tables (void)
2020 struct hash_table
*table
, *next
;
2022 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
2023 next
= (struct hash_table
*)table
->next_weak_hash_table
;
2024 table
->next_weak_hash_table
= NIL
;
2025 scan_weak_hash_table(table
);
2028 weak_hash_tables
= NULL
;
2037 scav_lose(lispobj
*where
, lispobj object
)
2039 lose("no scavenge function for object %p (widetag 0x%x)\n",
2041 widetag_of(*where
));
2043 return 0; /* bogus return value to satisfy static type checking */
2047 trans_lose(lispobj object
)
2049 lose("no transport function for object %p (widetag 0x%x)\n",
2051 widetag_of(*(lispobj
*)native_pointer(object
)));
2052 return NIL
; /* bogus return value to satisfy static type checking */
2056 size_lose(lispobj
*where
)
2058 lose("no size function for object at %p (widetag 0x%x)\n",
2060 widetag_of(*where
));
2061 return 1; /* bogus return value to satisfy static type checking */
2070 gc_init_tables(void)
2074 /* Set default value in all slots of scavenge table. FIXME
2075 * replace this gnarly sizeof with something based on
2077 for (i
= 0; i
< ((sizeof scavtab
)/(sizeof scavtab
[0])); i
++) {
2078 scavtab
[i
] = scav_lose
;
2081 /* For each type which can be selected by the lowtag alone, set
2082 * multiple entries in our widetag scavenge table (one for each
2083 * possible value of the high bits).
2086 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2087 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2089 scavtab
[j
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
2092 scavtab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_fun_pointer
;
2093 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2094 scavtab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_list_pointer
;
2095 scavtab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] =
2096 scav_instance_pointer
;
2097 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2098 scavtab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_other_pointer
;
2101 /* Other-pointer types (those selected by all eight bits of the
2102 * tag) get one entry each in the scavenge table. */
2103 scavtab
[BIGNUM_WIDETAG
] = scav_unboxed
;
2104 scavtab
[RATIO_WIDETAG
] = scav_boxed
;
2105 #if N_WORD_BITS == 64
2106 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_immediate
;
2108 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2110 scavtab
[DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2111 #ifdef LONG_FLOAT_WIDETAG
2112 scavtab
[LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2114 scavtab
[COMPLEX_WIDETAG
] = scav_boxed
;
2115 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2116 scavtab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2118 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2119 scavtab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2121 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2122 scavtab
[COMPLEX_LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2124 #ifdef SIMD_PACK_WIDETAG
2125 scavtab
[SIMD_PACK_WIDETAG
] = scav_unboxed
;
2127 scavtab
[SIMPLE_ARRAY_WIDETAG
] = scav_boxed
;
2128 scavtab
[SIMPLE_BASE_STRING_WIDETAG
] = scav_base_string
;
2129 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2130 scavtab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = scav_character_string
;
2132 scavtab
[SIMPLE_BIT_VECTOR_WIDETAG
] = scav_vector_bit
;
2133 scavtab
[SIMPLE_ARRAY_NIL_WIDETAG
] = scav_vector_nil
;
2134 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2135 scav_vector_unsigned_byte_2
;
2136 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2137 scav_vector_unsigned_byte_4
;
2138 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2139 scav_vector_unsigned_byte_8
;
2140 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2141 scav_vector_unsigned_byte_8
;
2142 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2143 scav_vector_unsigned_byte_16
;
2144 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2145 scav_vector_unsigned_byte_16
;
2146 #if (N_WORD_BITS == 32)
2147 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2148 scav_vector_unsigned_byte_32
;
2150 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2151 scav_vector_unsigned_byte_32
;
2152 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2153 scav_vector_unsigned_byte_32
;
2154 #if (N_WORD_BITS == 64)
2155 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2156 scav_vector_unsigned_byte_64
;
2158 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2159 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2160 scav_vector_unsigned_byte_64
;
2162 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2163 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2164 scav_vector_unsigned_byte_64
;
2166 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2167 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = scav_vector_unsigned_byte_8
;
2169 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2170 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2171 scav_vector_unsigned_byte_16
;
2173 #if (N_WORD_BITS == 32)
2174 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2175 scav_vector_unsigned_byte_32
;
2177 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2178 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2179 scav_vector_unsigned_byte_32
;
2181 #if (N_WORD_BITS == 64)
2182 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2183 scav_vector_unsigned_byte_64
;
2185 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2186 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2187 scav_vector_unsigned_byte_64
;
2189 scavtab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = scav_vector_single_float
;
2190 scavtab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = scav_vector_double_float
;
2191 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2192 scavtab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = scav_vector_long_float
;
2194 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2195 scavtab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2196 scav_vector_complex_single_float
;
2198 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2199 scavtab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2200 scav_vector_complex_double_float
;
2202 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2203 scavtab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2204 scav_vector_complex_long_float
;
2206 scavtab
[COMPLEX_BASE_STRING_WIDETAG
] = scav_boxed
;
2207 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2208 scavtab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = scav_boxed
;
2210 scavtab
[COMPLEX_VECTOR_NIL_WIDETAG
] = scav_boxed
;
2211 scavtab
[COMPLEX_BIT_VECTOR_WIDETAG
] = scav_boxed
;
2212 scavtab
[COMPLEX_VECTOR_WIDETAG
] = scav_boxed
;
2213 scavtab
[COMPLEX_ARRAY_WIDETAG
] = scav_boxed
;
2214 scavtab
[CODE_HEADER_WIDETAG
] = scav_code_header
;
2215 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2216 scavtab
[SIMPLE_FUN_HEADER_WIDETAG
] = scav_fun_header
;
2217 scavtab
[RETURN_PC_HEADER_WIDETAG
] = scav_return_pc_header
;
2219 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_boxed
;
2220 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2221 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_closure_header
;
2223 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_boxed
;
2225 scavtab
[VALUE_CELL_HEADER_WIDETAG
] = scav_boxed
;
2226 scavtab
[SYMBOL_HEADER_WIDETAG
] = scav_boxed
;
2227 scavtab
[CHARACTER_WIDETAG
] = scav_immediate
;
2228 scavtab
[SAP_WIDETAG
] = scav_unboxed
;
2229 scavtab
[UNBOUND_MARKER_WIDETAG
] = scav_immediate
;
2230 scavtab
[NO_TLS_VALUE_MARKER_WIDETAG
] = scav_immediate
;
2231 scavtab
[INSTANCE_HEADER_WIDETAG
] = scav_instance
;
2232 #if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
2233 scavtab
[FDEFN_WIDETAG
] = scav_boxed
;
2235 scavtab
[FDEFN_WIDETAG
] = scav_fdefn
;
2237 scavtab
[SIMPLE_VECTOR_WIDETAG
] = scav_vector
;
2239 /* transport other table, initialized same way as scavtab */
2240 for (i
= 0; i
< ((sizeof transother
)/(sizeof transother
[0])); i
++)
2241 transother
[i
] = trans_lose
;
2242 transother
[BIGNUM_WIDETAG
] = trans_unboxed
;
2243 transother
[RATIO_WIDETAG
] = trans_boxed
;
2245 #if N_WORD_BITS == 64
2246 transother
[SINGLE_FLOAT_WIDETAG
] = trans_immediate
;
2248 transother
[SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2250 transother
[DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2251 #ifdef LONG_FLOAT_WIDETAG
2252 transother
[LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2254 transother
[COMPLEX_WIDETAG
] = trans_boxed
;
2255 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2256 transother
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2258 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2259 transother
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2261 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2262 transother
[COMPLEX_LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2264 transother
[SIMPLE_ARRAY_WIDETAG
] = trans_boxed
; /* but not GENCGC */
2265 transother
[SIMPLE_BASE_STRING_WIDETAG
] = trans_base_string
;
2266 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2267 transother
[SIMPLE_CHARACTER_STRING_WIDETAG
] = trans_character_string
;
2269 transother
[SIMPLE_BIT_VECTOR_WIDETAG
] = trans_vector_bit
;
2270 transother
[SIMPLE_VECTOR_WIDETAG
] = trans_vector
;
2271 transother
[SIMPLE_ARRAY_NIL_WIDETAG
] = trans_vector_nil
;
2272 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2273 trans_vector_unsigned_byte_2
;
2274 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2275 trans_vector_unsigned_byte_4
;
2276 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2277 trans_vector_unsigned_byte_8
;
2278 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2279 trans_vector_unsigned_byte_8
;
2280 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2281 trans_vector_unsigned_byte_16
;
2282 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2283 trans_vector_unsigned_byte_16
;
2284 #if (N_WORD_BITS == 32)
2285 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2286 trans_vector_unsigned_byte_32
;
2288 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2289 trans_vector_unsigned_byte_32
;
2290 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2291 trans_vector_unsigned_byte_32
;
2292 #if (N_WORD_BITS == 64)
2293 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2294 trans_vector_unsigned_byte_64
;
2296 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2297 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2298 trans_vector_unsigned_byte_64
;
2300 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2301 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2302 trans_vector_unsigned_byte_64
;
2304 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2305 transother
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] =
2306 trans_vector_unsigned_byte_8
;
2308 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2309 transother
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2310 trans_vector_unsigned_byte_16
;
2312 #if (N_WORD_BITS == 32)
2313 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2314 trans_vector_unsigned_byte_32
;
2316 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2317 transother
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2318 trans_vector_unsigned_byte_32
;
2320 #if (N_WORD_BITS == 64)
2321 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2322 trans_vector_unsigned_byte_64
;
2324 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2325 transother
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2326 trans_vector_unsigned_byte_64
;
2328 transother
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] =
2329 trans_vector_single_float
;
2330 transother
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] =
2331 trans_vector_double_float
;
2332 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2333 transother
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] =
2334 trans_vector_long_float
;
2336 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2337 transother
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2338 trans_vector_complex_single_float
;
2340 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2341 transother
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2342 trans_vector_complex_double_float
;
2344 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2345 transother
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2346 trans_vector_complex_long_float
;
2348 transother
[COMPLEX_BASE_STRING_WIDETAG
] = trans_boxed
;
2349 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2350 transother
[COMPLEX_CHARACTER_STRING_WIDETAG
] = trans_boxed
;
2352 transother
[COMPLEX_BIT_VECTOR_WIDETAG
] = trans_boxed
;
2353 transother
[COMPLEX_VECTOR_NIL_WIDETAG
] = trans_boxed
;
2354 transother
[COMPLEX_VECTOR_WIDETAG
] = trans_boxed
;
2355 transother
[COMPLEX_ARRAY_WIDETAG
] = trans_boxed
;
2356 transother
[CODE_HEADER_WIDETAG
] = trans_code_header
;
2357 transother
[SIMPLE_FUN_HEADER_WIDETAG
] = trans_fun_header
;
2358 transother
[RETURN_PC_HEADER_WIDETAG
] = trans_return_pc_header
;
2359 transother
[CLOSURE_HEADER_WIDETAG
] = trans_boxed
;
2360 transother
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = trans_boxed
;
2361 transother
[VALUE_CELL_HEADER_WIDETAG
] = trans_boxed
;
2362 transother
[SYMBOL_HEADER_WIDETAG
] = trans_tiny_boxed
;
2363 transother
[CHARACTER_WIDETAG
] = trans_immediate
;
2364 transother
[SAP_WIDETAG
] = trans_unboxed
;
2365 #ifdef SIMD_PACK_WIDETAG
2366 transother
[SIMD_PACK_WIDETAG
] = trans_unboxed
;
2368 transother
[UNBOUND_MARKER_WIDETAG
] = trans_immediate
;
2369 transother
[NO_TLS_VALUE_MARKER_WIDETAG
] = trans_immediate
;
2370 transother
[WEAK_POINTER_WIDETAG
] = trans_weak_pointer
;
2371 transother
[INSTANCE_HEADER_WIDETAG
] = trans_instance
;
2372 transother
[FDEFN_WIDETAG
] = trans_boxed
;
2374 /* size table, initialized the same way as scavtab */
2375 for (i
= 0; i
< ((sizeof sizetab
)/(sizeof sizetab
[0])); i
++)
2376 sizetab
[i
] = size_lose
;
2377 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2378 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2380 sizetab
[j
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
2383 sizetab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2384 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2385 sizetab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2386 sizetab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2387 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2388 sizetab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2390 sizetab
[BIGNUM_WIDETAG
] = size_unboxed
;
2391 sizetab
[RATIO_WIDETAG
] = size_boxed
;
2392 #if N_WORD_BITS == 64
2393 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_immediate
;
2395 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2397 sizetab
[DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2398 #ifdef LONG_FLOAT_WIDETAG
2399 sizetab
[LONG_FLOAT_WIDETAG
] = size_unboxed
;
2401 sizetab
[COMPLEX_WIDETAG
] = size_boxed
;
2402 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2403 sizetab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2405 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2406 sizetab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2408 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2409 sizetab
[COMPLEX_LONG_FLOAT_WIDETAG
] = size_unboxed
;
2411 sizetab
[SIMPLE_ARRAY_WIDETAG
] = size_boxed
;
2412 sizetab
[SIMPLE_BASE_STRING_WIDETAG
] = size_base_string
;
2413 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2414 sizetab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = size_character_string
;
2416 sizetab
[SIMPLE_BIT_VECTOR_WIDETAG
] = size_vector_bit
;
2417 sizetab
[SIMPLE_VECTOR_WIDETAG
] = size_vector
;
2418 sizetab
[SIMPLE_ARRAY_NIL_WIDETAG
] = size_vector_nil
;
2419 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2420 size_vector_unsigned_byte_2
;
2421 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2422 size_vector_unsigned_byte_4
;
2423 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2424 size_vector_unsigned_byte_8
;
2425 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2426 size_vector_unsigned_byte_8
;
2427 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2428 size_vector_unsigned_byte_16
;
2429 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2430 size_vector_unsigned_byte_16
;
2431 #if (N_WORD_BITS == 32)
2432 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2433 size_vector_unsigned_byte_32
;
2435 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2436 size_vector_unsigned_byte_32
;
2437 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2438 size_vector_unsigned_byte_32
;
2439 #if (N_WORD_BITS == 64)
2440 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2441 size_vector_unsigned_byte_64
;
2443 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2444 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2445 size_vector_unsigned_byte_64
;
2447 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2448 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2449 size_vector_unsigned_byte_64
;
2451 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2452 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = size_vector_unsigned_byte_8
;
2454 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2455 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2456 size_vector_unsigned_byte_16
;
2458 #if (N_WORD_BITS == 32)
2459 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2460 size_vector_unsigned_byte_32
;
2462 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2463 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2464 size_vector_unsigned_byte_32
;
2466 #if (N_WORD_BITS == 64)
2467 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2468 size_vector_unsigned_byte_64
;
2470 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2471 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2472 size_vector_unsigned_byte_64
;
2474 sizetab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = size_vector_single_float
;
2475 sizetab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = size_vector_double_float
;
2476 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2477 sizetab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = size_vector_long_float
;
2479 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2480 sizetab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2481 size_vector_complex_single_float
;
2483 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2484 sizetab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2485 size_vector_complex_double_float
;
2487 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2488 sizetab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2489 size_vector_complex_long_float
;
2491 sizetab
[COMPLEX_BASE_STRING_WIDETAG
] = size_boxed
;
2492 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2493 sizetab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = size_boxed
;
2495 sizetab
[COMPLEX_VECTOR_NIL_WIDETAG
] = size_boxed
;
2496 sizetab
[COMPLEX_BIT_VECTOR_WIDETAG
] = size_boxed
;
2497 sizetab
[COMPLEX_VECTOR_WIDETAG
] = size_boxed
;
2498 sizetab
[COMPLEX_ARRAY_WIDETAG
] = size_boxed
;
2499 sizetab
[CODE_HEADER_WIDETAG
] = size_code_header
;
2501 /* We shouldn't see these, so just lose if it happens. */
2502 sizetab
[SIMPLE_FUN_HEADER_WIDETAG
] = size_function_header
;
2503 sizetab
[RETURN_PC_HEADER_WIDETAG
] = size_return_pc_header
;
2505 sizetab
[CLOSURE_HEADER_WIDETAG
] = size_boxed
;
2506 sizetab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = size_boxed
;
2507 sizetab
[VALUE_CELL_HEADER_WIDETAG
] = size_boxed
;
2508 sizetab
[SYMBOL_HEADER_WIDETAG
] = size_tiny_boxed
;
2509 sizetab
[CHARACTER_WIDETAG
] = size_immediate
;
2510 sizetab
[SAP_WIDETAG
] = size_unboxed
;
2511 #ifdef SIMD_PACK_WIDETAG
2512 sizetab
[SIMD_PACK_WIDETAG
] = size_unboxed
;
2514 sizetab
[UNBOUND_MARKER_WIDETAG
] = size_immediate
;
2515 sizetab
[NO_TLS_VALUE_MARKER_WIDETAG
] = size_immediate
;
2516 sizetab
[WEAK_POINTER_WIDETAG
] = size_weak_pointer
;
2517 sizetab
[INSTANCE_HEADER_WIDETAG
] = size_instance
;
2518 sizetab
[FDEFN_WIDETAG
] = size_boxed
;
2522 /* Find the code object for the given pc, or return NULL on
2525 component_ptr_from_pc(lispobj
*pc
)
2527 lispobj
*object
= NULL
;
2529 if ( (object
= search_read_only_space(pc
)) )
2531 else if ( (object
= search_static_space(pc
)) )
2534 object
= search_dynamic_space(pc
);
2536 if (object
) /* if we found something */
2537 if (widetag_of(*object
) == CODE_HEADER_WIDETAG
)
2543 /* Scan an area looking for an object which encloses the given pointer.
2544 * Return the object start on success or NULL on failure. */
2546 gc_search_space(lispobj
*start
, size_t words
, lispobj
*pointer
)
2550 lispobj
*forwarded_start
;
2552 if (forwarding_pointer_p(start
))
2554 native_pointer((lispobj
)forwarding_pointer_value(start
));
2556 forwarded_start
= start
;
2557 lispobj thing
= *forwarded_start
;
2558 /* If thing is an immediate then this is a cons. */
2559 if (is_lisp_pointer(thing
) || is_lisp_immediate(thing
))
2562 count
= (sizetab
[widetag_of(thing
)])(forwarded_start
);
2564 /* Check whether the pointer is within this object. */
2565 if ((pointer
>= start
) && (pointer
< (start
+count
))) {
2567 /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2571 /* Round up the count. */
2572 count
= CEILING(count
,2);
2580 /* Helper for valid_lisp_pointer_p (below) and
2581 * possibly_valid_dynamic_space_pointer (gencgc).
2583 * pointer is the pointer to validate, and start_addr is the address
2584 * of the enclosing object.
2587 looks_like_valid_lisp_pointer_p(lispobj pointer
, lispobj
*start_addr
)
2589 if (!is_lisp_pointer(pointer
)) {
2593 /* Check that the object pointed to is consistent with the pointer
2595 switch (lowtag_of(pointer
)) {
2596 case FUN_POINTER_LOWTAG
:
2597 /* Start_addr should be the enclosing code object, or a closure
2599 switch (widetag_of(*start_addr
)) {
2600 case CODE_HEADER_WIDETAG
:
2601 /* Make sure we actually point to a function in the code object,
2602 * as opposed to a random point there. */
2603 if (SIMPLE_FUN_HEADER_WIDETAG
==widetag_of(native_pointer(pointer
)[0]))
2607 case CLOSURE_HEADER_WIDETAG
:
2608 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2609 if (pointer
!= make_lispobj(start_addr
, FUN_POINTER_LOWTAG
)) {
2617 case LIST_POINTER_LOWTAG
:
2618 if (pointer
!= make_lispobj(start_addr
, LIST_POINTER_LOWTAG
)) {
2621 /* Is it plausible cons? */
2622 if ((is_lisp_pointer(start_addr
[0]) ||
2623 is_lisp_immediate(start_addr
[0])) &&
2624 (is_lisp_pointer(start_addr
[1]) ||
2625 is_lisp_immediate(start_addr
[1])))
2630 case INSTANCE_POINTER_LOWTAG
:
2631 if (pointer
!= make_lispobj(start_addr
, INSTANCE_POINTER_LOWTAG
)) {
2634 if (widetag_of(start_addr
[0]) != INSTANCE_HEADER_WIDETAG
) {
2638 case OTHER_POINTER_LOWTAG
:
2640 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2641 /* The all-architecture test below is good as far as it goes,
2642 * but an LRA object is similar to a FUN-POINTER: It is
2643 * embedded within a CODE-OBJECT pointed to by start_addr, and
2644 * cannot be found by simply walking the heap, therefore we
2645 * need to check for it. -- AB, 2010-Jun-04 */
2646 if ((widetag_of(start_addr
[0]) == CODE_HEADER_WIDETAG
)) {
2647 lispobj
*potential_lra
= native_pointer(pointer
);
2648 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
2649 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
2650 return 1; /* It's as good as we can verify. */
2655 if (pointer
!= make_lispobj(start_addr
, OTHER_POINTER_LOWTAG
)) {
2658 /* Is it plausible? Not a cons. XXX should check the headers. */
2659 if (is_lisp_pointer(start_addr
[0]) || ((start_addr
[0] & 3) == 0)) {
2662 switch (widetag_of(start_addr
[0])) {
2663 case UNBOUND_MARKER_WIDETAG
:
2664 case NO_TLS_VALUE_MARKER_WIDETAG
:
2665 case CHARACTER_WIDETAG
:
2666 #if N_WORD_BITS == 64
2667 case SINGLE_FLOAT_WIDETAG
:
2671 /* only pointed to by function pointers? */
2672 case CLOSURE_HEADER_WIDETAG
:
2673 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2676 case INSTANCE_HEADER_WIDETAG
:
2679 /* the valid other immediate pointer objects */
2680 case SIMPLE_VECTOR_WIDETAG
:
2682 case COMPLEX_WIDETAG
:
2683 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2684 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
2686 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2687 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2689 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2690 case COMPLEX_LONG_FLOAT_WIDETAG
:
2692 #ifdef SIMD_PACK_WIDETAG
2693 case SIMD_PACK_WIDETAG
:
2695 case SIMPLE_ARRAY_WIDETAG
:
2696 case COMPLEX_BASE_STRING_WIDETAG
:
2697 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2698 case COMPLEX_CHARACTER_STRING_WIDETAG
:
2700 case COMPLEX_VECTOR_NIL_WIDETAG
:
2701 case COMPLEX_BIT_VECTOR_WIDETAG
:
2702 case COMPLEX_VECTOR_WIDETAG
:
2703 case COMPLEX_ARRAY_WIDETAG
:
2704 case VALUE_CELL_HEADER_WIDETAG
:
2705 case SYMBOL_HEADER_WIDETAG
:
2707 case CODE_HEADER_WIDETAG
:
2708 case BIGNUM_WIDETAG
:
2709 #if N_WORD_BITS != 64
2710 case SINGLE_FLOAT_WIDETAG
:
2712 case DOUBLE_FLOAT_WIDETAG
:
2713 #ifdef LONG_FLOAT_WIDETAG
2714 case LONG_FLOAT_WIDETAG
:
2716 case SIMPLE_BASE_STRING_WIDETAG
:
2717 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2718 case SIMPLE_CHARACTER_STRING_WIDETAG
:
2720 case SIMPLE_BIT_VECTOR_WIDETAG
:
2721 case SIMPLE_ARRAY_NIL_WIDETAG
:
2722 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
2723 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
2724 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
2725 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
2726 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
2727 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
2729 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
2731 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
2732 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
2733 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2734 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
2736 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2737 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
2739 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2740 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
2742 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2743 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
2746 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
2748 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2749 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
2751 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2752 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
2754 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
2755 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
2756 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2757 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
2759 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2760 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
2762 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2763 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2765 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2766 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
2769 case WEAK_POINTER_WIDETAG
:
2784 /* META: Note the ambiguous word "validate" in the comment below.
2785 * This means "Decide whether <x> is valid".
2786 * But when you see os_validate() elsewhere, that doesn't mean to ask
2787 * whether something is valid, it says to *make* it valid.
2788 * I think it would be nice if we could avoid using the word in the
2789 * sense in which os_validate() uses it, which would entail renaming
2790 * a bunch of stuff, which is harder than just explaining why
2791 * the comments can be deceptive */
2793 /* Used by the debugger to validate possibly bogus pointers before
2794 * calling MAKE-LISP-OBJ on them.
2796 * FIXME: We would like to make this perfect, because if the debugger
2797 * constructs a reference to a bugs lisp object, and it ends up in a
2798 * location scavenged by the GC all hell breaks loose.
2800 * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2801 * and return true for all valid pointers, this could actually be eager
2802 * and lie about a few pointers without bad results... but that should
2803 * be reflected in the name.
2806 valid_lisp_pointer_p(lispobj
*pointer
)
2809 if (((start
=search_dynamic_space(pointer
))!=NULL
) ||
2810 ((start
=search_static_space(pointer
))!=NULL
) ||
2811 ((start
=search_read_only_space(pointer
))!=NULL
))
2812 return looks_like_valid_lisp_pointer_p((lispobj
)pointer
, start
);
2818 maybe_gc(os_context_t
*context
)
2820 lispobj gc_happened
;
2821 struct thread
*thread
= arch_os_get_current_thread();
2822 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
2825 fake_foreign_function_call(context
);
2828 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2829 * which case we will be running with no gc trigger barrier
2830 * thing for a while. But it shouldn't be long until the end
2833 * FIXME: It would be good to protect the end of dynamic space for
2834 * CheneyGC and signal a storage condition from there.
2837 /* Restore the signal mask from the interrupted context before
2838 * calling into Lisp if interrupts are enabled. Why not always?
2840 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2841 * interrupt hits while in SUB-GC, it is deferred and the
2842 * os_context_sigmask of that interrupt is set to block further
2843 * deferrable interrupts (until the first one is
2844 * handled). Unfortunately, that context refers to this place and
2845 * when we return from here the signals will not be blocked.
2847 * A kludgy alternative is to propagate the sigmask change to the
2850 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2851 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
2852 unblock_gc_signals(0, 0);
2854 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
2855 /* FIXME: Nothing must go wrong during GC else we end up running
2856 * the debugger, error handlers, and user code in general in a
2857 * potentially unsafe place. Running out of the control stack or
2858 * the heap in SUB-GC are ways to lose. Of course, deferrables
2859 * cannot be unblocked because there may be a pending handler, or
2860 * we may even be in a WITHOUT-INTERRUPTS. */
2861 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
2862 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
2863 (gc_happened
== NIL
)
2865 : ((gc_happened
== T
)
2868 /* gc_happened can take three values: T, NIL, 0.
2870 * T means that the thread managed to trigger a GC, and post-gc
2873 * NIL means that the thread is within without-gcing, and no GC
2876 * Finally, 0 means that *a* GC has occurred, but it wasn't
2877 * triggered by this thread; success, but post-gc doesn't have
2880 if ((gc_happened
== T
) &&
2881 /* See if interrupts are enabled or it's possible to enable
2882 * them. POST-GC has a similar check, but we don't want to
2883 * unlock deferrables in that case and get a pending interrupt
2885 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
2886 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
2887 #ifndef LISP_FEATURE_WIN32
2888 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
2889 if (!deferrables_blocked_p(context_sigmask
)) {
2890 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
2891 #ifndef LISP_FEATURE_SB_SAFEPOINT
2892 check_gc_signals_unblocked_or_lose(0);
2895 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
2896 funcall0(StaticSymbolFunction(POST_GC
));
2897 #ifndef LISP_FEATURE_WIN32
2899 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
2905 undo_fake_foreign_function_call(context
);
2907 /* Otherwise done by undo_fake_foreign_function_call. And
2908 something later wants them to be blocked. What a nice
2910 block_blockable_signals(0);
2913 FSHOW((stderr
, "/maybe_gc: returning\n"));
2914 return (gc_happened
!= NIL
);
2917 #define BYTES_ZERO_BEFORE_END (1<<12)
2919 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2920 * Lisp and another called zero_stack() in cheneygc.c, but since it's
2921 * shorter to express in, and more often called from C, I keep only
2922 * the C one after fixing it. -- MG 2009-03-25 */
2924 /* Zero the unused portion of the control stack so that old objects
2925 * are not kept alive because of uninitialized stack variables.
2927 * "To summarize the problem, since not all allocated stack frame
2928 * slots are guaranteed to be written by the time you call an another
2929 * function or GC, there may be garbage pointers retained in your dead
2930 * stack locations. The stack scrubbing only affects the part of the
2931 * stack from the SP to the end of the allocated stack." - ram, on
2932 * cmucl-imp, Tue, 25 Sep 2001
2934 * So, as an (admittedly lame) workaround, from time to time we call
2935 * scrub-control-stack to zero out all the unused portion. This is
2936 * supposed to happen when the stack is mostly empty, so that we have
2937 * a chance of clearing more of it: callers are currently (2002.07.18)
2938 * REPL, SUB-GC and sig_stop_for_gc_handler. */
2940 /* Take care not to tread on the guard page and the hard guard page as
2941 * it would be unkind to sig_stop_for_gc_handler. Touching the return
2942 * guard page is not dangerous. For this to work the guard page must
2943 * be zeroed when protected. */
2945 /* FIXME: I think there is no guarantee that once
2946 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2947 * may be what the "lame" adjective in the above comment is for. In
2948 * this case, exact gc may lose badly. */
2950 scrub_control_stack()
2952 scrub_thread_control_stack(arch_os_get_current_thread());
2956 scrub_thread_control_stack(struct thread
*th
)
2958 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
2959 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
2960 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2961 /* On these targets scrubbing from C is a bad idea, so we punt to
2962 * a routine in $ARCH-assem.S. */
2963 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
2964 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
2966 lispobj
*sp
= access_control_stack_pointer(th
);
2968 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
2969 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
2970 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
2971 ((os_vm_address_t
)sp
>= guard_page_address
) &&
2972 (th
->control_stack_guard_page_protected
!= NIL
)))
2974 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2977 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
2978 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
2983 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
2987 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
2988 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
2993 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
2995 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2998 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
3001 scavenge_control_stack(struct thread
*th
)
3003 lispobj
*object_ptr
;
3005 /* In order to properly support dynamic-extent allocation of
3006 * non-CONS objects, the control stack requires special handling.
3007 * Rather than calling scavenge() directly, grovel over it fixing
3008 * broken hearts, scavenging pointers to oldspace, and pitching a
3009 * fit when encountering unboxed data. This prevents stray object
3010 * headers from causing the scavenger to blow past the end of the
3011 * stack (an error case checked in scavenge()). We don't worry
3012 * about treating unboxed words as boxed or vice versa, because
3013 * the compiler isn't allowed to store unboxed objects on the
3014 * control stack. -- AB, 2011-Dec-02 */
3016 for (object_ptr
= th
->control_stack_start
;
3017 object_ptr
< access_control_stack_pointer(th
);
3020 lispobj object
= *object_ptr
;
3021 #ifdef LISP_FEATURE_GENCGC
3022 if (forwarding_pointer_p(object_ptr
))
3023 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
3024 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
3026 if (is_lisp_pointer(object
) && from_space_p(object
)) {
3027 /* It currently points to old space. Check for a
3028 * forwarding pointer. */
3029 lispobj
*ptr
= native_pointer(object
);
3030 if (forwarding_pointer_p(ptr
)) {
3031 /* Yes, there's a forwarding pointer. */
3032 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
3034 /* Scavenge that pointer. */
3035 long n_words_scavenged
=
3036 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
3037 gc_assert(n_words_scavenged
== 1);
3039 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
3040 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
3041 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
3046 /* Scavenging Interrupt Contexts */
3048 static int boxed_registers
[] = BOXED_REGISTERS
;
3050 /* The GC has a notion of an "interior pointer" register, an unboxed
3051 * register that typically contains a pointer to inside an object
3052 * referenced by another pointer. The most obvious of these is the
3053 * program counter, although many compiler backends define a "Lisp
3054 * Interior Pointer" register known to the runtime as reg_LIP, and
3055 * various CPU architectures have other registers that also partake of
3056 * the interior-pointer nature. As the code for pairing an interior
3057 * pointer value up with its "base" register, and fixing it up after
3058 * scavenging is complete is horribly repetitive, a few macros paper
3059 * over the monotony. --AB, 2010-Jul-14 */
3061 /* These macros are only ever used over a lexical environment which
3062 * defines a pointer to an os_context_t called context, thus we don't
3063 * bother to pass that context in as a parameter. */
3065 /* Define how to access a given interior pointer. */
3066 #define ACCESS_INTERIOR_POINTER_pc \
3067 *os_context_pc_addr(context)
3068 #define ACCESS_INTERIOR_POINTER_lip \
3069 *os_context_register_addr(context, reg_LIP)
3070 #define ACCESS_INTERIOR_POINTER_lr \
3071 *os_context_lr_addr(context)
3072 #define ACCESS_INTERIOR_POINTER_npc \
3073 *os_context_npc_addr(context)
3074 #define ACCESS_INTERIOR_POINTER_ctr \
3075 *os_context_ctr_addr(context)
3077 #define INTERIOR_POINTER_VARS(name) \
3078 uword_t name##_offset; \
3079 int name##_register_pair
3081 #define PAIR_INTERIOR_POINTER(name) \
3082 pair_interior_pointer(context, \
3083 ACCESS_INTERIOR_POINTER_##name, \
3085 &name##_register_pair)
3087 /* One complexity here is that if a paired register is not found for
3088 * an interior pointer, then that pointer does not get updated.
3089 * Originally, there was some commentary about using an index of -1
3090 * when calling os_context_register_addr() on SPARC referring to the
3091 * program counter, but the real reason is to allow an interior
3092 * pointer register to point to the runtime, read-only space, or
3093 * static space without problems. */
3094 #define FIXUP_INTERIOR_POINTER(name) \
3096 if (name##_register_pair >= 0) { \
3097 ACCESS_INTERIOR_POINTER_##name = \
3098 (*os_context_register_addr(context, \
3099 name##_register_pair) \
3107 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
3108 uword_t
*saved_offset
, int *register_pair
)
3113 * I (RLT) think this is trying to find the boxed register that is
3114 * closest to the LIP address, without going past it. Usually, it's
3115 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
3117 /* 0x7FFFFFFF on 32-bit platforms;
3118 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
3119 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
3120 *register_pair
= -1;
3121 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3126 index
= boxed_registers
[i
];
3127 reg
= *os_context_register_addr(context
, index
);
3129 /* An interior pointer is never relative to a non-pointer
3130 * register (an oversight in the original implementation).
3131 * The simplest argument for why this is true is to consider
3132 * the fixnum that happens by coincide to be the word-index in
3133 * memory of the header for some object plus two. This is
3134 * happenstance would cause the register containing the fixnum
3135 * to be selected as the register_pair if the interior pointer
3136 * is to anywhere after the first two words of the object.
3137 * The fixnum won't be changed during GC, but the object might
3138 * move, thus destroying the interior pointer. --AB,
3141 if (is_lisp_pointer(reg
) &&
3142 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
3143 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
3144 if (offset
< *saved_offset
) {
3145 *saved_offset
= offset
;
3146 *register_pair
= index
;
3153 scavenge_interrupt_context(os_context_t
* context
)
3157 /* FIXME: The various #ifdef noise here is precisely that: noise.
3158 * Is it possible to fold it into the macrology so that we have
3159 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
3160 * compile out for the registers that don't exist on a given
3163 INTERIOR_POINTER_VARS(pc
);
3165 INTERIOR_POINTER_VARS(lip
);
3167 #ifdef ARCH_HAS_LINK_REGISTER
3168 INTERIOR_POINTER_VARS(lr
);
3170 #ifdef ARCH_HAS_NPC_REGISTER
3171 INTERIOR_POINTER_VARS(npc
);
3173 #ifdef LISP_FEATURE_PPC
3174 INTERIOR_POINTER_VARS(ctr
);
3177 PAIR_INTERIOR_POINTER(pc
);
3179 PAIR_INTERIOR_POINTER(lip
);
3181 #ifdef ARCH_HAS_LINK_REGISTER
3182 PAIR_INTERIOR_POINTER(lr
);
3184 #ifdef ARCH_HAS_NPC_REGISTER
3185 PAIR_INTERIOR_POINTER(npc
);
3187 #ifdef LISP_FEATURE_PPC
3188 PAIR_INTERIOR_POINTER(ctr
);
3191 /* Scavenge all boxed registers in the context. */
3192 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3196 index
= boxed_registers
[i
];
3197 foo
= *os_context_register_addr(context
, index
);
3199 *os_context_register_addr(context
, index
) = foo
;
3201 /* this is unlikely to work as intended on bigendian
3202 * 64 bit platforms */
3204 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
3207 /* Now that the scavenging is done, repair the various interior
3209 FIXUP_INTERIOR_POINTER(pc
);
3211 FIXUP_INTERIOR_POINTER(lip
);
3213 #ifdef ARCH_HAS_LINK_REGISTER
3214 FIXUP_INTERIOR_POINTER(lr
);
3216 #ifdef ARCH_HAS_NPC_REGISTER
3217 FIXUP_INTERIOR_POINTER(npc
);
3219 #ifdef LISP_FEATURE_PPC
3220 FIXUP_INTERIOR_POINTER(ctr
);
3225 scavenge_interrupt_contexts(struct thread
*th
)
3228 os_context_t
*context
;
3230 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
3232 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3233 printf("Number of active contexts: %d\n", index
);
3236 for (i
= 0; i
< index
; i
++) {
3237 context
= th
->interrupt_contexts
[i
];
3238 scavenge_interrupt_context(context
);
3241 #endif /* x86oid targets */
3243 // The following accessors, which take a valid native pointer as input
3244 // and return a Lisp string, are designed to be foolproof during GC,
3245 // hence all the forwarding checks.
3247 #if defined(LISP_FEATURE_SB_LDB)
3248 #include "genesis/classoid.h"
3249 struct vector
* symbol_name(lispobj
* sym
)
3251 if (forwarding_pointer_p(sym
))
3252 sym
= native_pointer((lispobj
)forwarding_pointer_value(sym
));
3253 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
3255 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
3256 if (forwarding_pointer_p(name
))
3257 name
= native_pointer((lispobj
)forwarding_pointer_value(name
));
3258 return (struct vector
*)name
;
3260 struct vector
* classoid_name(lispobj
* classoid
)
3262 if (forwarding_pointer_p(classoid
))
3263 classoid
= native_pointer((lispobj
)forwarding_pointer_value(classoid
));
3264 lispobj sym
= ((struct classoid
*)classoid
)->name
;
3265 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
3266 : symbol_name(native_pointer(sym
));
3268 struct vector
* layout_classoid_name(lispobj
* layout
)
3270 if (forwarding_pointer_p(layout
))
3271 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
3272 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
3273 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
3274 : classoid_name(native_pointer(classoid
));
3276 struct vector
* instance_classoid_name(lispobj
* instance
)
3278 if (forwarding_pointer_p(instance
))
3279 instance
= native_pointer((lispobj
)forwarding_pointer_value(instance
));
3280 lispobj layout
= instance_layout(instance
);
3281 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
3282 : layout_classoid_name(native_pointer(layout
));
3284 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
3286 extern void show_lstring(struct vector
*, int, FILE*);
3287 if (forwarding_pointer_p((lispobj
*)string
))
3288 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
3290 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
3291 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
3293 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
3294 show_lstring(string
, quotes
, s
);
3296 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));