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 // The object at 'pointer' might already have been forwarded,
90 // but that's ok. Such occurs primarily when dealing with
91 // code components, because code can be forwarded by scavenging any
92 // pointer to a function that resides within the code.
93 // Testing whether the object had been forwarded would just slow
94 // things down, so we blindly stomp on whatever was there.
95 // Unfortunately this also implies we can't assert
96 // that we're operating on a not-yet-forwarded object here.
97 #ifdef LISP_FEATURE_GENCGC
99 pointer
[1]=newspace_copy
;
101 pointer
[0]=newspace_copy
;
103 return newspace_copy
;
106 sword_t (*scavtab
[256])(lispobj
*where
, lispobj object
);
107 lispobj (*transother
[256])(lispobj object
);
108 sword_t (*sizetab
[256])(lispobj
*where
);
109 struct weak_pointer
*weak_pointers
;
111 os_vm_size_t bytes_consed_between_gcs
= 12*1024*1024;
117 /* gc_general_copy_object is inline from gc-internal.h */
119 /* to copy a boxed object */
121 copy_object(lispobj object
, sword_t nwords
)
123 return gc_general_copy_object(object
, nwords
, BOXED_PAGE_FLAG
);
127 copy_code_object(lispobj object
, sword_t nwords
)
129 return gc_general_copy_object(object
, nwords
, CODE_PAGE_FLAG
);
132 static sword_t
scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
134 /* FIXME: Most calls end up going to some trouble to compute an
135 * 'n_words' value for this function. The system might be a little
136 * simpler if this function used an 'end' parameter instead. */
138 scavenge(lispobj
*start
, sword_t n_words
)
140 lispobj
*end
= start
+ n_words
;
143 for (object_ptr
= start
; object_ptr
< end
;) {
144 lispobj object
= *object_ptr
;
145 #ifdef LISP_FEATURE_GENCGC
146 if (forwarding_pointer_p(object_ptr
))
147 lose("unexpected forwarding pointer in scavenge: %p, start=%p, n=%ld\n",
148 object_ptr
, start
, n_words
);
150 if (is_lisp_pointer(object
)) {
151 if (from_space_p(object
)) {
152 /* It currently points to old space. Check for a
153 * forwarding pointer. */
154 lispobj
*ptr
= native_pointer(object
);
155 if (forwarding_pointer_p(ptr
)) {
156 /* Yes, there's a forwarding pointer. */
157 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
160 /* Scavenge that pointer. */
162 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
164 #ifdef LISP_FEATURE_IMMOBILE_SPACE
165 } else if (immobile_space_p(object
)) {
166 lispobj
*ptr
= native_pointer(object
);
167 if (immobile_obj_gen_bits(ptr
) == from_space
)
168 promote_immobile_obj(ptr
, 1);
172 /* It points somewhere other than oldspace. Leave it
177 else if (fixnump(object
)) {
178 /* It's a fixnum: really easy.. */
181 /* It's some sort of header object or another. */
182 object_ptr
+= (scavtab
[widetag_of(object
)])(object_ptr
, object
);
185 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
186 object_ptr
, start
, end
);
189 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
190 static lispobj
trans_boxed(lispobj object
);
193 scav_fun_pointer(lispobj
*where
, lispobj object
)
195 lispobj
*first_pointer
;
198 gc_assert(is_lisp_pointer(object
));
200 /* Object is a pointer into from_space - not a FP. */
201 first_pointer
= (lispobj
*) native_pointer(object
);
203 /* must transport object -- object may point to either a function
204 * header, a closure function header, or to a closure header. */
206 switch (widetag_of(*first_pointer
)) {
207 case SIMPLE_FUN_HEADER_WIDETAG
:
208 copy
= trans_fun_header(object
);
211 copy
= trans_boxed(object
);
215 if (copy
!= object
) {
216 /* Set forwarding pointer */
217 set_forwarding_pointer(first_pointer
,copy
);
220 gc_assert(is_lisp_pointer(copy
));
221 gc_assert(!from_space_p(copy
));
230 trans_code(struct code
*code
)
232 struct code
*new_code
;
233 lispobj l_code
, l_new_code
;
234 uword_t nheader_words
, ncode_words
, nwords
;
235 uword_t displacement
;
236 lispobj fheaderl
, *prev_pointer
;
238 /* if object has already been transported, just return pointer */
239 if (forwarding_pointer_p((lispobj
*)code
)) {
241 printf("Was already transported\n");
243 return (struct code
*) forwarding_pointer_value
244 ((lispobj
*)((pointer_sized_uint_t
) code
));
247 gc_assert(widetag_of(code
->header
) == CODE_HEADER_WIDETAG
);
249 /* prepare to transport the code vector */
250 l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
252 ncode_words
= code_instruction_words(code
->code_size
);
253 nheader_words
= code_header_words(code
->header
);
254 nwords
= ncode_words
+ nheader_words
;
255 nwords
= CEILING(nwords
, 2);
257 l_new_code
= copy_code_object(l_code
, nwords
);
258 new_code
= (struct code
*) native_pointer(l_new_code
);
260 #if defined(DEBUG_CODE_GC)
261 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
262 (uword_t
) code
, (uword_t
) new_code
);
263 printf("Code object is %d words long.\n", nwords
);
266 #ifdef LISP_FEATURE_GENCGC
267 if (new_code
== code
)
271 displacement
= l_new_code
- l_code
;
273 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
275 /* set forwarding pointers for all the function headers in the */
276 /* code object. also fix all self pointers */
278 fheaderl
= code
->entry_points
;
279 prev_pointer
= &new_code
->entry_points
;
281 while (fheaderl
!= NIL
) {
282 struct simple_fun
*fheaderp
, *nfheaderp
;
285 fheaderp
= (struct simple_fun
*) native_pointer(fheaderl
);
286 gc_assert(widetag_of(fheaderp
->header
) == SIMPLE_FUN_HEADER_WIDETAG
);
288 /* Calculate the new function pointer and the new */
289 /* function header. */
290 nfheaderl
= fheaderl
+ displacement
;
291 nfheaderp
= (struct simple_fun
*) native_pointer(nfheaderl
);
294 printf("fheaderp->header (at %x) <- %x\n",
295 &(fheaderp
->header
) , nfheaderl
);
297 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
299 /* fix self pointer. */
301 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
302 FUN_RAW_ADDR_OFFSET
+
306 *prev_pointer
= nfheaderl
;
308 fheaderl
= fheaderp
->next
;
309 prev_pointer
= &nfheaderp
->next
;
311 #ifdef LISP_FEATURE_GENCGC
312 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
313 spaces once when all copying is done. */
314 os_flush_icache((os_vm_address_t
) (((sword_t
*)new_code
) + nheader_words
),
315 ncode_words
* sizeof(sword_t
));
319 #ifdef LISP_FEATURE_X86
320 gencgc_apply_code_fixups(code
, new_code
);
327 scav_code_header(lispobj
*where
, lispobj object
)
330 sword_t n_header_words
, n_code_words
, n_words
;
331 lispobj entry_point
; /* tagged pointer to entry point */
332 struct simple_fun
*function_ptr
; /* untagged pointer to entry point */
334 code
= (struct code
*) where
;
335 n_code_words
= code_instruction_words(code
->code_size
);
336 n_header_words
= code_header_words(object
);
337 n_words
= n_code_words
+ n_header_words
;
338 n_words
= CEILING(n_words
, 2);
340 /* Scavenge the boxed section of the code data block. */
341 scavenge(where
+ 1, n_header_words
- 1);
343 /* Scavenge the boxed section of each function object in the
344 * code data block. */
345 for (entry_point
= code
->entry_points
;
347 entry_point
= function_ptr
->next
) {
349 gc_assert_verbose(is_lisp_pointer(entry_point
),
350 "Entry point %lx\n is not a lisp pointer.",
351 (sword_t
)entry_point
);
353 function_ptr
= (struct simple_fun
*) native_pointer(entry_point
);
354 gc_assert(widetag_of(function_ptr
->header
)==SIMPLE_FUN_HEADER_WIDETAG
);
355 scavenge(SIMPLE_FUN_SCAV_START(function_ptr
),
356 SIMPLE_FUN_SCAV_NWORDS(function_ptr
));
363 trans_code_header(lispobj object
)
367 ncode
= trans_code((struct code
*) native_pointer(object
));
368 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
373 size_code_header(lispobj
*where
)
376 sword_t nheader_words
, ncode_words
, nwords
;
378 code
= (struct code
*) where
;
380 ncode_words
= code_instruction_words(code
->code_size
);
381 nheader_words
= code_header_words(code
->header
);
382 nwords
= ncode_words
+ nheader_words
;
383 nwords
= CEILING(nwords
, 2);
388 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
390 scav_return_pc_header(lispobj
*where
, lispobj object
)
392 lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
395 return 0; /* bogus return value to satisfy static type checking */
397 #endif /* LISP_FEATURE_X86 */
400 trans_return_pc_header(lispobj object
)
402 struct simple_fun
*return_pc
;
404 struct code
*code
, *ncode
;
406 return_pc
= (struct simple_fun
*) native_pointer(object
);
407 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
409 /* Transport the whole code object */
410 code
= (struct code
*) ((uword_t
) return_pc
- offset
);
411 ncode
= trans_code(code
);
413 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
416 /* On the 386, closures hold a pointer to the raw address instead of the
417 * function object, so we can use CALL [$FDEFN+const] to invoke
418 * the function without loading it into a register. Given that code
419 * objects don't move, we don't need to update anything, but we do
420 * have to figure out that the function is still live. */
422 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
424 scav_closure_header(lispobj
*where
, lispobj object
)
426 struct closure
*closure
;
429 closure
= (struct closure
*)where
;
430 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
432 #ifdef LISP_FEATURE_GENCGC
433 /* The function may have moved so update the raw address. But
434 * don't write unnecessarily. */
435 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
436 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
442 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
444 scav_fun_header(lispobj
*where
, lispobj object
)
446 lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
449 return 0; /* bogus return value to satisfy static type checking */
451 #endif /* LISP_FEATURE_X86 */
454 trans_fun_header(lispobj object
)
456 struct simple_fun
*fheader
;
458 struct code
*code
, *ncode
;
460 fheader
= (struct simple_fun
*) native_pointer(object
);
461 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
463 /* Transport the whole code object */
464 code
= (struct code
*) ((uword_t
) fheader
- offset
);
465 ncode
= trans_code(code
);
467 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
476 trans_instance(lispobj object
)
481 gc_assert(is_lisp_pointer(object
));
483 header
= *((lispobj
*) native_pointer(object
));
484 length
= instance_length(header
) + 1;
485 length
= CEILING(length
, 2);
487 return copy_object(object
, length
);
491 size_instance(lispobj
*where
)
497 length
= instance_length(header
) + 1;
498 length
= CEILING(length
, 2);
504 scav_instance_pointer(lispobj
*where
, lispobj object
)
506 lispobj copy
, *first_pointer
;
508 /* Object is a pointer into from space - not a FP. */
509 copy
= trans_instance(object
);
511 #ifdef LISP_FEATURE_GENCGC
512 gc_assert(copy
!= object
);
515 first_pointer
= (lispobj
*) native_pointer(object
);
516 set_forwarding_pointer(first_pointer
,copy
);
527 static lispobj
trans_list(lispobj object
);
530 scav_list_pointer(lispobj
*where
, lispobj object
)
533 gc_assert(is_lisp_pointer(object
));
535 first
= trans_list(object
);
536 gc_assert(first
!= object
);
538 gc_assert(is_lisp_pointer(first
));
539 gc_assert(!from_space_p(first
));
547 trans_list(lispobj object
)
549 lispobj new_list_pointer
;
550 struct cons
*cons
, *new_cons
;
553 cons
= (struct cons
*) native_pointer(object
);
556 new_cons
= (struct cons
*)
557 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
558 new_cons
->car
= cons
->car
;
559 new_cons
->cdr
= cons
->cdr
; /* updated later */
560 new_list_pointer
= make_lispobj(new_cons
,lowtag_of(object
));
562 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
565 set_forwarding_pointer((lispobj
*)cons
, new_list_pointer
);
567 /* Try to linearize the list in the cdr direction to help reduce
571 struct cons
*cdr_cons
, *new_cdr_cons
;
573 if(lowtag_of(cdr
) != LIST_POINTER_LOWTAG
||
574 !from_space_p(cdr
) ||
575 forwarding_pointer_p((lispobj
*)native_pointer(cdr
)))
578 cdr_cons
= (struct cons
*) native_pointer(cdr
);
581 new_cdr_cons
= (struct cons
*)
582 gc_general_alloc(sizeof(struct cons
), BOXED_PAGE_FLAG
, ALLOC_QUICK
);
583 new_cdr_cons
->car
= cdr_cons
->car
;
584 new_cdr_cons
->cdr
= cdr_cons
->cdr
;
585 new_cdr
= make_lispobj(new_cdr_cons
, lowtag_of(cdr
));
587 /* Grab the cdr before it is clobbered. */
589 set_forwarding_pointer((lispobj
*)cdr_cons
, new_cdr
);
591 /* Update the cdr of the last cons copied into new space to
592 * keep the newspace scavenge from having to do it. */
593 new_cons
->cdr
= new_cdr
;
595 new_cons
= new_cdr_cons
;
598 return new_list_pointer
;
603 * scavenging and transporting other pointers
607 scav_other_pointer(lispobj
*where
, lispobj object
)
609 lispobj first
, *first_pointer
;
611 gc_assert(is_lisp_pointer(object
));
613 /* Object is a pointer into from space - not FP. */
614 first_pointer
= (lispobj
*) native_pointer(object
);
615 first
= (transother
[widetag_of(*first_pointer
)])(object
);
617 // If the object was large, then instead of transporting it,
618 // gencgc might simply promote the pages and return the same pointer.
619 // That decision is made in general_copy_large_object().
620 if (first
!= object
) {
621 set_forwarding_pointer(first_pointer
, first
);
622 #ifdef LISP_FEATURE_GENCGC
626 #ifndef LISP_FEATURE_GENCGC
629 gc_assert(is_lisp_pointer(first
));
630 gc_assert(!from_space_p(first
));
636 * immediate, boxed, and unboxed objects
640 size_pointer(lispobj
*where
)
646 scav_immediate(lispobj
*where
, lispobj object
)
652 trans_immediate(lispobj object
)
654 lose("trying to transport an immediate\n");
655 return NIL
; /* bogus return value to satisfy static type checking */
659 size_immediate(lispobj
*where
)
666 scav_boxed(lispobj
*where
, lispobj object
)
671 boolean
positive_bignum_logbitp(int index
, struct bignum
* bignum
)
673 /* If the bignum in the layout has another pointer to it (besides the layout)
674 acting as a root, and which is scavenged first, then transporting the
675 bignum causes the layout to see a FP, as would copying an instance whose
676 layout that is. This is a nearly impossible scenario to create organically
677 in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
678 except for a few things that would cause it to be pinned anyway,
679 such as it being kept in a local variable during structure manipulation.
680 See 'interleaved-raw.impure.lisp' for a way to trigger this */
681 if (forwarding_pointer_p((lispobj
*)bignum
)) {
682 lispobj
*forwarded
= forwarding_pointer_value((lispobj
*)bignum
);
684 fprintf(stderr
, "GC bignum_logbitp(): fwd from %p to %p\n",
685 (void*)bignum
, (void*)forwarded
);
687 bignum
= (struct bignum
*)native_pointer((lispobj
)forwarded
);
690 int len
= HeaderValue(bignum
->header
);
691 int word_index
= index
/ N_WORD_BITS
;
692 int bit_index
= index
% N_WORD_BITS
;
693 if (word_index
>= len
) {
694 // just return 0 since the marking logic does not allow negative bignums
697 return (bignum
->digits
[word_index
] >> bit_index
) & 1;
701 // Helper function for helper function below, since lambda isn't a thing
702 static void instance_scan_range(void* instance_ptr
, int offset
, int nwords
)
704 scavenge((lispobj
*)instance_ptr
+ offset
, nwords
);
707 // Helper function for stepping through the tagged slots of an instance in
708 // scav_instance and verify_space.
710 instance_scan_interleaved(void (*proc
)(lispobj
*, sword_t
),
711 lispobj
*instance_ptr
,
715 struct layout
*layout
= (struct layout
*)layout_obj
;
716 lispobj layout_bitmap
= layout
->bitmap
;
719 /* This code might be made more efficient by run-length-encoding the ranges
720 of words to scan, but probably not by much */
722 ++instance_ptr
; // was supplied as the address of the header word
723 if (fixnump(layout_bitmap
)) {
724 sword_t bitmap
= (sword_t
)layout_bitmap
>> N_FIXNUM_TAG_BITS
; // signed integer!
725 for (index
= 0; index
< n_words
; index
++, bitmap
>>= 1)
727 proc(instance_ptr
+ index
, 1);
728 } else { /* huge bitmap */
729 struct bignum
* bitmap
;
730 bitmap
= (struct bignum
*)native_pointer(layout_bitmap
);
731 if (forwarding_pointer_p((lispobj
*)bitmap
))
732 bitmap
= (struct bignum
*)
733 native_pointer((lispobj
)forwarding_pointer_value((lispobj
*)bitmap
));
734 bitmap_scan((uword_t
*)bitmap
->digits
, HeaderValue(bitmap
->header
), 0,
735 instance_scan_range
, instance_ptr
);
739 void bitmap_scan(uword_t
* bitmap
, int n_bitmap_words
, int flags
,
740 void (*proc
)(void*, int, int), void* arg
)
742 uword_t sense
= (flags
& BIT_SCAN_INVERT
) ? ~0L : 0;
743 int start_word_index
= 0;
745 in_use_marker_t word
;
747 flags
= flags
& BIT_SCAN_CLEAR
;
749 // Rather than bzero'ing we can just clear each nonzero word as it's read,
751 #define BITMAP_REF(j) word = bitmap[j]; if(word && flags) bitmap[j] = 0; word ^= sense
754 int skip_bits
, start_bit
, start_position
, run_length
;
756 if (++start_word_index
>= n_bitmap_words
) break;
757 BITMAP_REF(start_word_index
);
761 // On each loop iteration, the lowest 1 bit is a "relative"
762 // bit index, since the word was already shifted. This is 'skip_bits'.
763 // Adding back in the total shift amount gives 'start_bit',
764 // the true absolute index within the current word.
765 // 'start_position' is absolute within the entire bitmap.
766 skip_bits
= ffsl(word
) - 1;
767 start_bit
= skip_bits
+ shift
;
768 start_position
= N_WORD_BITS
* start_word_index
+ start_bit
;
769 // Compute the number of consecutive 1s in the current word.
771 run_length
= ~word
? ffsl(~word
) - 1 : N_WORD_BITS
;
772 if (start_bit
+ run_length
< N_WORD_BITS
) { // Do not extend to additional words.
774 shift
+= skip_bits
+ run_length
;
776 int end_word_index
= ++start_word_index
;
778 if (end_word_index
>= n_bitmap_words
) {
780 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
;
783 BITMAP_REF(end_word_index
);
787 // end_word_index is the exclusive bound on contiguous
788 // words to include in the range. See if the low bits
789 // from the next word can extend the range.
790 shift
= ffsl(~word
) - 1;
792 run_length
+= (end_word_index
- start_word_index
) * N_WORD_BITS
797 start_word_index
= end_word_index
;
799 proc(arg
, start_position
, run_length
);
805 scav_instance(lispobj
*where
, lispobj header
)
807 // instance_length() is the number of words following the header including
808 // the layout. If this is an even number, it should be made odd so that
809 // scav_instance() always consumes an even number of words in total.
810 sword_t ntotal
= instance_length(header
) | 1;
811 lispobj
* layout
= (lispobj
*)instance_layout(where
);
815 layout
= native_pointer((lispobj
)layout
);
816 #ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
817 if (__immobile_obj_gen_bits(layout
) == from_space
)
818 promote_immobile_obj(layout
, 1);
820 if (forwarding_pointer_p(layout
))
821 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
824 if (((struct layout
*)layout
)->bitmap
== make_fixnum(-1))
825 scavenge(where
+1, ntotal
);
827 instance_scan_interleaved(scavenge
, where
, ntotal
, layout
);
833 trans_boxed(lispobj object
)
838 gc_assert(is_lisp_pointer(object
));
840 header
= *((lispobj
*) native_pointer(object
));
841 length
= HeaderValue(header
) + 1;
842 length
= CEILING(length
, 2);
844 return copy_object(object
, length
);
848 size_boxed(lispobj
*where
)
854 length
= HeaderValue(header
) + 1;
855 length
= CEILING(length
, 2);
861 trans_tiny_boxed(lispobj object
)
866 gc_assert(is_lisp_pointer(object
));
868 header
= *((lispobj
*) native_pointer(object
));
869 length
= (HeaderValue(header
) & 0xFF) + 1;
870 length
= CEILING(length
, 2);
872 return copy_object(object
, length
);
876 size_tiny_boxed(lispobj
*where
)
882 length
= (HeaderValue(header
) & 0xFF) + 1;
883 length
= CEILING(length
, 2);
888 /* Note: on the sparc we don't have to do anything special for fdefns, */
889 /* 'cause the raw-addr has a function lowtag. */
890 #if !defined(LISP_FEATURE_SPARC) && !defined(LISP_FEATURE_ARM)
892 scav_fdefn(lispobj
*where
, lispobj object
)
896 fdefn
= (struct fdefn
*)where
;
898 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
899 fdefn->fun, fdefn->raw_addr)); */
901 scavenge(where
+ 1, 2); // 'name' and 'fun'
902 lispobj raw_fun
= (lispobj
)fdefn
->raw_addr
;
903 if (raw_fun
> READ_ONLY_SPACE_END
) {
904 lispobj simple_fun
= raw_fun
- FUN_RAW_ADDR_OFFSET
;
905 scavenge(&simple_fun
, 1);
906 /* Don't write unnecessarily. */
907 if (simple_fun
!= raw_fun
- FUN_RAW_ADDR_OFFSET
)
908 fdefn
->raw_addr
= (char *)simple_fun
+ FUN_RAW_ADDR_OFFSET
;
915 scav_unboxed(lispobj
*where
, lispobj object
)
919 length
= HeaderValue(object
) + 1;
920 length
= CEILING(length
, 2);
926 trans_unboxed(lispobj object
)
932 gc_assert(is_lisp_pointer(object
));
934 header
= *((lispobj
*) native_pointer(object
));
935 length
= HeaderValue(header
) + 1;
936 length
= CEILING(length
, 2);
938 return copy_unboxed_object(object
, length
);
942 size_unboxed(lispobj
*where
)
948 length
= HeaderValue(header
) + 1;
949 length
= CEILING(length
, 2);
955 /* vector-like objects */
957 scav_base_string(lispobj
*where
, lispobj object
)
959 struct vector
*vector
;
960 sword_t length
, nwords
;
962 /* NOTE: Strings contain one more byte of data than the length */
963 /* slot indicates. */
965 vector
= (struct vector
*) where
;
966 length
= fixnum_value(vector
->length
) + 1;
967 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
972 trans_base_string(lispobj object
)
974 struct vector
*vector
;
975 sword_t length
, nwords
;
977 gc_assert(is_lisp_pointer(object
));
979 /* NOTE: A string contains one more byte of data (a terminating
980 * '\0' to help when interfacing with C functions) than indicated
981 * by the length slot. */
983 vector
= (struct vector
*) native_pointer(object
);
984 length
= fixnum_value(vector
->length
) + 1;
985 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
987 return copy_large_unboxed_object(object
, nwords
);
991 size_base_string(lispobj
*where
)
993 struct vector
*vector
;
994 sword_t length
, nwords
;
996 /* NOTE: A string contains one more byte of data (a terminating
997 * '\0' to help when interfacing with C functions) than indicated
998 * by the length slot. */
1000 vector
= (struct vector
*) where
;
1001 length
= fixnum_value(vector
->length
) + 1;
1002 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1007 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1009 scav_character_string(lispobj
*where
, lispobj object
)
1011 struct vector
*vector
;
1014 /* NOTE: Strings contain one more byte of data than the length */
1015 /* slot indicates. */
1017 vector
= (struct vector
*) where
;
1018 length
= fixnum_value(vector
->length
) + 1;
1019 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1024 trans_character_string(lispobj object
)
1026 struct vector
*vector
;
1029 gc_assert(is_lisp_pointer(object
));
1031 /* NOTE: A string contains one more byte of data (a terminating
1032 * '\0' to help when interfacing with C functions) than indicated
1033 * by the length slot. */
1035 vector
= (struct vector
*) native_pointer(object
);
1036 length
= fixnum_value(vector
->length
) + 1;
1037 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1039 return copy_large_unboxed_object(object
, nwords
);
1043 size_character_string(lispobj
*where
)
1045 struct vector
*vector
;
1048 /* NOTE: A string contains one more byte of data (a terminating
1049 * '\0' to help when interfacing with C functions) than indicated
1050 * by the length slot. */
1052 vector
= (struct vector
*) where
;
1053 length
= fixnum_value(vector
->length
) + 1;
1054 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1061 trans_vector(lispobj object
)
1063 struct vector
*vector
;
1064 sword_t length
, nwords
;
1066 gc_assert(is_lisp_pointer(object
));
1068 vector
= (struct vector
*) native_pointer(object
);
1070 length
= fixnum_value(vector
->length
);
1071 nwords
= CEILING(length
+ 2, 2);
1073 return copy_large_object(object
, nwords
);
1077 size_vector(lispobj
*where
)
1079 struct vector
*vector
;
1080 sword_t length
, nwords
;
1082 vector
= (struct vector
*) where
;
1083 length
= fixnum_value(vector
->length
);
1084 nwords
= CEILING(length
+ 2, 2);
1090 scav_vector_nil(lispobj
*where
, lispobj object
)
1096 trans_vector_nil(lispobj object
)
1098 gc_assert(is_lisp_pointer(object
));
1099 return copy_unboxed_object(object
, 2);
1103 size_vector_nil(lispobj
*where
)
1105 /* Just the header word and the length word */
1110 scav_vector_bit(lispobj
*where
, lispobj object
)
1112 struct vector
*vector
;
1113 sword_t length
, nwords
;
1115 vector
= (struct vector
*) where
;
1116 length
= fixnum_value(vector
->length
);
1117 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1123 trans_vector_bit(lispobj object
)
1125 struct vector
*vector
;
1126 sword_t length
, nwords
;
1128 gc_assert(is_lisp_pointer(object
));
1130 vector
= (struct vector
*) native_pointer(object
);
1131 length
= fixnum_value(vector
->length
);
1132 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1134 return copy_large_unboxed_object(object
, nwords
);
1138 size_vector_bit(lispobj
*where
)
1140 struct vector
*vector
;
1141 sword_t length
, nwords
;
1143 vector
= (struct vector
*) where
;
1144 length
= fixnum_value(vector
->length
);
1145 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
1151 scav_vector_unsigned_byte_2(lispobj
*where
, lispobj object
)
1153 struct vector
*vector
;
1154 sword_t length
, nwords
;
1156 vector
= (struct vector
*) where
;
1157 length
= fixnum_value(vector
->length
);
1158 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1164 trans_vector_unsigned_byte_2(lispobj object
)
1166 struct vector
*vector
;
1167 sword_t length
, nwords
;
1169 gc_assert(is_lisp_pointer(object
));
1171 vector
= (struct vector
*) native_pointer(object
);
1172 length
= fixnum_value(vector
->length
);
1173 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1175 return copy_large_unboxed_object(object
, nwords
);
1179 size_vector_unsigned_byte_2(lispobj
*where
)
1181 struct vector
*vector
;
1182 sword_t length
, nwords
;
1184 vector
= (struct vector
*) where
;
1185 length
= fixnum_value(vector
->length
);
1186 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1192 scav_vector_unsigned_byte_4(lispobj
*where
, lispobj object
)
1194 struct vector
*vector
;
1195 sword_t length
, nwords
;
1197 vector
= (struct vector
*) where
;
1198 length
= fixnum_value(vector
->length
);
1199 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1205 trans_vector_unsigned_byte_4(lispobj object
)
1207 struct vector
*vector
;
1208 sword_t length
, nwords
;
1210 gc_assert(is_lisp_pointer(object
));
1212 vector
= (struct vector
*) native_pointer(object
);
1213 length
= fixnum_value(vector
->length
);
1214 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1216 return copy_large_unboxed_object(object
, nwords
);
1219 size_vector_unsigned_byte_4(lispobj
*where
)
1221 struct vector
*vector
;
1222 sword_t length
, nwords
;
1224 vector
= (struct vector
*) where
;
1225 length
= fixnum_value(vector
->length
);
1226 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1233 scav_vector_unsigned_byte_8(lispobj
*where
, lispobj object
)
1235 struct vector
*vector
;
1236 sword_t length
, nwords
;
1238 vector
= (struct vector
*) where
;
1239 length
= fixnum_value(vector
->length
);
1240 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1245 /*********************/
1250 trans_vector_unsigned_byte_8(lispobj object
)
1252 struct vector
*vector
;
1253 sword_t length
, nwords
;
1255 gc_assert(is_lisp_pointer(object
));
1257 vector
= (struct vector
*) native_pointer(object
);
1258 length
= fixnum_value(vector
->length
);
1259 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1261 return copy_large_unboxed_object(object
, nwords
);
1265 size_vector_unsigned_byte_8(lispobj
*where
)
1267 struct vector
*vector
;
1268 sword_t length
, nwords
;
1270 vector
= (struct vector
*) where
;
1271 length
= fixnum_value(vector
->length
);
1272 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1279 scav_vector_unsigned_byte_16(lispobj
*where
, lispobj object
)
1281 struct vector
*vector
;
1282 sword_t length
, nwords
;
1284 vector
= (struct vector
*) where
;
1285 length
= fixnum_value(vector
->length
);
1286 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1292 trans_vector_unsigned_byte_16(lispobj object
)
1294 struct vector
*vector
;
1295 sword_t length
, nwords
;
1297 gc_assert(is_lisp_pointer(object
));
1299 vector
= (struct vector
*) native_pointer(object
);
1300 length
= fixnum_value(vector
->length
);
1301 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1303 return copy_large_unboxed_object(object
, nwords
);
1307 size_vector_unsigned_byte_16(lispobj
*where
)
1309 struct vector
*vector
;
1310 sword_t length
, nwords
;
1312 vector
= (struct vector
*) where
;
1313 length
= fixnum_value(vector
->length
);
1314 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1320 scav_vector_unsigned_byte_32(lispobj
*where
, lispobj object
)
1322 struct vector
*vector
;
1323 sword_t length
, nwords
;
1325 vector
= (struct vector
*) where
;
1326 length
= fixnum_value(vector
->length
);
1327 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1333 trans_vector_unsigned_byte_32(lispobj object
)
1335 struct vector
*vector
;
1336 sword_t length
, nwords
;
1338 gc_assert(is_lisp_pointer(object
));
1340 vector
= (struct vector
*) native_pointer(object
);
1341 length
= fixnum_value(vector
->length
);
1342 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1344 return copy_large_unboxed_object(object
, nwords
);
1348 size_vector_unsigned_byte_32(lispobj
*where
)
1350 struct vector
*vector
;
1351 sword_t length
, nwords
;
1353 vector
= (struct vector
*) where
;
1354 length
= fixnum_value(vector
->length
);
1355 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1360 #if N_WORD_BITS == 64
1362 scav_vector_unsigned_byte_64(lispobj
*where
, lispobj object
)
1364 struct vector
*vector
;
1365 sword_t length
, nwords
;
1367 vector
= (struct vector
*) where
;
1368 length
= fixnum_value(vector
->length
);
1369 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1375 trans_vector_unsigned_byte_64(lispobj object
)
1377 struct vector
*vector
;
1378 sword_t length
, nwords
;
1380 gc_assert(is_lisp_pointer(object
));
1382 vector
= (struct vector
*) native_pointer(object
);
1383 length
= fixnum_value(vector
->length
);
1384 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1386 return copy_large_unboxed_object(object
, nwords
);
1390 size_vector_unsigned_byte_64(lispobj
*where
)
1392 struct vector
*vector
;
1393 sword_t length
, nwords
;
1395 vector
= (struct vector
*) where
;
1396 length
= fixnum_value(vector
->length
);
1397 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1404 scav_vector_single_float(lispobj
*where
, lispobj object
)
1406 struct vector
*vector
;
1407 sword_t length
, nwords
;
1409 vector
= (struct vector
*) where
;
1410 length
= fixnum_value(vector
->length
);
1411 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1417 trans_vector_single_float(lispobj object
)
1419 struct vector
*vector
;
1420 sword_t length
, nwords
;
1422 gc_assert(is_lisp_pointer(object
));
1424 vector
= (struct vector
*) native_pointer(object
);
1425 length
= fixnum_value(vector
->length
);
1426 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1428 return copy_large_unboxed_object(object
, nwords
);
1432 size_vector_single_float(lispobj
*where
)
1434 struct vector
*vector
;
1435 sword_t length
, nwords
;
1437 vector
= (struct vector
*) where
;
1438 length
= fixnum_value(vector
->length
);
1439 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1445 scav_vector_double_float(lispobj
*where
, lispobj object
)
1447 struct vector
*vector
;
1448 sword_t length
, nwords
;
1450 vector
= (struct vector
*) where
;
1451 length
= fixnum_value(vector
->length
);
1452 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1458 trans_vector_double_float(lispobj object
)
1460 struct vector
*vector
;
1461 sword_t length
, nwords
;
1463 gc_assert(is_lisp_pointer(object
));
1465 vector
= (struct vector
*) native_pointer(object
);
1466 length
= fixnum_value(vector
->length
);
1467 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1469 return copy_large_unboxed_object(object
, nwords
);
1473 size_vector_double_float(lispobj
*where
)
1475 struct vector
*vector
;
1476 sword_t length
, nwords
;
1478 vector
= (struct vector
*) where
;
1479 length
= fixnum_value(vector
->length
);
1480 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1485 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1487 scav_vector_long_float(lispobj
*where
, lispobj object
)
1489 struct vector
*vector
;
1490 long length
, nwords
;
1492 vector
= (struct vector
*) where
;
1493 length
= fixnum_value(vector
->length
);
1494 nwords
= CEILING(length
*
1501 trans_vector_long_float(lispobj object
)
1503 struct vector
*vector
;
1504 long length
, nwords
;
1506 gc_assert(is_lisp_pointer(object
));
1508 vector
= (struct vector
*) native_pointer(object
);
1509 length
= fixnum_value(vector
->length
);
1510 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1512 return copy_large_unboxed_object(object
, nwords
);
1516 size_vector_long_float(lispobj
*where
)
1518 struct vector
*vector
;
1519 sword_t length
, nwords
;
1521 vector
= (struct vector
*) where
;
1522 length
= fixnum_value(vector
->length
);
1523 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1530 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1532 scav_vector_complex_single_float(lispobj
*where
, lispobj object
)
1534 struct vector
*vector
;
1535 sword_t length
, nwords
;
1537 vector
= (struct vector
*) where
;
1538 length
= fixnum_value(vector
->length
);
1539 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1545 trans_vector_complex_single_float(lispobj object
)
1547 struct vector
*vector
;
1548 sword_t length
, nwords
;
1550 gc_assert(is_lisp_pointer(object
));
1552 vector
= (struct vector
*) native_pointer(object
);
1553 length
= fixnum_value(vector
->length
);
1554 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1556 return copy_large_unboxed_object(object
, nwords
);
1560 size_vector_complex_single_float(lispobj
*where
)
1562 struct vector
*vector
;
1563 sword_t length
, nwords
;
1565 vector
= (struct vector
*) where
;
1566 length
= fixnum_value(vector
->length
);
1567 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1573 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1575 scav_vector_complex_double_float(lispobj
*where
, lispobj object
)
1577 struct vector
*vector
;
1578 sword_t length
, nwords
;
1580 vector
= (struct vector
*) where
;
1581 length
= fixnum_value(vector
->length
);
1582 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1588 trans_vector_complex_double_float(lispobj object
)
1590 struct vector
*vector
;
1591 sword_t length
, nwords
;
1593 gc_assert(is_lisp_pointer(object
));
1595 vector
= (struct vector
*) native_pointer(object
);
1596 length
= fixnum_value(vector
->length
);
1597 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1599 return copy_large_unboxed_object(object
, nwords
);
1603 size_vector_complex_double_float(lispobj
*where
)
1605 struct vector
*vector
;
1606 sword_t length
, nwords
;
1608 vector
= (struct vector
*) where
;
1609 length
= fixnum_value(vector
->length
);
1610 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1617 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1619 scav_vector_complex_long_float(lispobj
*where
, lispobj object
)
1621 struct vector
*vector
;
1622 sword_t length
, nwords
;
1624 vector
= (struct vector
*) where
;
1625 length
= fixnum_value(vector
->length
);
1626 nwords
= CEILING(length
* (2* LONG_FLOAT_SIZE
) + 2, 2);
1632 trans_vector_complex_long_float(lispobj object
)
1634 struct vector
*vector
;
1635 long length
, nwords
;
1637 gc_assert(is_lisp_pointer(object
));
1639 vector
= (struct vector
*) native_pointer(object
);
1640 length
= fixnum_value(vector
->length
);
1641 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1643 return copy_large_unboxed_object(object
, nwords
);
1647 size_vector_complex_long_float(lispobj
*where
)
1649 struct vector
*vector
;
1650 long length
, nwords
;
1652 vector
= (struct vector
*) where
;
1653 length
= fixnum_value(vector
->length
);
1654 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1660 #define WEAK_POINTER_NWORDS \
1661 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1664 trans_weak_pointer(lispobj object
)
1667 #ifndef LISP_FEATURE_GENCGC
1668 struct weak_pointer
*wp
;
1670 gc_assert(is_lisp_pointer(object
));
1672 #if defined(DEBUG_WEAK)
1673 printf("Transporting weak pointer from 0x%08x\n", object
);
1676 /* Need to remember where all the weak pointers are that have */
1677 /* been transported so they can be fixed up in a post-GC pass. */
1679 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
1680 #ifndef LISP_FEATURE_GENCGC
1681 wp
= (struct weak_pointer
*) native_pointer(copy
);
1683 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1684 /* Push the weak pointer onto the list of weak pointers. */
1685 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
1692 size_weak_pointer(lispobj
*where
)
1694 return WEAK_POINTER_NWORDS
;
1698 void scan_weak_pointers(void)
1700 struct weak_pointer
*wp
, *next_wp
;
1701 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
1702 lispobj value
= wp
->value
;
1703 lispobj
*first_pointer
;
1704 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1708 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
1711 if (!is_lisp_pointer(value
))
1714 /* Now, we need to check whether the object has been forwarded. If
1715 * it has been, the weak pointer is still good and needs to be
1716 * updated. Otherwise, the weak pointer needs to be nil'ed
1719 if (from_space_p(value
)) {
1720 first_pointer
= (lispobj
*)native_pointer(value
);
1722 if (forwarding_pointer_p(first_pointer
)) {
1724 (lispobj
)LOW_WORD(forwarding_pointer_value(first_pointer
));
1731 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1732 else if (immobile_space_p(value
) &&
1733 immobile_obj_gen_bits(native_pointer(value
)) == from_space
) {
1744 #if N_WORD_BITS == 32
1745 #define EQ_HASH_MASK 0x1fffffff
1746 #elif N_WORD_BITS == 64
1747 #define EQ_HASH_MASK 0x1fffffffffffffff
1750 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1751 * target-hash-table.lisp. */
1752 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1754 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1755 * slot. Set to NULL at the end of a collection.
1757 * This is not optimal because, when a table is tenured, it won't be
1758 * processed automatically; only the yougest generation is GC'd by
1759 * default. On the other hand, all applications will need an
1760 * occasional full GC anyway, so it's not that bad either. */
1761 struct hash_table
*weak_hash_tables
= NULL
;
1763 /* Return true if OBJ has already survived the current GC. */
1765 survived_gc_yet (lispobj obj
)
1767 #ifdef LISP_FEATURE_IMMOBILE_SPACE
1768 /* If an immobile object's generation# is that of 'from_space', but has been
1769 visited (i.e. is live), then it is conceptually not in 'from_space'.
1770 This can happen when and only when _not_ raising the generation number.
1771 Since the gen_bits() accessor returns the visited bit, the byte value
1772 is numerically unequal to 'from_space', which is what we want */
1773 return !is_lisp_pointer(obj
)
1774 || (immobile_space_p(obj
)
1775 ? immobile_obj_gen_bits(native_pointer(obj
)) != from_space
1776 : (!from_space_p(obj
) || forwarding_pointer_p(native_pointer(obj
))));
1778 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1779 forwarding_pointer_p(native_pointer(obj
)));
1784 weak_hash_entry_alivep (lispobj weakness
, lispobj key
, lispobj value
)
1788 return survived_gc_yet(key
);
1790 return survived_gc_yet(value
);
1792 return (survived_gc_yet(key
) || survived_gc_yet(value
));
1794 return (survived_gc_yet(key
) && survived_gc_yet(value
));
1797 /* Shut compiler up. */
1802 /* Return the beginning of data in ARRAY (skipping the header and the
1803 * length) or NULL if it isn't an array of the specified widetag after
1805 static inline lispobj
*
1806 get_array_data (lispobj array
, int widetag
, uword_t
*length
)
1808 if (is_lisp_pointer(array
) &&
1809 (widetag_of(*(lispobj
*)native_pointer(array
)) == widetag
)) {
1811 *length
= fixnum_value(((lispobj
*)native_pointer(array
))[1]);
1812 return ((lispobj
*)native_pointer(array
)) + 2;
1818 /* Only need to worry about scavenging the _real_ entries in the
1819 * table. Phantom entries such as the hash table itself at index 0 and
1820 * the empty marker at index 1 were scavenged by scav_vector that
1821 * either called this function directly or arranged for it to be
1822 * called later by pushing the hash table onto weak_hash_tables. */
1824 scav_hash_table_entries (struct hash_table
*hash_table
)
1828 lispobj
*index_vector
;
1830 lispobj
*next_vector
;
1831 uword_t next_vector_length
;
1832 lispobj
*hash_vector
;
1833 uword_t hash_vector_length
;
1834 lispobj empty_symbol
;
1835 lispobj weakness
= hash_table
->weakness
;
1838 kv_vector
= get_array_data(hash_table
->table
,
1839 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1840 if (kv_vector
== NULL
)
1841 lose("invalid kv_vector %x\n", hash_table
->table
);
1843 index_vector
= get_array_data(hash_table
->index_vector
,
1844 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1845 if (index_vector
== NULL
)
1846 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1848 next_vector
= get_array_data(hash_table
->next_vector
,
1849 SIMPLE_ARRAY_WORD_WIDETAG
,
1850 &next_vector_length
);
1851 if (next_vector
== NULL
)
1852 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1854 hash_vector
= get_array_data(hash_table
->hash_vector
,
1855 SIMPLE_ARRAY_WORD_WIDETAG
,
1856 &hash_vector_length
);
1857 if (hash_vector
!= NULL
)
1858 gc_assert(hash_vector_length
== next_vector_length
);
1860 /* These lengths could be different as the index_vector can be a
1861 * different length from the others, a larger index_vector could
1862 * help reduce collisions. */
1863 gc_assert(next_vector_length
*2 == kv_length
);
1865 empty_symbol
= kv_vector
[1];
1866 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1867 if (widetag_of(*(lispobj
*)native_pointer(empty_symbol
)) !=
1868 SYMBOL_HEADER_WIDETAG
) {
1869 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1870 *(lispobj
*)native_pointer(empty_symbol
));
1873 /* Work through the KV vector. */
1874 for (i
= 1; i
< next_vector_length
; i
++) {
1875 lispobj old_key
= kv_vector
[2*i
];
1876 lispobj value
= kv_vector
[2*i
+1];
1877 if ((weakness
== NIL
) ||
1878 weak_hash_entry_alivep(weakness
, old_key
, value
)) {
1880 /* Scavenge the key and value. */
1881 scavenge(&kv_vector
[2*i
],2);
1883 /* If an EQ-based key has moved, mark the hash-table for
1885 if (!hash_vector
|| hash_vector
[i
] == MAGIC_HASH_VECTOR_VALUE
) {
1886 lispobj new_key
= kv_vector
[2*i
];
1887 // FIXME: many EQ-based sxhash values are insensitive
1888 // to object movement. The most important one is SYMBOL,
1889 // but others also carry around a hash value: LAYOUT, CLASSOID,
1890 // and STANDARD-[FUNCALLABLE-]INSTANCE.
1891 // If old_key is any of those, don't set needs_rehash_p.
1892 if (old_key
!= new_key
&& new_key
!= empty_symbol
) {
1893 hash_table
->needs_rehash_p
= T
;
1901 scav_vector (lispobj
*where
, lispobj object
)
1904 struct hash_table
*hash_table
;
1906 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1907 * hash tables in the Lisp HASH-TABLE code to indicate need for
1908 * special GC support. */
1909 if ((HeaderValue(object
) & 0xFF) == subtype_VectorNormal
)
1912 kv_length
= fixnum_value(where
[1]);
1913 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1915 /* Scavenge element 0, which may be a hash-table structure. */
1916 scavenge(where
+2, 1);
1917 if (!is_lisp_pointer(where
[2])) {
1918 /* This'll happen when REHASH clears the header of old-kv-vector
1919 * and fills it with zero, but some other thread simulatenously
1920 * sets the header in %%PUTHASH.
1923 "Warning: no pointer at %p in hash table: this indicates "
1924 "non-fatal corruption caused by concurrent access to a "
1925 "hash-table from multiple threads. Any accesses to "
1926 "hash-tables shared between threads should be protected "
1927 "by locks.\n", (void*)&where
[2]);
1928 // We've scavenged three words.
1931 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1932 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1933 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1934 lose("hash table not instance (%x at %x)\n",
1939 /* Scavenge element 1, which should be some internal symbol that
1940 * the hash table code reserves for marking empty slots. */
1941 scavenge(where
+3, 1);
1942 if (!is_lisp_pointer(where
[3])) {
1943 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1946 /* Scavenge hash table, which will fix the positions of the other
1947 * needed objects. */
1948 scavenge((lispobj
*)hash_table
,
1949 CEILING(sizeof(struct hash_table
) / sizeof(lispobj
), 2));
1951 /* Cross-check the kv_vector. */
1952 if (where
!= (lispobj
*)native_pointer(hash_table
->table
)) {
1953 lose("hash_table table!=this table %x\n", hash_table
->table
);
1956 if (hash_table
->weakness
== NIL
) {
1957 scav_hash_table_entries(hash_table
);
1959 /* Delay scavenging of this table by pushing it onto
1960 * weak_hash_tables (if it's not there already) for the weak
1962 if (hash_table
->next_weak_hash_table
== NIL
) {
1963 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1964 weak_hash_tables
= hash_table
;
1968 return (CEILING(kv_length
+ 2, 2));
1972 scav_weak_hash_tables (void)
1974 struct hash_table
*table
;
1976 /* Scavenge entries whose triggers are known to survive. */
1977 for (table
= weak_hash_tables
; table
!= NULL
;
1978 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1979 scav_hash_table_entries(table
);
1983 /* Walk through the chain whose first element is *FIRST and remove
1984 * dead weak entries. */
1986 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1987 lispobj
*kv_vector
, lispobj
*index_vector
,
1988 lispobj
*next_vector
, lispobj
*hash_vector
,
1989 lispobj empty_symbol
, lispobj weakness
)
1991 unsigned index
= *prev
;
1993 unsigned next
= next_vector
[index
];
1994 lispobj key
= kv_vector
[2 * index
];
1995 lispobj value
= kv_vector
[2 * index
+ 1];
1996 gc_assert(key
!= empty_symbol
);
1997 gc_assert(value
!= empty_symbol
);
1998 if (!weak_hash_entry_alivep(weakness
, key
, value
)) {
1999 unsigned count
= fixnum_value(hash_table
->number_entries
);
2000 gc_assert(count
> 0);
2002 hash_table
->number_entries
= make_fixnum(count
- 1);
2003 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
2004 hash_table
->next_free_kv
= make_fixnum(index
);
2005 kv_vector
[2 * index
] = empty_symbol
;
2006 kv_vector
[2 * index
+ 1] = empty_symbol
;
2008 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
2010 prev
= &next_vector
[index
];
2017 scan_weak_hash_table (struct hash_table
*hash_table
)
2020 lispobj
*index_vector
;
2021 uword_t length
= 0; /* prevent warning */
2022 lispobj
*next_vector
;
2023 uword_t next_vector_length
= 0; /* prevent warning */
2024 lispobj
*hash_vector
;
2025 lispobj empty_symbol
;
2026 lispobj weakness
= hash_table
->weakness
;
2029 kv_vector
= get_array_data(hash_table
->table
,
2030 SIMPLE_VECTOR_WIDETAG
, NULL
);
2031 index_vector
= get_array_data(hash_table
->index_vector
,
2032 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
2033 next_vector
= get_array_data(hash_table
->next_vector
,
2034 SIMPLE_ARRAY_WORD_WIDETAG
,
2035 &next_vector_length
);
2036 hash_vector
= get_array_data(hash_table
->hash_vector
,
2037 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
2038 empty_symbol
= kv_vector
[1];
2040 for (i
= 0; i
< length
; i
++) {
2041 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
2042 kv_vector
, index_vector
, next_vector
,
2043 hash_vector
, empty_symbol
, weakness
);
2047 /* Remove dead entries from weak hash tables. */
2049 scan_weak_hash_tables (void)
2051 struct hash_table
*table
, *next
;
2053 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
2054 next
= (struct hash_table
*)table
->next_weak_hash_table
;
2055 table
->next_weak_hash_table
= NIL
;
2056 scan_weak_hash_table(table
);
2059 weak_hash_tables
= NULL
;
2068 scav_lose(lispobj
*where
, lispobj object
)
2070 lose("no scavenge function for object %p (widetag 0x%x)\n",
2072 widetag_of(*where
));
2074 return 0; /* bogus return value to satisfy static type checking */
2078 trans_lose(lispobj object
)
2080 lose("no transport function for object %p (widetag 0x%x)\n",
2082 widetag_of(*(lispobj
*)native_pointer(object
)));
2083 return NIL
; /* bogus return value to satisfy static type checking */
2087 size_lose(lispobj
*where
)
2089 lose("no size function for object at %p (widetag 0x%x)\n",
2091 widetag_of(*where
));
2092 return 1; /* bogus return value to satisfy static type checking */
2101 gc_init_tables(void)
2105 /* Set default value in all slots of scavenge table. FIXME
2106 * replace this gnarly sizeof with something based on
2108 for (i
= 0; i
< ((sizeof scavtab
)/(sizeof scavtab
[0])); i
++) {
2109 scavtab
[i
] = scav_lose
;
2112 /* For each type which can be selected by the lowtag alone, set
2113 * multiple entries in our widetag scavenge table (one for each
2114 * possible value of the high bits).
2117 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2118 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2120 scavtab
[j
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
2123 scavtab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_fun_pointer
;
2124 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2125 scavtab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_list_pointer
;
2126 scavtab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] =
2127 scav_instance_pointer
;
2128 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2129 scavtab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_other_pointer
;
2132 /* Other-pointer types (those selected by all eight bits of the
2133 * tag) get one entry each in the scavenge table. */
2134 scavtab
[BIGNUM_WIDETAG
] = scav_unboxed
;
2135 scavtab
[RATIO_WIDETAG
] = scav_boxed
;
2136 #if N_WORD_BITS == 64
2137 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_immediate
;
2139 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2141 scavtab
[DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2142 #ifdef LONG_FLOAT_WIDETAG
2143 scavtab
[LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2145 scavtab
[COMPLEX_WIDETAG
] = scav_boxed
;
2146 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2147 scavtab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
2149 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2150 scavtab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
2152 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2153 scavtab
[COMPLEX_LONG_FLOAT_WIDETAG
] = scav_unboxed
;
2155 #ifdef SIMD_PACK_WIDETAG
2156 scavtab
[SIMD_PACK_WIDETAG
] = scav_unboxed
;
2158 scavtab
[SIMPLE_ARRAY_WIDETAG
] = scav_boxed
;
2159 scavtab
[SIMPLE_BASE_STRING_WIDETAG
] = scav_base_string
;
2160 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2161 scavtab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = scav_character_string
;
2163 scavtab
[SIMPLE_BIT_VECTOR_WIDETAG
] = scav_vector_bit
;
2164 scavtab
[SIMPLE_ARRAY_NIL_WIDETAG
] = scav_vector_nil
;
2165 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2166 scav_vector_unsigned_byte_2
;
2167 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2168 scav_vector_unsigned_byte_4
;
2169 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2170 scav_vector_unsigned_byte_8
;
2171 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2172 scav_vector_unsigned_byte_8
;
2173 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2174 scav_vector_unsigned_byte_16
;
2175 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2176 scav_vector_unsigned_byte_16
;
2177 #if (N_WORD_BITS == 32)
2178 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2179 scav_vector_unsigned_byte_32
;
2181 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2182 scav_vector_unsigned_byte_32
;
2183 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2184 scav_vector_unsigned_byte_32
;
2185 #if (N_WORD_BITS == 64)
2186 scavtab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2187 scav_vector_unsigned_byte_64
;
2189 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2190 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2191 scav_vector_unsigned_byte_64
;
2193 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2194 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2195 scav_vector_unsigned_byte_64
;
2197 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2198 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = scav_vector_unsigned_byte_8
;
2200 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2201 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2202 scav_vector_unsigned_byte_16
;
2204 #if (N_WORD_BITS == 32)
2205 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2206 scav_vector_unsigned_byte_32
;
2208 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2209 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2210 scav_vector_unsigned_byte_32
;
2212 #if (N_WORD_BITS == 64)
2213 scavtab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2214 scav_vector_unsigned_byte_64
;
2216 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2217 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2218 scav_vector_unsigned_byte_64
;
2220 scavtab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = scav_vector_single_float
;
2221 scavtab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = scav_vector_double_float
;
2222 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2223 scavtab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = scav_vector_long_float
;
2225 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2226 scavtab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2227 scav_vector_complex_single_float
;
2229 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2230 scavtab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2231 scav_vector_complex_double_float
;
2233 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2234 scavtab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2235 scav_vector_complex_long_float
;
2237 scavtab
[COMPLEX_BASE_STRING_WIDETAG
] = scav_boxed
;
2238 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2239 scavtab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = scav_boxed
;
2241 scavtab
[COMPLEX_VECTOR_NIL_WIDETAG
] = scav_boxed
;
2242 scavtab
[COMPLEX_BIT_VECTOR_WIDETAG
] = scav_boxed
;
2243 scavtab
[COMPLEX_VECTOR_WIDETAG
] = scav_boxed
;
2244 scavtab
[COMPLEX_ARRAY_WIDETAG
] = scav_boxed
;
2245 scavtab
[CODE_HEADER_WIDETAG
] = scav_code_header
;
2246 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2247 scavtab
[SIMPLE_FUN_HEADER_WIDETAG
] = scav_fun_header
;
2248 scavtab
[RETURN_PC_HEADER_WIDETAG
] = scav_return_pc_header
;
2250 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_boxed
;
2251 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2252 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_closure_header
;
2254 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_boxed
;
2256 scavtab
[VALUE_CELL_HEADER_WIDETAG
] = scav_boxed
;
2257 scavtab
[SYMBOL_HEADER_WIDETAG
] = scav_boxed
;
2258 scavtab
[CHARACTER_WIDETAG
] = scav_immediate
;
2259 scavtab
[SAP_WIDETAG
] = scav_unboxed
;
2260 scavtab
[UNBOUND_MARKER_WIDETAG
] = scav_immediate
;
2261 scavtab
[NO_TLS_VALUE_MARKER_WIDETAG
] = scav_immediate
;
2262 scavtab
[INSTANCE_HEADER_WIDETAG
] = scav_instance
;
2263 #if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM)
2264 scavtab
[FDEFN_WIDETAG
] = scav_boxed
;
2266 scavtab
[FDEFN_WIDETAG
] = scav_fdefn
;
2268 scavtab
[SIMPLE_VECTOR_WIDETAG
] = scav_vector
;
2270 /* transport other table, initialized same way as scavtab */
2271 for (i
= 0; i
< ((sizeof transother
)/(sizeof transother
[0])); i
++)
2272 transother
[i
] = trans_lose
;
2273 transother
[BIGNUM_WIDETAG
] = trans_unboxed
;
2274 transother
[RATIO_WIDETAG
] = trans_boxed
;
2276 #if N_WORD_BITS == 64
2277 transother
[SINGLE_FLOAT_WIDETAG
] = trans_immediate
;
2279 transother
[SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2281 transother
[DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2282 #ifdef LONG_FLOAT_WIDETAG
2283 transother
[LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2285 transother
[COMPLEX_WIDETAG
] = trans_boxed
;
2286 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2287 transother
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2289 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2290 transother
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2292 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2293 transother
[COMPLEX_LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2295 transother
[SIMPLE_ARRAY_WIDETAG
] = trans_boxed
; /* but not GENCGC */
2296 transother
[SIMPLE_BASE_STRING_WIDETAG
] = trans_base_string
;
2297 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2298 transother
[SIMPLE_CHARACTER_STRING_WIDETAG
] = trans_character_string
;
2300 transother
[SIMPLE_BIT_VECTOR_WIDETAG
] = trans_vector_bit
;
2301 transother
[SIMPLE_VECTOR_WIDETAG
] = trans_vector
;
2302 transother
[SIMPLE_ARRAY_NIL_WIDETAG
] = trans_vector_nil
;
2303 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2304 trans_vector_unsigned_byte_2
;
2305 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2306 trans_vector_unsigned_byte_4
;
2307 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2308 trans_vector_unsigned_byte_8
;
2309 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2310 trans_vector_unsigned_byte_8
;
2311 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2312 trans_vector_unsigned_byte_16
;
2313 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2314 trans_vector_unsigned_byte_16
;
2315 #if (N_WORD_BITS == 32)
2316 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2317 trans_vector_unsigned_byte_32
;
2319 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2320 trans_vector_unsigned_byte_32
;
2321 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2322 trans_vector_unsigned_byte_32
;
2323 #if (N_WORD_BITS == 64)
2324 transother
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2325 trans_vector_unsigned_byte_64
;
2327 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2328 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2329 trans_vector_unsigned_byte_64
;
2331 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2332 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2333 trans_vector_unsigned_byte_64
;
2335 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2336 transother
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] =
2337 trans_vector_unsigned_byte_8
;
2339 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2340 transother
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2341 trans_vector_unsigned_byte_16
;
2343 #if (N_WORD_BITS == 32)
2344 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2345 trans_vector_unsigned_byte_32
;
2347 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2348 transother
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2349 trans_vector_unsigned_byte_32
;
2351 #if (N_WORD_BITS == 64)
2352 transother
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2353 trans_vector_unsigned_byte_64
;
2355 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2356 transother
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2357 trans_vector_unsigned_byte_64
;
2359 transother
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] =
2360 trans_vector_single_float
;
2361 transother
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] =
2362 trans_vector_double_float
;
2363 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2364 transother
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] =
2365 trans_vector_long_float
;
2367 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2368 transother
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2369 trans_vector_complex_single_float
;
2371 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2372 transother
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2373 trans_vector_complex_double_float
;
2375 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2376 transother
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2377 trans_vector_complex_long_float
;
2379 transother
[COMPLEX_BASE_STRING_WIDETAG
] = trans_boxed
;
2380 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2381 transother
[COMPLEX_CHARACTER_STRING_WIDETAG
] = trans_boxed
;
2383 transother
[COMPLEX_BIT_VECTOR_WIDETAG
] = trans_boxed
;
2384 transother
[COMPLEX_VECTOR_NIL_WIDETAG
] = trans_boxed
;
2385 transother
[COMPLEX_VECTOR_WIDETAG
] = trans_boxed
;
2386 transother
[COMPLEX_ARRAY_WIDETAG
] = trans_boxed
;
2387 transother
[CODE_HEADER_WIDETAG
] = trans_code_header
;
2388 transother
[SIMPLE_FUN_HEADER_WIDETAG
] = trans_fun_header
;
2389 transother
[RETURN_PC_HEADER_WIDETAG
] = trans_return_pc_header
;
2390 transother
[CLOSURE_HEADER_WIDETAG
] = trans_boxed
;
2391 transother
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = trans_boxed
;
2392 transother
[VALUE_CELL_HEADER_WIDETAG
] = trans_boxed
;
2393 transother
[SYMBOL_HEADER_WIDETAG
] = trans_tiny_boxed
;
2394 transother
[CHARACTER_WIDETAG
] = trans_immediate
;
2395 transother
[SAP_WIDETAG
] = trans_unboxed
;
2396 #ifdef SIMD_PACK_WIDETAG
2397 transother
[SIMD_PACK_WIDETAG
] = trans_unboxed
;
2399 transother
[UNBOUND_MARKER_WIDETAG
] = trans_immediate
;
2400 transother
[NO_TLS_VALUE_MARKER_WIDETAG
] = trans_immediate
;
2401 transother
[WEAK_POINTER_WIDETAG
] = trans_weak_pointer
;
2402 transother
[INSTANCE_HEADER_WIDETAG
] = trans_instance
;
2403 transother
[FDEFN_WIDETAG
] = trans_tiny_boxed
;
2405 /* size table, initialized the same way as scavtab */
2406 for (i
= 0; i
< ((sizeof sizetab
)/(sizeof sizetab
[0])); i
++)
2407 sizetab
[i
] = size_lose
;
2408 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2409 for (j
= 0; j
< (1<<N_LOWTAG_BITS
); j
++) {
2411 sizetab
[j
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
2414 sizetab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2415 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2416 sizetab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2417 sizetab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2418 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2419 sizetab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2421 sizetab
[BIGNUM_WIDETAG
] = size_unboxed
;
2422 sizetab
[RATIO_WIDETAG
] = size_boxed
;
2423 #if N_WORD_BITS == 64
2424 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_immediate
;
2426 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2428 sizetab
[DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2429 #ifdef LONG_FLOAT_WIDETAG
2430 sizetab
[LONG_FLOAT_WIDETAG
] = size_unboxed
;
2432 sizetab
[COMPLEX_WIDETAG
] = size_boxed
;
2433 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2434 sizetab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2436 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2437 sizetab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2439 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2440 sizetab
[COMPLEX_LONG_FLOAT_WIDETAG
] = size_unboxed
;
2442 sizetab
[SIMPLE_ARRAY_WIDETAG
] = size_boxed
;
2443 sizetab
[SIMPLE_BASE_STRING_WIDETAG
] = size_base_string
;
2444 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2445 sizetab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = size_character_string
;
2447 sizetab
[SIMPLE_BIT_VECTOR_WIDETAG
] = size_vector_bit
;
2448 sizetab
[SIMPLE_VECTOR_WIDETAG
] = size_vector
;
2449 sizetab
[SIMPLE_ARRAY_NIL_WIDETAG
] = size_vector_nil
;
2450 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2451 size_vector_unsigned_byte_2
;
2452 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2453 size_vector_unsigned_byte_4
;
2454 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2455 size_vector_unsigned_byte_8
;
2456 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2457 size_vector_unsigned_byte_8
;
2458 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2459 size_vector_unsigned_byte_16
;
2460 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2461 size_vector_unsigned_byte_16
;
2462 #if (N_WORD_BITS == 32)
2463 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2464 size_vector_unsigned_byte_32
;
2466 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2467 size_vector_unsigned_byte_32
;
2468 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2469 size_vector_unsigned_byte_32
;
2470 #if (N_WORD_BITS == 64)
2471 sizetab
[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
] =
2472 size_vector_unsigned_byte_64
;
2474 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2475 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2476 size_vector_unsigned_byte_64
;
2478 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2479 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2480 size_vector_unsigned_byte_64
;
2482 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2483 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = size_vector_unsigned_byte_8
;
2485 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2486 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2487 size_vector_unsigned_byte_16
;
2489 #if (N_WORD_BITS == 32)
2490 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2491 size_vector_unsigned_byte_32
;
2493 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2494 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2495 size_vector_unsigned_byte_32
;
2497 #if (N_WORD_BITS == 64)
2498 sizetab
[SIMPLE_ARRAY_FIXNUM_WIDETAG
] =
2499 size_vector_unsigned_byte_64
;
2501 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2502 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2503 size_vector_unsigned_byte_64
;
2505 sizetab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = size_vector_single_float
;
2506 sizetab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = size_vector_double_float
;
2507 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2508 sizetab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = size_vector_long_float
;
2510 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2511 sizetab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2512 size_vector_complex_single_float
;
2514 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2515 sizetab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2516 size_vector_complex_double_float
;
2518 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2519 sizetab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2520 size_vector_complex_long_float
;
2522 sizetab
[COMPLEX_BASE_STRING_WIDETAG
] = size_boxed
;
2523 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2524 sizetab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = size_boxed
;
2526 sizetab
[COMPLEX_VECTOR_NIL_WIDETAG
] = size_boxed
;
2527 sizetab
[COMPLEX_BIT_VECTOR_WIDETAG
] = size_boxed
;
2528 sizetab
[COMPLEX_VECTOR_WIDETAG
] = size_boxed
;
2529 sizetab
[COMPLEX_ARRAY_WIDETAG
] = size_boxed
;
2530 sizetab
[CODE_HEADER_WIDETAG
] = size_code_header
;
2532 /* We shouldn't see these, so just lose if it happens. */
2533 sizetab
[SIMPLE_FUN_HEADER_WIDETAG
] = size_function_header
;
2534 sizetab
[RETURN_PC_HEADER_WIDETAG
] = size_return_pc_header
;
2536 sizetab
[CLOSURE_HEADER_WIDETAG
] = size_boxed
;
2537 sizetab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = size_boxed
;
2538 sizetab
[VALUE_CELL_HEADER_WIDETAG
] = size_boxed
;
2539 sizetab
[SYMBOL_HEADER_WIDETAG
] = size_tiny_boxed
;
2540 sizetab
[CHARACTER_WIDETAG
] = size_immediate
;
2541 sizetab
[SAP_WIDETAG
] = size_unboxed
;
2542 #ifdef SIMD_PACK_WIDETAG
2543 sizetab
[SIMD_PACK_WIDETAG
] = size_unboxed
;
2545 sizetab
[UNBOUND_MARKER_WIDETAG
] = size_immediate
;
2546 sizetab
[NO_TLS_VALUE_MARKER_WIDETAG
] = size_immediate
;
2547 sizetab
[WEAK_POINTER_WIDETAG
] = size_weak_pointer
;
2548 sizetab
[INSTANCE_HEADER_WIDETAG
] = size_instance
;
2549 sizetab
[FDEFN_WIDETAG
] = size_tiny_boxed
;
2553 /* Find the code object for the given pc, or return NULL on
2556 component_ptr_from_pc(lispobj
*pc
)
2558 lispobj
*object
= NULL
;
2560 if ( (object
= search_read_only_space(pc
)) )
2562 else if ( (object
= search_static_space(pc
)) )
2564 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2565 else if ( (object
= search_immobile_space(pc
)) )
2569 object
= search_dynamic_space(pc
);
2571 if (object
) /* if we found something */
2572 if (widetag_of(*object
) == CODE_HEADER_WIDETAG
)
2578 /* Scan an area looking for an object which encloses the given pointer.
2579 * Return the object start on success or NULL on failure. */
2581 gc_search_space(lispobj
*start
, size_t words
, lispobj
*pointer
)
2585 lispobj
*forwarded_start
;
2587 if (forwarding_pointer_p(start
))
2589 native_pointer((lispobj
)forwarding_pointer_value(start
));
2591 forwarded_start
= start
;
2592 lispobj thing
= *forwarded_start
;
2593 /* If thing is an immediate then this is a cons. */
2594 if (is_lisp_pointer(thing
) || is_lisp_immediate(thing
))
2597 count
= (sizetab
[widetag_of(thing
)])(forwarded_start
);
2599 /* Check whether the pointer is within this object. */
2600 if ((pointer
>= start
) && (pointer
< (start
+count
))) {
2602 /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2606 /* Round up the count. */
2607 count
= CEILING(count
,2);
2615 /* Helper for valid_lisp_pointer_p (below) and
2616 * possibly_valid_dynamic_space_pointer (gencgc).
2618 * pointer is the pointer to validate, and start_addr is the address
2619 * of the enclosing object.
2622 looks_like_valid_lisp_pointer_p(lispobj pointer
, lispobj
*start_addr
)
2624 if (!is_lisp_pointer(pointer
)) {
2628 /* Check that the object pointed to is consistent with the pointer
2630 switch (lowtag_of(pointer
)) {
2631 case FUN_POINTER_LOWTAG
:
2632 /* Start_addr should be the enclosing code object, or a closure
2634 switch (widetag_of(*start_addr
)) {
2635 case CODE_HEADER_WIDETAG
:
2636 /* Make sure we actually point to a function in the code object,
2637 * as opposed to a random point there. */
2638 if (SIMPLE_FUN_HEADER_WIDETAG
==widetag_of(native_pointer(pointer
)[0]))
2642 case CLOSURE_HEADER_WIDETAG
:
2643 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2644 if (pointer
!= make_lispobj(start_addr
, FUN_POINTER_LOWTAG
)) {
2652 case LIST_POINTER_LOWTAG
:
2653 if (pointer
!= make_lispobj(start_addr
, LIST_POINTER_LOWTAG
)) {
2656 /* Is it plausible cons? */
2657 if ((is_lisp_pointer(start_addr
[0]) ||
2658 is_lisp_immediate(start_addr
[0])) &&
2659 (is_lisp_pointer(start_addr
[1]) ||
2660 is_lisp_immediate(start_addr
[1])))
2665 case INSTANCE_POINTER_LOWTAG
:
2666 if (pointer
!= make_lispobj(start_addr
, INSTANCE_POINTER_LOWTAG
)) {
2669 if (widetag_of(start_addr
[0]) != INSTANCE_HEADER_WIDETAG
) {
2673 case OTHER_POINTER_LOWTAG
:
2675 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2676 /* The all-architecture test below is good as far as it goes,
2677 * but an LRA object is similar to a FUN-POINTER: It is
2678 * embedded within a CODE-OBJECT pointed to by start_addr, and
2679 * cannot be found by simply walking the heap, therefore we
2680 * need to check for it. -- AB, 2010-Jun-04 */
2681 if ((widetag_of(start_addr
[0]) == CODE_HEADER_WIDETAG
)) {
2682 lispobj
*potential_lra
= native_pointer(pointer
);
2683 if ((widetag_of(potential_lra
[0]) == RETURN_PC_HEADER_WIDETAG
) &&
2684 ((potential_lra
- HeaderValue(potential_lra
[0])) == start_addr
)) {
2685 return 1; /* It's as good as we can verify. */
2690 if (pointer
!= make_lispobj(start_addr
, OTHER_POINTER_LOWTAG
)) {
2693 /* Is it plausible? Not a cons. XXX should check the headers. */
2694 if (is_lisp_pointer(start_addr
[0]) || ((start_addr
[0] & 3) == 0)) {
2697 switch (widetag_of(start_addr
[0])) {
2698 case UNBOUND_MARKER_WIDETAG
:
2699 case NO_TLS_VALUE_MARKER_WIDETAG
:
2700 case CHARACTER_WIDETAG
:
2701 #if N_WORD_BITS == 64
2702 case SINGLE_FLOAT_WIDETAG
:
2706 /* only pointed to by function pointers? */
2707 case CLOSURE_HEADER_WIDETAG
:
2708 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
2711 case INSTANCE_HEADER_WIDETAG
:
2714 /* the valid other immediate pointer objects */
2715 case SIMPLE_VECTOR_WIDETAG
:
2717 case COMPLEX_WIDETAG
:
2718 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2719 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
2721 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2722 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2724 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2725 case COMPLEX_LONG_FLOAT_WIDETAG
:
2727 #ifdef SIMD_PACK_WIDETAG
2728 case SIMD_PACK_WIDETAG
:
2730 case SIMPLE_ARRAY_WIDETAG
:
2731 case COMPLEX_BASE_STRING_WIDETAG
:
2732 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2733 case COMPLEX_CHARACTER_STRING_WIDETAG
:
2735 case COMPLEX_VECTOR_NIL_WIDETAG
:
2736 case COMPLEX_BIT_VECTOR_WIDETAG
:
2737 case COMPLEX_VECTOR_WIDETAG
:
2738 case COMPLEX_ARRAY_WIDETAG
:
2739 case VALUE_CELL_HEADER_WIDETAG
:
2740 case SYMBOL_HEADER_WIDETAG
:
2742 case CODE_HEADER_WIDETAG
:
2743 case BIGNUM_WIDETAG
:
2744 #if N_WORD_BITS != 64
2745 case SINGLE_FLOAT_WIDETAG
:
2747 case DOUBLE_FLOAT_WIDETAG
:
2748 #ifdef LONG_FLOAT_WIDETAG
2749 case LONG_FLOAT_WIDETAG
:
2751 case SIMPLE_BASE_STRING_WIDETAG
:
2752 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2753 case SIMPLE_CHARACTER_STRING_WIDETAG
:
2755 case SIMPLE_BIT_VECTOR_WIDETAG
:
2756 case SIMPLE_ARRAY_NIL_WIDETAG
:
2757 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
2758 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
2759 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
2760 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
2761 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
2762 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
2764 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG
:
2766 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
2767 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
2768 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2769 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
2771 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2772 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
2774 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2775 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
2777 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2778 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
2781 case SIMPLE_ARRAY_FIXNUM_WIDETAG
:
2783 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2784 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
2786 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2787 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
2789 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
2790 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
2791 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2792 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
2794 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2795 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
2797 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2798 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
2800 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2801 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
2804 case WEAK_POINTER_WIDETAG
:
2819 /* META: Note the ambiguous word "validate" in the comment below.
2820 * This means "Decide whether <x> is valid".
2821 * But when you see os_validate() elsewhere, that doesn't mean to ask
2822 * whether something is valid, it says to *make* it valid.
2823 * I think it would be nice if we could avoid using the word in the
2824 * sense in which os_validate() uses it, which would entail renaming
2825 * a bunch of stuff, which is harder than just explaining why
2826 * the comments can be deceptive */
2828 /* Used by the debugger to validate possibly bogus pointers before
2829 * calling MAKE-LISP-OBJ on them.
2831 * FIXME: We would like to make this perfect, because if the debugger
2832 * constructs a reference to a bugs lisp object, and it ends up in a
2833 * location scavenged by the GC all hell breaks loose.
2835 * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2836 * and return true for all valid pointers, this could actually be eager
2837 * and lie about a few pointers without bad results... but that should
2838 * be reflected in the name.
2841 valid_lisp_pointer_p(lispobj
*pointer
)
2844 if (((start
=search_dynamic_space(pointer
))!=NULL
) ||
2845 #ifdef LISP_FEATURE_IMMOBILE_SPACE
2846 ((start
=search_immobile_space(pointer
))!=NULL
) ||
2848 ((start
=search_static_space(pointer
))!=NULL
) ||
2849 ((start
=search_read_only_space(pointer
))!=NULL
))
2850 return looks_like_valid_lisp_pointer_p((lispobj
)pointer
, start
);
2856 maybe_gc(os_context_t
*context
)
2858 lispobj gc_happened
;
2859 struct thread
*thread
= arch_os_get_current_thread();
2860 boolean were_in_lisp
= !foreign_function_call_active_p(thread
);
2863 fake_foreign_function_call(context
);
2866 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2867 * which case we will be running with no gc trigger barrier
2868 * thing for a while. But it shouldn't be long until the end
2871 * FIXME: It would be good to protect the end of dynamic space for
2872 * CheneyGC and signal a storage condition from there.
2875 /* Restore the signal mask from the interrupted context before
2876 * calling into Lisp if interrupts are enabled. Why not always?
2878 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2879 * interrupt hits while in SUB-GC, it is deferred and the
2880 * os_context_sigmask of that interrupt is set to block further
2881 * deferrable interrupts (until the first one is
2882 * handled). Unfortunately, that context refers to this place and
2883 * when we return from here the signals will not be blocked.
2885 * A kludgy alternative is to propagate the sigmask change to the
2888 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2889 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context
));
2890 unblock_gc_signals(0, 0);
2892 FSHOW((stderr
, "/maybe_gc: calling SUB_GC\n"));
2893 /* FIXME: Nothing must go wrong during GC else we end up running
2894 * the debugger, error handlers, and user code in general in a
2895 * potentially unsafe place. Running out of the control stack or
2896 * the heap in SUB-GC are ways to lose. Of course, deferrables
2897 * cannot be unblocked because there may be a pending handler, or
2898 * we may even be in a WITHOUT-INTERRUPTS. */
2899 gc_happened
= funcall0(StaticSymbolFunction(SUB_GC
));
2900 FSHOW((stderr
, "/maybe_gc: gc_happened=%s\n",
2901 (gc_happened
== NIL
)
2903 : ((gc_happened
== T
)
2906 /* gc_happened can take three values: T, NIL, 0.
2908 * T means that the thread managed to trigger a GC, and post-gc
2911 * NIL means that the thread is within without-gcing, and no GC
2914 * Finally, 0 means that *a* GC has occurred, but it wasn't
2915 * triggered by this thread; success, but post-gc doesn't have
2918 if ((gc_happened
== T
) &&
2919 /* See if interrupts are enabled or it's possible to enable
2920 * them. POST-GC has a similar check, but we don't want to
2921 * unlock deferrables in that case and get a pending interrupt
2923 ((SymbolValue(INTERRUPTS_ENABLED
,thread
) != NIL
) ||
2924 (SymbolValue(ALLOW_WITH_INTERRUPTS
,thread
) != NIL
))) {
2925 #ifndef LISP_FEATURE_WIN32
2926 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
2927 if (!deferrables_blocked_p(context_sigmask
)) {
2928 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
2929 #ifndef LISP_FEATURE_SB_SAFEPOINT
2930 check_gc_signals_unblocked_or_lose(0);
2933 FSHOW((stderr
, "/maybe_gc: calling POST_GC\n"));
2934 funcall0(StaticSymbolFunction(POST_GC
));
2935 #ifndef LISP_FEATURE_WIN32
2937 FSHOW((stderr
, "/maybe_gc: punting on POST_GC due to blockage\n"));
2943 undo_fake_foreign_function_call(context
);
2945 /* Otherwise done by undo_fake_foreign_function_call. And
2946 something later wants them to be blocked. What a nice
2948 block_blockable_signals(0);
2951 FSHOW((stderr
, "/maybe_gc: returning\n"));
2952 return (gc_happened
!= NIL
);
2955 #define BYTES_ZERO_BEFORE_END (1<<12)
2957 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2958 * Lisp and another called zero_stack() in cheneygc.c, but since it's
2959 * shorter to express in, and more often called from C, I keep only
2960 * the C one after fixing it. -- MG 2009-03-25 */
2962 /* Zero the unused portion of the control stack so that old objects
2963 * are not kept alive because of uninitialized stack variables.
2965 * "To summarize the problem, since not all allocated stack frame
2966 * slots are guaranteed to be written by the time you call an another
2967 * function or GC, there may be garbage pointers retained in your dead
2968 * stack locations. The stack scrubbing only affects the part of the
2969 * stack from the SP to the end of the allocated stack." - ram, on
2970 * cmucl-imp, Tue, 25 Sep 2001
2972 * So, as an (admittedly lame) workaround, from time to time we call
2973 * scrub-control-stack to zero out all the unused portion. This is
2974 * supposed to happen when the stack is mostly empty, so that we have
2975 * a chance of clearing more of it: callers are currently (2002.07.18)
2976 * REPL, SUB-GC and sig_stop_for_gc_handler. */
2978 /* Take care not to tread on the guard page and the hard guard page as
2979 * it would be unkind to sig_stop_for_gc_handler. Touching the return
2980 * guard page is not dangerous. For this to work the guard page must
2981 * be zeroed when protected. */
2983 /* FIXME: I think there is no guarantee that once
2984 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2985 * may be what the "lame" adjective in the above comment is for. In
2986 * this case, exact gc may lose badly. */
2988 scrub_control_stack()
2990 scrub_thread_control_stack(arch_os_get_current_thread());
2994 scrub_thread_control_stack(struct thread
*th
)
2996 os_vm_address_t guard_page_address
= CONTROL_STACK_GUARD_PAGE(th
);
2997 os_vm_address_t hard_guard_page_address
= CONTROL_STACK_HARD_GUARD_PAGE(th
);
2998 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2999 /* On these targets scrubbing from C is a bad idea, so we punt to
3000 * a routine in $ARCH-assem.S. */
3001 extern void arch_scrub_control_stack(struct thread
*, os_vm_address_t
, os_vm_address_t
);
3002 arch_scrub_control_stack(th
, guard_page_address
, hard_guard_page_address
);
3004 lispobj
*sp
= access_control_stack_pointer(th
);
3006 if ((((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
)) &&
3007 ((os_vm_address_t
)sp
>= hard_guard_page_address
)) ||
3008 (((os_vm_address_t
)sp
< (guard_page_address
+ os_vm_page_size
)) &&
3009 ((os_vm_address_t
)sp
>= guard_page_address
) &&
3010 (th
->control_stack_guard_page_protected
!= NIL
)))
3012 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
3015 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
3016 if ((os_vm_address_t
)sp
< (hard_guard_page_address
+ os_vm_page_size
))
3021 } while (((uword_t
)sp
--) & (BYTES_ZERO_BEFORE_END
- 1));
3025 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
3026 if ((os_vm_address_t
)sp
>= hard_guard_page_address
)
3031 } while (((uword_t
)++sp
) & (BYTES_ZERO_BEFORE_END
- 1));
3033 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
3036 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
3039 scavenge_control_stack(struct thread
*th
)
3041 lispobj
*object_ptr
;
3043 /* In order to properly support dynamic-extent allocation of
3044 * non-CONS objects, the control stack requires special handling.
3045 * Rather than calling scavenge() directly, grovel over it fixing
3046 * broken hearts, scavenging pointers to oldspace, and pitching a
3047 * fit when encountering unboxed data. This prevents stray object
3048 * headers from causing the scavenger to blow past the end of the
3049 * stack (an error case checked in scavenge()). We don't worry
3050 * about treating unboxed words as boxed or vice versa, because
3051 * the compiler isn't allowed to store unboxed objects on the
3052 * control stack. -- AB, 2011-Dec-02 */
3054 for (object_ptr
= th
->control_stack_start
;
3055 object_ptr
< access_control_stack_pointer(th
);
3058 lispobj object
= *object_ptr
;
3059 #ifdef LISP_FEATURE_GENCGC
3060 if (forwarding_pointer_p(object_ptr
))
3061 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
3062 object_ptr
, th
->control_stack_start
, access_control_stack_pointer(th
));
3064 if (is_lisp_pointer(object
) && from_space_p(object
)) {
3065 /* It currently points to old space. Check for a
3066 * forwarding pointer. */
3067 lispobj
*ptr
= native_pointer(object
);
3068 if (forwarding_pointer_p(ptr
)) {
3069 /* Yes, there's a forwarding pointer. */
3070 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
3072 /* Scavenge that pointer. */
3073 long n_words_scavenged
=
3074 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
3075 gc_assert(n_words_scavenged
== 1);
3077 } else if (scavtab
[widetag_of(object
)] == scav_lose
) {
3078 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
3079 object_ptr
, object
, th
->control_stack_start
, access_control_stack_pointer(th
));
3084 /* Scavenging Interrupt Contexts */
3086 static int boxed_registers
[] = BOXED_REGISTERS
;
3088 /* The GC has a notion of an "interior pointer" register, an unboxed
3089 * register that typically contains a pointer to inside an object
3090 * referenced by another pointer. The most obvious of these is the
3091 * program counter, although many compiler backends define a "Lisp
3092 * Interior Pointer" register known to the runtime as reg_LIP, and
3093 * various CPU architectures have other registers that also partake of
3094 * the interior-pointer nature. As the code for pairing an interior
3095 * pointer value up with its "base" register, and fixing it up after
3096 * scavenging is complete is horribly repetitive, a few macros paper
3097 * over the monotony. --AB, 2010-Jul-14 */
3099 /* These macros are only ever used over a lexical environment which
3100 * defines a pointer to an os_context_t called context, thus we don't
3101 * bother to pass that context in as a parameter. */
3103 /* Define how to access a given interior pointer. */
3104 #define ACCESS_INTERIOR_POINTER_pc \
3105 *os_context_pc_addr(context)
3106 #define ACCESS_INTERIOR_POINTER_lip \
3107 *os_context_register_addr(context, reg_LIP)
3108 #define ACCESS_INTERIOR_POINTER_lr \
3109 *os_context_lr_addr(context)
3110 #define ACCESS_INTERIOR_POINTER_npc \
3111 *os_context_npc_addr(context)
3112 #define ACCESS_INTERIOR_POINTER_ctr \
3113 *os_context_ctr_addr(context)
3115 #define INTERIOR_POINTER_VARS(name) \
3116 uword_t name##_offset; \
3117 int name##_register_pair
3119 #define PAIR_INTERIOR_POINTER(name) \
3120 pair_interior_pointer(context, \
3121 ACCESS_INTERIOR_POINTER_##name, \
3123 &name##_register_pair)
3125 /* One complexity here is that if a paired register is not found for
3126 * an interior pointer, then that pointer does not get updated.
3127 * Originally, there was some commentary about using an index of -1
3128 * when calling os_context_register_addr() on SPARC referring to the
3129 * program counter, but the real reason is to allow an interior
3130 * pointer register to point to the runtime, read-only space, or
3131 * static space without problems. */
3132 #define FIXUP_INTERIOR_POINTER(name) \
3134 if (name##_register_pair >= 0) { \
3135 ACCESS_INTERIOR_POINTER_##name = \
3136 (*os_context_register_addr(context, \
3137 name##_register_pair) \
3145 pair_interior_pointer(os_context_t
*context
, uword_t pointer
,
3146 uword_t
*saved_offset
, int *register_pair
)
3151 * I (RLT) think this is trying to find the boxed register that is
3152 * closest to the LIP address, without going past it. Usually, it's
3153 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
3155 /* 0x7FFFFFFF on 32-bit platforms;
3156 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
3157 *saved_offset
= (((uword_t
)1) << (N_WORD_BITS
- 1)) - 1;
3158 *register_pair
= -1;
3159 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3164 index
= boxed_registers
[i
];
3165 reg
= *os_context_register_addr(context
, index
);
3167 /* An interior pointer is never relative to a non-pointer
3168 * register (an oversight in the original implementation).
3169 * The simplest argument for why this is true is to consider
3170 * the fixnum that happens by coincide to be the word-index in
3171 * memory of the header for some object plus two. This is
3172 * happenstance would cause the register containing the fixnum
3173 * to be selected as the register_pair if the interior pointer
3174 * is to anywhere after the first two words of the object.
3175 * The fixnum won't be changed during GC, but the object might
3176 * move, thus destroying the interior pointer. --AB,
3179 if (is_lisp_pointer(reg
) &&
3180 ((reg
& ~LOWTAG_MASK
) <= pointer
)) {
3181 offset
= pointer
- (reg
& ~LOWTAG_MASK
);
3182 if (offset
< *saved_offset
) {
3183 *saved_offset
= offset
;
3184 *register_pair
= index
;
3191 scavenge_interrupt_context(os_context_t
* context
)
3195 /* FIXME: The various #ifdef noise here is precisely that: noise.
3196 * Is it possible to fold it into the macrology so that we have
3197 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
3198 * compile out for the registers that don't exist on a given
3201 INTERIOR_POINTER_VARS(pc
);
3203 INTERIOR_POINTER_VARS(lip
);
3205 #ifdef ARCH_HAS_LINK_REGISTER
3206 INTERIOR_POINTER_VARS(lr
);
3208 #ifdef ARCH_HAS_NPC_REGISTER
3209 INTERIOR_POINTER_VARS(npc
);
3211 #ifdef LISP_FEATURE_PPC
3212 INTERIOR_POINTER_VARS(ctr
);
3215 PAIR_INTERIOR_POINTER(pc
);
3217 PAIR_INTERIOR_POINTER(lip
);
3219 #ifdef ARCH_HAS_LINK_REGISTER
3220 PAIR_INTERIOR_POINTER(lr
);
3222 #ifdef ARCH_HAS_NPC_REGISTER
3223 PAIR_INTERIOR_POINTER(npc
);
3225 #ifdef LISP_FEATURE_PPC
3226 PAIR_INTERIOR_POINTER(ctr
);
3229 /* Scavenge all boxed registers in the context. */
3230 for (i
= 0; i
< (sizeof(boxed_registers
) / sizeof(int)); i
++) {
3234 index
= boxed_registers
[i
];
3235 foo
= *os_context_register_addr(context
, index
);
3237 *os_context_register_addr(context
, index
) = foo
;
3239 /* this is unlikely to work as intended on bigendian
3240 * 64 bit platforms */
3242 scavenge((lispobj
*) os_context_register_addr(context
, index
), 1);
3245 /* Now that the scavenging is done, repair the various interior
3247 FIXUP_INTERIOR_POINTER(pc
);
3249 FIXUP_INTERIOR_POINTER(lip
);
3251 #ifdef ARCH_HAS_LINK_REGISTER
3252 FIXUP_INTERIOR_POINTER(lr
);
3254 #ifdef ARCH_HAS_NPC_REGISTER
3255 FIXUP_INTERIOR_POINTER(npc
);
3257 #ifdef LISP_FEATURE_PPC
3258 FIXUP_INTERIOR_POINTER(ctr
);
3263 scavenge_interrupt_contexts(struct thread
*th
)
3266 os_context_t
*context
;
3268 index
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,th
));
3270 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3271 printf("Number of active contexts: %d\n", index
);
3274 for (i
= 0; i
< index
; i
++) {
3275 context
= th
->interrupt_contexts
[i
];
3276 scavenge_interrupt_context(context
);
3279 #endif /* x86oid targets */
3281 // The following accessors, which take a valid native pointer as input
3282 // and return a Lisp string, are designed to be foolproof during GC,
3283 // hence all the forwarding checks.
3285 #if defined(LISP_FEATURE_SB_LDB)
3286 #include "genesis/classoid.h"
3287 struct vector
* symbol_name(lispobj
* sym
)
3289 if (forwarding_pointer_p(sym
))
3290 sym
= native_pointer((lispobj
)forwarding_pointer_value(sym
));
3291 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
3293 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
3294 if (forwarding_pointer_p(name
))
3295 name
= native_pointer((lispobj
)forwarding_pointer_value(name
));
3296 return (struct vector
*)name
;
3298 struct vector
* classoid_name(lispobj
* classoid
)
3300 if (forwarding_pointer_p(classoid
))
3301 classoid
= native_pointer((lispobj
)forwarding_pointer_value(classoid
));
3302 lispobj sym
= ((struct classoid
*)classoid
)->name
;
3303 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
3304 : symbol_name(native_pointer(sym
));
3306 struct vector
* layout_classoid_name(lispobj
* layout
)
3308 if (forwarding_pointer_p(layout
))
3309 layout
= native_pointer((lispobj
)forwarding_pointer_value(layout
));
3310 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
3311 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
3312 : classoid_name(native_pointer(classoid
));
3314 struct vector
* instance_classoid_name(lispobj
* instance
)
3316 if (forwarding_pointer_p(instance
))
3317 instance
= native_pointer((lispobj
)forwarding_pointer_value(instance
));
3318 lispobj layout
= instance_layout(instance
);
3319 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
3320 : layout_classoid_name(native_pointer(layout
));
3322 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
3324 extern void show_lstring(struct vector
*, int, FILE*);
3325 if (forwarding_pointer_p((lispobj
*)string
))
3326 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
3328 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
3329 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
3331 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
3332 show_lstring(string
, quotes
, s
);
3334 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));