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>.
36 #include "interrupt.h"
42 #include "genesis/primitive-objects.h"
43 #include "genesis/static-symbols.h"
44 #include "genesis/layout.h"
45 #include "genesis/hash-table.h"
46 #include "gc-internal.h"
48 #ifdef LISP_FEATURE_SPARC
49 #define LONG_FLOAT_SIZE 4
51 #ifdef LISP_FEATURE_X86
52 #define LONG_FLOAT_SIZE 3
56 size_t dynamic_space_size
= DEFAULT_DYNAMIC_SPACE_SIZE
;
59 forwarding_pointer_p(lispobj
*pointer
) {
60 lispobj first_word
=*pointer
;
61 #ifdef LISP_FEATURE_GENCGC
62 return (first_word
== 0x01);
64 return (is_lisp_pointer(first_word
)
65 && new_space_p(first_word
));
69 static inline lispobj
*
70 forwarding_pointer_value(lispobj
*pointer
) {
71 #ifdef LISP_FEATURE_GENCGC
72 return (lispobj
*) ((pointer_sized_uint_t
) pointer
[1]);
74 return (lispobj
*) ((pointer_sized_uint_t
) pointer
[0]);
78 set_forwarding_pointer(lispobj
* pointer
, lispobj newspace_copy
) {
79 #ifdef LISP_FEATURE_GENCGC
81 pointer
[1]=newspace_copy
;
83 pointer
[0]=newspace_copy
;
88 long (*scavtab
[256])(lispobj
*where
, lispobj object
);
89 lispobj (*transother
[256])(lispobj object
);
90 long (*sizetab
[256])(lispobj
*where
);
91 struct weak_pointer
*weak_pointers
;
93 unsigned long bytes_consed_between_gcs
= 12*1024*1024;
100 /* to copy a boxed object */
102 copy_object(lispobj object
, long nwords
)
107 gc_assert(is_lisp_pointer(object
));
108 gc_assert(from_space_p(object
));
109 gc_assert((nwords
& 0x01) == 0);
111 /* Get tag of object. */
112 tag
= lowtag_of(object
);
114 /* Allocate space. */
115 new = gc_general_alloc(nwords
*N_WORD_BYTES
,ALLOC_BOXED
,ALLOC_QUICK
);
117 /* Copy the object. */
118 memcpy(new,native_pointer(object
),nwords
*N_WORD_BYTES
);
119 return make_lispobj(new,tag
);
122 static long scav_lose(lispobj
*where
, lispobj object
); /* forward decl */
124 /* FIXME: Most calls end up going to some trouble to compute an
125 * 'n_words' value for this function. The system might be a little
126 * simpler if this function used an 'end' parameter instead. */
128 scavenge(lispobj
*start
, long n_words
)
130 lispobj
*end
= start
+ n_words
;
132 long n_words_scavenged
;
134 for (object_ptr
= start
;
136 object_ptr
+= n_words_scavenged
) {
138 lispobj object
= *object_ptr
;
139 #ifdef LISP_FEATURE_GENCGC
140 if (forwarding_pointer_p(object_ptr
))
141 lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
142 object_ptr
, start
, n_words
);
144 if (is_lisp_pointer(object
)) {
145 if (from_space_p(object
)) {
146 /* It currently points to old space. Check for a
147 * forwarding pointer. */
148 lispobj
*ptr
= native_pointer(object
);
149 if (forwarding_pointer_p(ptr
)) {
150 /* Yes, there's a forwarding pointer. */
151 *object_ptr
= LOW_WORD(forwarding_pointer_value(ptr
));
152 n_words_scavenged
= 1;
154 /* Scavenge that pointer. */
156 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
159 /* It points somewhere other than oldspace. Leave it
161 n_words_scavenged
= 1;
164 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
165 /* This workaround is probably not needed for those ports
166 which don't have a partitioned register set (and therefore
167 scan the stack conservatively for roots). */
168 else if (n_words
== 1) {
169 /* there are some situations where an other-immediate may
170 end up in a descriptor register. I'm not sure whether
171 this is supposed to happen, but if it does then we
172 don't want to (a) barf or (b) scavenge over the
173 data-block, because there isn't one. So, if we're
174 checking a single word and it's anything other than a
175 pointer, just hush it up */
176 int widetag
= widetag_of(object
);
177 n_words_scavenged
= 1;
179 if ((scavtab
[widetag
] == scav_lose
) ||
180 (((sizetab
[widetag
])(object_ptr
)) > 1)) {
181 fprintf(stderr
,"warning: \
182 attempted to scavenge non-descriptor value %x at %p.\n\n\
183 If you can reproduce this warning, please send a bug report\n\
184 (see manual page for details).\n",
189 else if (fixnump(object
)) {
190 /* It's a fixnum: really easy.. */
191 n_words_scavenged
= 1;
193 /* It's some sort of header object or another. */
195 (scavtab
[widetag_of(object
)])(object_ptr
, object
);
198 gc_assert_verbose(object_ptr
== end
, "Final object pointer %p, start %p, end %p\n",
199 object_ptr
, start
, end
);
202 static lispobj
trans_fun_header(lispobj object
); /* forward decls */
203 static lispobj
trans_boxed(lispobj object
);
206 scav_fun_pointer(lispobj
*where
, lispobj object
)
208 lispobj
*first_pointer
;
211 gc_assert(is_lisp_pointer(object
));
213 /* Object is a pointer into from_space - not a FP. */
214 first_pointer
= (lispobj
*) native_pointer(object
);
216 /* must transport object -- object may point to either a function
217 * header, a closure function header, or to a closure header. */
219 switch (widetag_of(*first_pointer
)) {
220 case SIMPLE_FUN_HEADER_WIDETAG
:
221 copy
= trans_fun_header(object
);
224 copy
= trans_boxed(object
);
228 if (copy
!= object
) {
229 /* Set forwarding pointer */
230 set_forwarding_pointer(first_pointer
,copy
);
233 gc_assert(is_lisp_pointer(copy
));
234 gc_assert(!from_space_p(copy
));
243 trans_code(struct code
*code
)
245 struct code
*new_code
;
246 lispobj first
, l_code
, l_new_code
;
247 long nheader_words
, ncode_words
, nwords
;
248 unsigned long displacement
;
249 lispobj fheaderl
, *prev_pointer
;
251 /* if object has already been transported, just return pointer */
252 first
= code
->header
;
253 if (forwarding_pointer_p((lispobj
*)code
)) {
255 printf("Was already transported\n");
257 return (struct code
*) forwarding_pointer_value
258 ((lispobj
*)((pointer_sized_uint_t
) code
));
261 gc_assert(widetag_of(first
) == CODE_HEADER_WIDETAG
);
263 /* prepare to transport the code vector */
264 l_code
= (lispobj
) LOW_WORD(code
) | OTHER_POINTER_LOWTAG
;
266 ncode_words
= fixnum_value(code
->code_size
);
267 nheader_words
= HeaderValue(code
->header
);
268 nwords
= ncode_words
+ nheader_words
;
269 nwords
= CEILING(nwords
, 2);
271 l_new_code
= copy_object(l_code
, nwords
);
272 new_code
= (struct code
*) native_pointer(l_new_code
);
274 #if defined(DEBUG_CODE_GC)
275 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
276 (unsigned long) code
, (unsigned long) new_code
);
277 printf("Code object is %d words long.\n", nwords
);
280 #ifdef LISP_FEATURE_GENCGC
281 if (new_code
== code
)
285 displacement
= l_new_code
- l_code
;
287 set_forwarding_pointer((lispobj
*)code
, l_new_code
);
289 /* set forwarding pointers for all the function headers in the */
290 /* code object. also fix all self pointers */
292 fheaderl
= code
->entry_points
;
293 prev_pointer
= &new_code
->entry_points
;
295 while (fheaderl
!= NIL
) {
296 struct simple_fun
*fheaderp
, *nfheaderp
;
299 fheaderp
= (struct simple_fun
*) native_pointer(fheaderl
);
300 gc_assert(widetag_of(fheaderp
->header
) == SIMPLE_FUN_HEADER_WIDETAG
);
302 /* Calculate the new function pointer and the new */
303 /* function header. */
304 nfheaderl
= fheaderl
+ displacement
;
305 nfheaderp
= (struct simple_fun
*) native_pointer(nfheaderl
);
308 printf("fheaderp->header (at %x) <- %x\n",
309 &(fheaderp
->header
) , nfheaderl
);
311 set_forwarding_pointer((lispobj
*)fheaderp
, nfheaderl
);
313 /* fix self pointer. */
315 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
316 FUN_RAW_ADDR_OFFSET
+
320 *prev_pointer
= nfheaderl
;
322 fheaderl
= fheaderp
->next
;
323 prev_pointer
= &nfheaderp
->next
;
325 #ifdef LISP_FEATURE_GENCGC
326 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
327 spaces once when all copying is done. */
328 os_flush_icache((os_vm_address_t
) (((long *)new_code
) + nheader_words
),
329 ncode_words
* sizeof(long));
333 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
334 gencgc_apply_code_fixups(code
, new_code
);
341 scav_code_header(lispobj
*where
, lispobj object
)
344 long n_header_words
, n_code_words
, n_words
;
345 lispobj entry_point
; /* tagged pointer to entry point */
346 struct simple_fun
*function_ptr
; /* untagged pointer to entry point */
348 code
= (struct code
*) where
;
349 n_code_words
= fixnum_value(code
->code_size
);
350 n_header_words
= HeaderValue(object
);
351 n_words
= n_code_words
+ n_header_words
;
352 n_words
= CEILING(n_words
, 2);
354 /* Scavenge the boxed section of the code data block. */
355 scavenge(where
+ 1, n_header_words
- 1);
357 /* Scavenge the boxed section of each function object in the
358 * code data block. */
359 for (entry_point
= code
->entry_points
;
361 entry_point
= function_ptr
->next
) {
363 gc_assert_verbose(is_lisp_pointer(entry_point
),
364 "Entry point %lx\n is not a lisp pointer.",
367 function_ptr
= (struct simple_fun
*) native_pointer(entry_point
);
368 gc_assert(widetag_of(function_ptr
->header
)==SIMPLE_FUN_HEADER_WIDETAG
);
370 scavenge(&function_ptr
->name
, 1);
371 scavenge(&function_ptr
->arglist
, 1);
372 scavenge(&function_ptr
->type
, 1);
373 scavenge(&function_ptr
->xrefs
, 1);
380 trans_code_header(lispobj object
)
384 ncode
= trans_code((struct code
*) native_pointer(object
));
385 return (lispobj
) LOW_WORD(ncode
) | OTHER_POINTER_LOWTAG
;
390 size_code_header(lispobj
*where
)
393 long nheader_words
, ncode_words
, nwords
;
395 code
= (struct code
*) where
;
397 ncode_words
= fixnum_value(code
->code_size
);
398 nheader_words
= HeaderValue(code
->header
);
399 nwords
= ncode_words
+ nheader_words
;
400 nwords
= CEILING(nwords
, 2);
405 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
407 scav_return_pc_header(lispobj
*where
, lispobj object
)
409 lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
410 (unsigned long) where
,
411 (unsigned long) object
);
412 return 0; /* bogus return value to satisfy static type checking */
414 #endif /* LISP_FEATURE_X86 */
417 trans_return_pc_header(lispobj object
)
419 struct simple_fun
*return_pc
;
420 unsigned long offset
;
421 struct code
*code
, *ncode
;
423 return_pc
= (struct simple_fun
*) native_pointer(object
);
424 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
425 offset
= HeaderValue(return_pc
->header
) * N_WORD_BYTES
;
427 /* Transport the whole code object */
428 code
= (struct code
*) ((unsigned long) return_pc
- offset
);
429 ncode
= trans_code(code
);
431 return ((lispobj
) LOW_WORD(ncode
) + offset
) | OTHER_POINTER_LOWTAG
;
434 /* On the 386, closures hold a pointer to the raw address instead of the
435 * function object, so we can use CALL [$FDEFN+const] to invoke
436 * the function without loading it into a register. Given that code
437 * objects don't move, we don't need to update anything, but we do
438 * have to figure out that the function is still live. */
440 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
442 scav_closure_header(lispobj
*where
, lispobj object
)
444 struct closure
*closure
;
447 closure
= (struct closure
*)where
;
448 fun
= closure
->fun
- FUN_RAW_ADDR_OFFSET
;
450 #ifdef LISP_FEATURE_GENCGC
451 /* The function may have moved so update the raw address. But
452 * don't write unnecessarily. */
453 if (closure
->fun
!= fun
+ FUN_RAW_ADDR_OFFSET
)
454 closure
->fun
= fun
+ FUN_RAW_ADDR_OFFSET
;
460 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
462 scav_fun_header(lispobj
*where
, lispobj object
)
464 lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
465 (unsigned long) where
,
466 (unsigned long) object
);
467 return 0; /* bogus return value to satisfy static type checking */
469 #endif /* LISP_FEATURE_X86 */
472 trans_fun_header(lispobj object
)
474 struct simple_fun
*fheader
;
475 unsigned long offset
;
476 struct code
*code
, *ncode
;
478 fheader
= (struct simple_fun
*) native_pointer(object
);
479 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
480 offset
= HeaderValue(fheader
->header
) * N_WORD_BYTES
;
482 /* Transport the whole code object */
483 code
= (struct code
*) ((unsigned long) fheader
- offset
);
484 ncode
= trans_code(code
);
486 return ((lispobj
) LOW_WORD(ncode
) + offset
) | FUN_POINTER_LOWTAG
;
495 scav_instance_pointer(lispobj
*where
, lispobj object
)
497 lispobj copy
, *first_pointer
;
499 /* Object is a pointer into from space - not a FP. */
500 copy
= trans_boxed(object
);
502 #ifdef LISP_FEATURE_GENCGC
503 gc_assert(copy
!= object
);
506 first_pointer
= (lispobj
*) native_pointer(object
);
507 set_forwarding_pointer(first_pointer
,copy
);
518 static lispobj
trans_list(lispobj object
);
521 scav_list_pointer(lispobj
*where
, lispobj object
)
523 lispobj first
, *first_pointer
;
525 gc_assert(is_lisp_pointer(object
));
527 /* Object is a pointer into from space - not FP. */
528 first_pointer
= (lispobj
*) native_pointer(object
);
530 first
= trans_list(object
);
531 gc_assert(first
!= object
);
533 /* Set forwarding pointer */
534 set_forwarding_pointer(first_pointer
, first
);
536 gc_assert(is_lisp_pointer(first
));
537 gc_assert(!from_space_p(first
));
545 trans_list(lispobj object
)
547 lispobj new_list_pointer
;
548 struct cons
*cons
, *new_cons
;
551 cons
= (struct cons
*) native_pointer(object
);
554 new_cons
= (struct cons
*)
555 gc_general_alloc(sizeof(struct cons
),ALLOC_BOXED
,ALLOC_QUICK
);
556 new_cons
->car
= cons
->car
;
557 new_cons
->cdr
= cons
->cdr
; /* updated later */
558 new_list_pointer
= make_lispobj(new_cons
,lowtag_of(object
));
560 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
563 set_forwarding_pointer((lispobj
*)cons
, new_list_pointer
);
565 /* Try to linearize the list in the cdr direction to help reduce
569 struct cons
*cdr_cons
, *new_cdr_cons
;
571 if(lowtag_of(cdr
) != LIST_POINTER_LOWTAG
||
572 !from_space_p(cdr
) ||
573 forwarding_pointer_p((lispobj
*)native_pointer(cdr
)))
576 cdr_cons
= (struct cons
*) native_pointer(cdr
);
579 new_cdr_cons
= (struct cons
*)
580 gc_general_alloc(sizeof(struct cons
),ALLOC_BOXED
,ALLOC_QUICK
);
581 new_cdr_cons
->car
= cdr_cons
->car
;
582 new_cdr_cons
->cdr
= cdr_cons
->cdr
;
583 new_cdr
= make_lispobj(new_cdr_cons
, lowtag_of(cdr
));
585 /* Grab the cdr before it is clobbered. */
587 set_forwarding_pointer((lispobj
*)cdr_cons
, new_cdr
);
589 /* Update the cdr of the last cons copied into new space to
590 * keep the newspace scavenge from having to do it. */
591 new_cons
->cdr
= new_cdr
;
593 new_cons
= new_cdr_cons
;
596 return new_list_pointer
;
601 * scavenging and transporting other pointers
605 scav_other_pointer(lispobj
*where
, lispobj object
)
607 lispobj first
, *first_pointer
;
609 gc_assert(is_lisp_pointer(object
));
611 /* Object is a pointer into from space - not FP. */
612 first_pointer
= (lispobj
*) native_pointer(object
);
613 first
= (transother
[widetag_of(*first_pointer
)])(object
);
615 if (first
!= object
) {
616 set_forwarding_pointer(first_pointer
, first
);
617 #ifdef LISP_FEATURE_GENCGC
621 #ifndef LISP_FEATURE_GENCGC
624 gc_assert(is_lisp_pointer(first
));
625 gc_assert(!from_space_p(first
));
631 * immediate, boxed, and unboxed objects
635 size_pointer(lispobj
*where
)
641 scav_immediate(lispobj
*where
, lispobj object
)
647 trans_immediate(lispobj object
)
649 lose("trying to transport an immediate\n");
650 return NIL
; /* bogus return value to satisfy static type checking */
654 size_immediate(lispobj
*where
)
661 scav_boxed(lispobj
*where
, lispobj object
)
667 scav_instance(lispobj
*where
, lispobj object
)
670 long ntotal
= HeaderValue(object
);
671 lispobj layout
= ((struct instance
*)where
)->slots
[0];
675 if (forwarding_pointer_p(native_pointer(layout
)))
676 layout
= (lispobj
) forwarding_pointer_value(native_pointer(layout
));
678 nuntagged
= ((struct layout
*)native_pointer(layout
))->n_untagged_slots
;
679 scavenge(where
+ 1, ntotal
- fixnum_value(nuntagged
));
685 trans_boxed(lispobj object
)
688 unsigned long length
;
690 gc_assert(is_lisp_pointer(object
));
692 header
= *((lispobj
*) native_pointer(object
));
693 length
= HeaderValue(header
) + 1;
694 length
= CEILING(length
, 2);
696 return copy_object(object
, length
);
701 size_boxed(lispobj
*where
)
704 unsigned long length
;
707 length
= HeaderValue(header
) + 1;
708 length
= CEILING(length
, 2);
713 /* Note: on the sparc we don't have to do anything special for fdefns, */
714 /* 'cause the raw-addr has a function lowtag. */
715 #if !defined(LISP_FEATURE_SPARC)
717 scav_fdefn(lispobj
*where
, lispobj object
)
721 fdefn
= (struct fdefn
*)where
;
723 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
724 fdefn->fun, fdefn->raw_addr)); */
726 if ((char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
)
727 == (char *)((unsigned long)(fdefn
->raw_addr
))) {
728 scavenge(where
+ 1, sizeof(struct fdefn
)/sizeof(lispobj
) - 1);
730 /* Don't write unnecessarily. */
731 if (fdefn
->raw_addr
!= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
))
732 fdefn
->raw_addr
= (char *)(fdefn
->fun
+ FUN_RAW_ADDR_OFFSET
);
733 /* gc.c has more casts here, which may be relevant or alternatively
734 may be compiler warning defeaters. try
735 fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
737 return sizeof(struct fdefn
) / sizeof(lispobj
);
745 scav_unboxed(lispobj
*where
, lispobj object
)
747 unsigned long length
;
749 length
= HeaderValue(object
) + 1;
750 length
= CEILING(length
, 2);
756 trans_unboxed(lispobj object
)
759 unsigned long length
;
762 gc_assert(is_lisp_pointer(object
));
764 header
= *((lispobj
*) native_pointer(object
));
765 length
= HeaderValue(header
) + 1;
766 length
= CEILING(length
, 2);
768 return copy_unboxed_object(object
, length
);
772 size_unboxed(lispobj
*where
)
775 unsigned long length
;
778 length
= HeaderValue(header
) + 1;
779 length
= CEILING(length
, 2);
785 /* vector-like objects */
787 scav_base_string(lispobj
*where
, lispobj object
)
789 struct vector
*vector
;
792 /* NOTE: Strings contain one more byte of data than the length */
793 /* slot indicates. */
795 vector
= (struct vector
*) where
;
796 length
= fixnum_value(vector
->length
) + 1;
797 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
802 trans_base_string(lispobj object
)
804 struct vector
*vector
;
807 gc_assert(is_lisp_pointer(object
));
809 /* NOTE: A string contains one more byte of data (a terminating
810 * '\0' to help when interfacing with C functions) than indicated
811 * by the length slot. */
813 vector
= (struct vector
*) native_pointer(object
);
814 length
= fixnum_value(vector
->length
) + 1;
815 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
817 return copy_large_unboxed_object(object
, nwords
);
821 size_base_string(lispobj
*where
)
823 struct vector
*vector
;
826 /* NOTE: A string contains one more byte of data (a terminating
827 * '\0' to help when interfacing with C functions) than indicated
828 * by the length slot. */
830 vector
= (struct vector
*) where
;
831 length
= fixnum_value(vector
->length
) + 1;
832 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
838 scav_character_string(lispobj
*where
, lispobj object
)
840 struct vector
*vector
;
843 /* NOTE: Strings contain one more byte of data than the length */
844 /* slot indicates. */
846 vector
= (struct vector
*) where
;
847 length
= fixnum_value(vector
->length
) + 1;
848 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
853 trans_character_string(lispobj object
)
855 struct vector
*vector
;
858 gc_assert(is_lisp_pointer(object
));
860 /* NOTE: A string contains one more byte of data (a terminating
861 * '\0' to help when interfacing with C functions) than indicated
862 * by the length slot. */
864 vector
= (struct vector
*) native_pointer(object
);
865 length
= fixnum_value(vector
->length
) + 1;
866 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
868 return copy_large_unboxed_object(object
, nwords
);
872 size_character_string(lispobj
*where
)
874 struct vector
*vector
;
877 /* NOTE: A string contains one more byte of data (a terminating
878 * '\0' to help when interfacing with C functions) than indicated
879 * by the length slot. */
881 vector
= (struct vector
*) where
;
882 length
= fixnum_value(vector
->length
) + 1;
883 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
889 trans_vector(lispobj object
)
891 struct vector
*vector
;
894 gc_assert(is_lisp_pointer(object
));
896 vector
= (struct vector
*) native_pointer(object
);
898 length
= fixnum_value(vector
->length
);
899 nwords
= CEILING(length
+ 2, 2);
901 return copy_large_object(object
, nwords
);
905 size_vector(lispobj
*where
)
907 struct vector
*vector
;
910 vector
= (struct vector
*) where
;
911 length
= fixnum_value(vector
->length
);
912 nwords
= CEILING(length
+ 2, 2);
918 scav_vector_nil(lispobj
*where
, lispobj object
)
924 trans_vector_nil(lispobj object
)
926 gc_assert(is_lisp_pointer(object
));
927 return copy_unboxed_object(object
, 2);
931 size_vector_nil(lispobj
*where
)
933 /* Just the header word and the length word */
938 scav_vector_bit(lispobj
*where
, lispobj object
)
940 struct vector
*vector
;
943 vector
= (struct vector
*) where
;
944 length
= fixnum_value(vector
->length
);
945 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
951 trans_vector_bit(lispobj object
)
953 struct vector
*vector
;
956 gc_assert(is_lisp_pointer(object
));
958 vector
= (struct vector
*) native_pointer(object
);
959 length
= fixnum_value(vector
->length
);
960 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
962 return copy_large_unboxed_object(object
, nwords
);
966 size_vector_bit(lispobj
*where
)
968 struct vector
*vector
;
971 vector
= (struct vector
*) where
;
972 length
= fixnum_value(vector
->length
);
973 nwords
= CEILING(NWORDS(length
, 1) + 2, 2);
979 scav_vector_unsigned_byte_2(lispobj
*where
, lispobj object
)
981 struct vector
*vector
;
984 vector
= (struct vector
*) where
;
985 length
= fixnum_value(vector
->length
);
986 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
992 trans_vector_unsigned_byte_2(lispobj object
)
994 struct vector
*vector
;
997 gc_assert(is_lisp_pointer(object
));
999 vector
= (struct vector
*) native_pointer(object
);
1000 length
= fixnum_value(vector
->length
);
1001 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1003 return copy_large_unboxed_object(object
, nwords
);
1007 size_vector_unsigned_byte_2(lispobj
*where
)
1009 struct vector
*vector
;
1010 long length
, nwords
;
1012 vector
= (struct vector
*) where
;
1013 length
= fixnum_value(vector
->length
);
1014 nwords
= CEILING(NWORDS(length
, 2) + 2, 2);
1020 scav_vector_unsigned_byte_4(lispobj
*where
, lispobj object
)
1022 struct vector
*vector
;
1023 long length
, nwords
;
1025 vector
= (struct vector
*) where
;
1026 length
= fixnum_value(vector
->length
);
1027 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1033 trans_vector_unsigned_byte_4(lispobj object
)
1035 struct vector
*vector
;
1036 long length
, nwords
;
1038 gc_assert(is_lisp_pointer(object
));
1040 vector
= (struct vector
*) native_pointer(object
);
1041 length
= fixnum_value(vector
->length
);
1042 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1044 return copy_large_unboxed_object(object
, nwords
);
1047 size_vector_unsigned_byte_4(lispobj
*where
)
1049 struct vector
*vector
;
1050 long length
, nwords
;
1052 vector
= (struct vector
*) where
;
1053 length
= fixnum_value(vector
->length
);
1054 nwords
= CEILING(NWORDS(length
, 4) + 2, 2);
1061 scav_vector_unsigned_byte_8(lispobj
*where
, lispobj object
)
1063 struct vector
*vector
;
1064 long length
, nwords
;
1066 vector
= (struct vector
*) where
;
1067 length
= fixnum_value(vector
->length
);
1068 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1073 /*********************/
1078 trans_vector_unsigned_byte_8(lispobj object
)
1080 struct vector
*vector
;
1081 long length
, nwords
;
1083 gc_assert(is_lisp_pointer(object
));
1085 vector
= (struct vector
*) native_pointer(object
);
1086 length
= fixnum_value(vector
->length
);
1087 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1089 return copy_large_unboxed_object(object
, nwords
);
1093 size_vector_unsigned_byte_8(lispobj
*where
)
1095 struct vector
*vector
;
1096 long length
, nwords
;
1098 vector
= (struct vector
*) where
;
1099 length
= fixnum_value(vector
->length
);
1100 nwords
= CEILING(NWORDS(length
, 8) + 2, 2);
1107 scav_vector_unsigned_byte_16(lispobj
*where
, lispobj object
)
1109 struct vector
*vector
;
1110 long length
, nwords
;
1112 vector
= (struct vector
*) where
;
1113 length
= fixnum_value(vector
->length
);
1114 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1120 trans_vector_unsigned_byte_16(lispobj object
)
1122 struct vector
*vector
;
1123 long length
, nwords
;
1125 gc_assert(is_lisp_pointer(object
));
1127 vector
= (struct vector
*) native_pointer(object
);
1128 length
= fixnum_value(vector
->length
);
1129 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1131 return copy_large_unboxed_object(object
, nwords
);
1135 size_vector_unsigned_byte_16(lispobj
*where
)
1137 struct vector
*vector
;
1138 long length
, nwords
;
1140 vector
= (struct vector
*) where
;
1141 length
= fixnum_value(vector
->length
);
1142 nwords
= CEILING(NWORDS(length
, 16) + 2, 2);
1148 scav_vector_unsigned_byte_32(lispobj
*where
, lispobj object
)
1150 struct vector
*vector
;
1151 long length
, nwords
;
1153 vector
= (struct vector
*) where
;
1154 length
= fixnum_value(vector
->length
);
1155 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1161 trans_vector_unsigned_byte_32(lispobj object
)
1163 struct vector
*vector
;
1164 long length
, nwords
;
1166 gc_assert(is_lisp_pointer(object
));
1168 vector
= (struct vector
*) native_pointer(object
);
1169 length
= fixnum_value(vector
->length
);
1170 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1172 return copy_large_unboxed_object(object
, nwords
);
1176 size_vector_unsigned_byte_32(lispobj
*where
)
1178 struct vector
*vector
;
1179 long length
, nwords
;
1181 vector
= (struct vector
*) where
;
1182 length
= fixnum_value(vector
->length
);
1183 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1188 #if N_WORD_BITS == 64
1190 scav_vector_unsigned_byte_64(lispobj
*where
, lispobj object
)
1192 struct vector
*vector
;
1193 long length
, nwords
;
1195 vector
= (struct vector
*) where
;
1196 length
= fixnum_value(vector
->length
);
1197 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1203 trans_vector_unsigned_byte_64(lispobj object
)
1205 struct vector
*vector
;
1206 long length
, nwords
;
1208 gc_assert(is_lisp_pointer(object
));
1210 vector
= (struct vector
*) native_pointer(object
);
1211 length
= fixnum_value(vector
->length
);
1212 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1214 return copy_large_unboxed_object(object
, nwords
);
1218 size_vector_unsigned_byte_64(lispobj
*where
)
1220 struct vector
*vector
;
1221 long length
, nwords
;
1223 vector
= (struct vector
*) where
;
1224 length
= fixnum_value(vector
->length
);
1225 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1232 scav_vector_single_float(lispobj
*where
, lispobj object
)
1234 struct vector
*vector
;
1235 long length
, nwords
;
1237 vector
= (struct vector
*) where
;
1238 length
= fixnum_value(vector
->length
);
1239 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1245 trans_vector_single_float(lispobj object
)
1247 struct vector
*vector
;
1248 long length
, nwords
;
1250 gc_assert(is_lisp_pointer(object
));
1252 vector
= (struct vector
*) native_pointer(object
);
1253 length
= fixnum_value(vector
->length
);
1254 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1256 return copy_large_unboxed_object(object
, nwords
);
1260 size_vector_single_float(lispobj
*where
)
1262 struct vector
*vector
;
1263 long length
, nwords
;
1265 vector
= (struct vector
*) where
;
1266 length
= fixnum_value(vector
->length
);
1267 nwords
= CEILING(NWORDS(length
, 32) + 2, 2);
1273 scav_vector_double_float(lispobj
*where
, lispobj object
)
1275 struct vector
*vector
;
1276 long length
, nwords
;
1278 vector
= (struct vector
*) where
;
1279 length
= fixnum_value(vector
->length
);
1280 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1286 trans_vector_double_float(lispobj object
)
1288 struct vector
*vector
;
1289 long length
, nwords
;
1291 gc_assert(is_lisp_pointer(object
));
1293 vector
= (struct vector
*) native_pointer(object
);
1294 length
= fixnum_value(vector
->length
);
1295 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1297 return copy_large_unboxed_object(object
, nwords
);
1301 size_vector_double_float(lispobj
*where
)
1303 struct vector
*vector
;
1304 long length
, nwords
;
1306 vector
= (struct vector
*) where
;
1307 length
= fixnum_value(vector
->length
);
1308 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1313 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1315 scav_vector_long_float(lispobj
*where
, lispobj object
)
1317 struct vector
*vector
;
1318 long length
, nwords
;
1320 vector
= (struct vector
*) where
;
1321 length
= fixnum_value(vector
->length
);
1322 nwords
= CEILING(length
*
1329 trans_vector_long_float(lispobj object
)
1331 struct vector
*vector
;
1332 long length
, nwords
;
1334 gc_assert(is_lisp_pointer(object
));
1336 vector
= (struct vector
*) native_pointer(object
);
1337 length
= fixnum_value(vector
->length
);
1338 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1340 return copy_large_unboxed_object(object
, nwords
);
1344 size_vector_long_float(lispobj
*where
)
1346 struct vector
*vector
;
1347 long length
, nwords
;
1349 vector
= (struct vector
*) where
;
1350 length
= fixnum_value(vector
->length
);
1351 nwords
= CEILING(length
* LONG_FLOAT_SIZE
+ 2, 2);
1358 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1360 scav_vector_complex_single_float(lispobj
*where
, lispobj object
)
1362 struct vector
*vector
;
1363 long length
, nwords
;
1365 vector
= (struct vector
*) where
;
1366 length
= fixnum_value(vector
->length
);
1367 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1373 trans_vector_complex_single_float(lispobj object
)
1375 struct vector
*vector
;
1376 long length
, nwords
;
1378 gc_assert(is_lisp_pointer(object
));
1380 vector
= (struct vector
*) native_pointer(object
);
1381 length
= fixnum_value(vector
->length
);
1382 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1384 return copy_large_unboxed_object(object
, nwords
);
1388 size_vector_complex_single_float(lispobj
*where
)
1390 struct vector
*vector
;
1391 long length
, nwords
;
1393 vector
= (struct vector
*) where
;
1394 length
= fixnum_value(vector
->length
);
1395 nwords
= CEILING(NWORDS(length
, 64) + 2, 2);
1401 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1403 scav_vector_complex_double_float(lispobj
*where
, lispobj object
)
1405 struct vector
*vector
;
1406 long length
, nwords
;
1408 vector
= (struct vector
*) where
;
1409 length
= fixnum_value(vector
->length
);
1410 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1416 trans_vector_complex_double_float(lispobj object
)
1418 struct vector
*vector
;
1419 long length
, nwords
;
1421 gc_assert(is_lisp_pointer(object
));
1423 vector
= (struct vector
*) native_pointer(object
);
1424 length
= fixnum_value(vector
->length
);
1425 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1427 return copy_large_unboxed_object(object
, nwords
);
1431 size_vector_complex_double_float(lispobj
*where
)
1433 struct vector
*vector
;
1434 long length
, nwords
;
1436 vector
= (struct vector
*) where
;
1437 length
= fixnum_value(vector
->length
);
1438 nwords
= CEILING(NWORDS(length
, 128) + 2, 2);
1445 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1447 scav_vector_complex_long_float(lispobj
*where
, lispobj object
)
1449 struct vector
*vector
;
1450 long length
, nwords
;
1452 vector
= (struct vector
*) where
;
1453 length
= fixnum_value(vector
->length
);
1454 nwords
= CEILING(length
* (2* LONG_FLOAT_SIZE
) + 2, 2);
1460 trans_vector_complex_long_float(lispobj object
)
1462 struct vector
*vector
;
1463 long length
, nwords
;
1465 gc_assert(is_lisp_pointer(object
));
1467 vector
= (struct vector
*) native_pointer(object
);
1468 length
= fixnum_value(vector
->length
);
1469 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1471 return copy_large_unboxed_object(object
, nwords
);
1475 size_vector_complex_long_float(lispobj
*where
)
1477 struct vector
*vector
;
1478 long length
, nwords
;
1480 vector
= (struct vector
*) where
;
1481 length
= fixnum_value(vector
->length
);
1482 nwords
= CEILING(length
* (2*LONG_FLOAT_SIZE
) + 2, 2);
1488 #define WEAK_POINTER_NWORDS \
1489 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1492 trans_weak_pointer(lispobj object
)
1495 #ifndef LISP_FEATURE_GENCGC
1496 struct weak_pointer
*wp
;
1498 gc_assert(is_lisp_pointer(object
));
1500 #if defined(DEBUG_WEAK)
1501 printf("Transporting weak pointer from 0x%08x\n", object
);
1504 /* Need to remember where all the weak pointers are that have */
1505 /* been transported so they can be fixed up in a post-GC pass. */
1507 copy
= copy_object(object
, WEAK_POINTER_NWORDS
);
1508 #ifndef LISP_FEATURE_GENCGC
1509 wp
= (struct weak_pointer
*) native_pointer(copy
);
1511 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1512 /* Push the weak pointer onto the list of weak pointers. */
1513 wp
->next
= (struct weak_pointer
*)LOW_WORD(weak_pointers
);
1520 size_weak_pointer(lispobj
*where
)
1522 return WEAK_POINTER_NWORDS
;
1526 void scan_weak_pointers(void)
1528 struct weak_pointer
*wp
, *next_wp
;
1529 for (wp
= weak_pointers
, next_wp
= NULL
; wp
!= NULL
; wp
= next_wp
) {
1530 lispobj value
= wp
->value
;
1531 lispobj
*first_pointer
;
1532 gc_assert(widetag_of(wp
->header
)==WEAK_POINTER_WIDETAG
);
1536 if (next_wp
== wp
) /* gencgc uses a ref to self for end of list */
1539 if (!(is_lisp_pointer(value
) && from_space_p(value
)))
1542 /* Now, we need to check whether the object has been forwarded. If
1543 * it has been, the weak pointer is still good and needs to be
1544 * updated. Otherwise, the weak pointer needs to be nil'ed
1547 first_pointer
= (lispobj
*)native_pointer(value
);
1549 if (forwarding_pointer_p(first_pointer
)) {
1551 (lispobj
)LOW_WORD(forwarding_pointer_value(first_pointer
));
1563 #if N_WORD_BITS == 32
1564 #define EQ_HASH_MASK 0x1fffffff
1565 #elif N_WORD_BITS == 64
1566 #define EQ_HASH_MASK 0x1fffffffffffffff
1569 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1570 * target-hash-table.lisp. */
1571 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1573 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1574 * slot. Set to NULL at the end of a collection.
1576 * This is not optimal because, when a table is tenured, it won't be
1577 * processed automatically; only the yougest generation is GC'd by
1578 * default. On the other hand, all applications will need an
1579 * occasional full GC anyway, so it's not that bad either. */
1580 struct hash_table
*weak_hash_tables
= NULL
;
1582 /* Return true if OBJ has already survived the current GC. */
1584 survived_gc_yet (lispobj obj
)
1586 return (!is_lisp_pointer(obj
) || !from_space_p(obj
) ||
1587 forwarding_pointer_p(native_pointer(obj
)));
1591 weak_hash_entry_alivep (lispobj weakness
, lispobj key
, lispobj value
)
1595 return survived_gc_yet(key
);
1597 return survived_gc_yet(value
);
1599 return (survived_gc_yet(key
) || survived_gc_yet(value
));
1601 return (survived_gc_yet(key
) && survived_gc_yet(value
));
1604 /* Shut compiler up. */
1609 /* Return the beginning of data in ARRAY (skipping the header and the
1610 * length) or NULL if it isn't an array of the specified widetag after
1612 static inline lispobj
*
1613 get_array_data (lispobj array
, int widetag
, unsigned long *length
)
1615 if (is_lisp_pointer(array
) &&
1616 (widetag_of(*(lispobj
*)native_pointer(array
)) == widetag
)) {
1618 *length
= fixnum_value(((lispobj
*)native_pointer(array
))[1]);
1619 return ((lispobj
*)native_pointer(array
)) + 2;
1625 /* Only need to worry about scavenging the _real_ entries in the
1626 * table. Phantom entries such as the hash table itself at index 0 and
1627 * the empty marker at index 1 were scavenged by scav_vector that
1628 * either called this function directly or arranged for it to be
1629 * called later by pushing the hash table onto weak_hash_tables. */
1631 scav_hash_table_entries (struct hash_table
*hash_table
)
1634 unsigned long kv_length
;
1635 lispobj
*index_vector
;
1636 unsigned long length
;
1637 lispobj
*next_vector
;
1638 unsigned long next_vector_length
;
1639 lispobj
*hash_vector
;
1640 unsigned long hash_vector_length
;
1641 lispobj empty_symbol
;
1642 lispobj weakness
= hash_table
->weakness
;
1645 kv_vector
= get_array_data(hash_table
->table
,
1646 SIMPLE_VECTOR_WIDETAG
, &kv_length
);
1647 if (kv_vector
== NULL
)
1648 lose("invalid kv_vector %x\n", hash_table
->table
);
1650 index_vector
= get_array_data(hash_table
->index_vector
,
1651 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1652 if (index_vector
== NULL
)
1653 lose("invalid index_vector %x\n", hash_table
->index_vector
);
1655 next_vector
= get_array_data(hash_table
->next_vector
,
1656 SIMPLE_ARRAY_WORD_WIDETAG
,
1657 &next_vector_length
);
1658 if (next_vector
== NULL
)
1659 lose("invalid next_vector %x\n", hash_table
->next_vector
);
1661 hash_vector
= get_array_data(hash_table
->hash_vector
,
1662 SIMPLE_ARRAY_WORD_WIDETAG
,
1663 &hash_vector_length
);
1664 if (hash_vector
!= NULL
)
1665 gc_assert(hash_vector_length
== next_vector_length
);
1667 /* These lengths could be different as the index_vector can be a
1668 * different length from the others, a larger index_vector could
1669 * help reduce collisions. */
1670 gc_assert(next_vector_length
*2 == kv_length
);
1672 empty_symbol
= kv_vector
[1];
1673 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1674 if (widetag_of(*(lispobj
*)native_pointer(empty_symbol
)) !=
1675 SYMBOL_HEADER_WIDETAG
) {
1676 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1677 *(lispobj
*)native_pointer(empty_symbol
));
1680 /* Work through the KV vector. */
1681 for (i
= 1; i
< next_vector_length
; i
++) {
1682 lispobj old_key
= kv_vector
[2*i
];
1683 lispobj value
= kv_vector
[2*i
+1];
1684 if ((weakness
== NIL
) ||
1685 weak_hash_entry_alivep(weakness
, old_key
, value
)) {
1687 /* Scavenge the key and value. */
1688 scavenge(&kv_vector
[2*i
],2);
1690 /* If an EQ-based key has moved, mark the hash-table for
1692 if (!hash_vector
|| hash_vector
[i
] == MAGIC_HASH_VECTOR_VALUE
) {
1693 lispobj new_key
= kv_vector
[2*i
];
1695 if (old_key
!= new_key
&& new_key
!= empty_symbol
) {
1696 hash_table
->needs_rehash_p
= T
;
1704 scav_vector (lispobj
*where
, lispobj object
)
1706 unsigned long kv_length
;
1708 struct hash_table
*hash_table
;
1710 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1711 * hash tables in the Lisp HASH-TABLE code to indicate need for
1712 * special GC support. */
1713 if (HeaderValue(object
) == subtype_VectorNormal
)
1716 kv_length
= fixnum_value(where
[1]);
1717 kv_vector
= where
+ 2; /* Skip the header and length. */
1718 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1720 /* Scavenge element 0, which may be a hash-table structure. */
1721 scavenge(where
+2, 1);
1722 if (!is_lisp_pointer(where
[2])) {
1723 /* This'll happen when REHASH clears the header of old-kv-vector
1724 * and fills it with zero, but some other thread simulatenously
1725 * sets the header in %%PUTHASH.
1728 "Warning: no pointer at %lx in hash table: this indicates "
1729 "non-fatal corruption caused by concurrent access to a "
1730 "hash-table from multiple threads. Any accesses to "
1731 "hash-tables shared between threads should be protected "
1732 "by locks.\n", (unsigned long)&where
[2]);
1733 // We've scavenged three words.
1736 hash_table
= (struct hash_table
*)native_pointer(where
[2]);
1737 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1738 if (widetag_of(hash_table
->header
) != INSTANCE_HEADER_WIDETAG
) {
1739 lose("hash table not instance (%x at %x)\n",
1744 /* Scavenge element 1, which should be some internal symbol that
1745 * the hash table code reserves for marking empty slots. */
1746 scavenge(where
+3, 1);
1747 if (!is_lisp_pointer(where
[3])) {
1748 lose("not empty-hash-table-slot symbol pointer: %x\n", where
[3]);
1751 /* Scavenge hash table, which will fix the positions of the other
1752 * needed objects. */
1753 scavenge((lispobj
*)hash_table
,
1754 sizeof(struct hash_table
) / sizeof(lispobj
));
1756 /* Cross-check the kv_vector. */
1757 if (where
!= (lispobj
*)native_pointer(hash_table
->table
)) {
1758 lose("hash_table table!=this table %x\n", hash_table
->table
);
1761 if (hash_table
->weakness
== NIL
) {
1762 scav_hash_table_entries(hash_table
);
1764 /* Delay scavenging of this table by pushing it onto
1765 * weak_hash_tables (if it's not there already) for the weak
1767 if (hash_table
->next_weak_hash_table
== NIL
) {
1768 hash_table
->next_weak_hash_table
= (lispobj
)weak_hash_tables
;
1769 weak_hash_tables
= hash_table
;
1773 return (CEILING(kv_length
+ 2, 2));
1777 scav_weak_hash_tables (void)
1779 struct hash_table
*table
;
1781 /* Scavenge entries whose triggers are known to survive. */
1782 for (table
= weak_hash_tables
; table
!= NULL
;
1783 table
= (struct hash_table
*)table
->next_weak_hash_table
) {
1784 scav_hash_table_entries(table
);
1788 /* Walk through the chain whose first element is *FIRST and remove
1789 * dead weak entries. */
1791 scan_weak_hash_table_chain (struct hash_table
*hash_table
, lispobj
*prev
,
1792 lispobj
*kv_vector
, lispobj
*index_vector
,
1793 lispobj
*next_vector
, lispobj
*hash_vector
,
1794 lispobj empty_symbol
, lispobj weakness
)
1796 unsigned index
= *prev
;
1798 unsigned next
= next_vector
[index
];
1799 lispobj key
= kv_vector
[2 * index
];
1800 lispobj value
= kv_vector
[2 * index
+ 1];
1801 gc_assert(key
!= empty_symbol
);
1802 gc_assert(value
!= empty_symbol
);
1803 if (!weak_hash_entry_alivep(weakness
, key
, value
)) {
1804 unsigned count
= fixnum_value(hash_table
->number_entries
);
1805 gc_assert(count
> 0);
1807 hash_table
->number_entries
= make_fixnum(count
- 1);
1808 next_vector
[index
] = fixnum_value(hash_table
->next_free_kv
);
1809 hash_table
->next_free_kv
= make_fixnum(index
);
1810 kv_vector
[2 * index
] = empty_symbol
;
1811 kv_vector
[2 * index
+ 1] = empty_symbol
;
1813 hash_vector
[index
] = MAGIC_HASH_VECTOR_VALUE
;
1815 prev
= &next_vector
[index
];
1822 scan_weak_hash_table (struct hash_table
*hash_table
)
1825 lispobj
*index_vector
;
1826 unsigned long length
= 0; /* prevent warning */
1827 lispobj
*next_vector
;
1828 unsigned long next_vector_length
= 0; /* prevent warning */
1829 lispobj
*hash_vector
;
1830 lispobj empty_symbol
;
1831 lispobj weakness
= hash_table
->weakness
;
1834 kv_vector
= get_array_data(hash_table
->table
,
1835 SIMPLE_VECTOR_WIDETAG
, NULL
);
1836 index_vector
= get_array_data(hash_table
->index_vector
,
1837 SIMPLE_ARRAY_WORD_WIDETAG
, &length
);
1838 next_vector
= get_array_data(hash_table
->next_vector
,
1839 SIMPLE_ARRAY_WORD_WIDETAG
,
1840 &next_vector_length
);
1841 hash_vector
= get_array_data(hash_table
->hash_vector
,
1842 SIMPLE_ARRAY_WORD_WIDETAG
, NULL
);
1843 empty_symbol
= kv_vector
[1];
1845 for (i
= 0; i
< length
; i
++) {
1846 scan_weak_hash_table_chain(hash_table
, &index_vector
[i
],
1847 kv_vector
, index_vector
, next_vector
,
1848 hash_vector
, empty_symbol
, weakness
);
1852 /* Remove dead entries from weak hash tables. */
1854 scan_weak_hash_tables (void)
1856 struct hash_table
*table
, *next
;
1858 for (table
= weak_hash_tables
; table
!= NULL
; table
= next
) {
1859 next
= (struct hash_table
*)table
->next_weak_hash_table
;
1860 table
->next_weak_hash_table
= NIL
;
1861 scan_weak_hash_table(table
);
1864 weak_hash_tables
= NULL
;
1873 scav_lose(lispobj
*where
, lispobj object
)
1875 lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1876 (unsigned long)object
,
1877 widetag_of(*(lispobj
*)native_pointer(object
)));
1879 return 0; /* bogus return value to satisfy static type checking */
1883 trans_lose(lispobj object
)
1885 lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1886 (unsigned long)object
,
1887 widetag_of(*(lispobj
*)native_pointer(object
)));
1888 return NIL
; /* bogus return value to satisfy static type checking */
1892 size_lose(lispobj
*where
)
1894 lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1895 (unsigned long)where
,
1896 widetag_of(LOW_WORD(where
)));
1897 return 1; /* bogus return value to satisfy static type checking */
1906 gc_init_tables(void)
1910 /* Set default value in all slots of scavenge table. FIXME
1911 * replace this gnarly sizeof with something based on
1913 for (i
= 0; i
< ((sizeof scavtab
)/(sizeof scavtab
[0])); i
++) {
1914 scavtab
[i
] = scav_lose
;
1917 /* For each type which can be selected by the lowtag alone, set
1918 * multiple entries in our widetag scavenge table (one for each
1919 * possible value of the high bits).
1922 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
1923 scavtab
[EVEN_FIXNUM_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
1924 scavtab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_fun_pointer
;
1925 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1926 scavtab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_list_pointer
;
1927 scavtab
[ODD_FIXNUM_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_immediate
;
1928 scavtab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_instance_pointer
;
1929 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1930 scavtab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = scav_other_pointer
;
1933 /* Other-pointer types (those selected by all eight bits of the
1934 * tag) get one entry each in the scavenge table. */
1935 scavtab
[BIGNUM_WIDETAG
] = scav_unboxed
;
1936 scavtab
[RATIO_WIDETAG
] = scav_boxed
;
1937 #if N_WORD_BITS == 64
1938 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_immediate
;
1940 scavtab
[SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
1942 scavtab
[DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
1943 #ifdef LONG_FLOAT_WIDETAG
1944 scavtab
[LONG_FLOAT_WIDETAG
] = scav_unboxed
;
1946 scavtab
[COMPLEX_WIDETAG
] = scav_boxed
;
1947 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1948 scavtab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = scav_unboxed
;
1950 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1951 scavtab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = scav_unboxed
;
1953 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1954 scavtab
[COMPLEX_LONG_FLOAT_WIDETAG
] = scav_unboxed
;
1956 scavtab
[SIMPLE_ARRAY_WIDETAG
] = scav_boxed
;
1957 scavtab
[SIMPLE_BASE_STRING_WIDETAG
] = scav_base_string
;
1958 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1959 scavtab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = scav_character_string
;
1961 scavtab
[SIMPLE_BIT_VECTOR_WIDETAG
] = scav_vector_bit
;
1962 scavtab
[SIMPLE_ARRAY_NIL_WIDETAG
] = scav_vector_nil
;
1963 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
1964 scav_vector_unsigned_byte_2
;
1965 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
1966 scav_vector_unsigned_byte_4
;
1967 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
1968 scav_vector_unsigned_byte_8
;
1969 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
1970 scav_vector_unsigned_byte_8
;
1971 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
1972 scav_vector_unsigned_byte_16
;
1973 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
1974 scav_vector_unsigned_byte_16
;
1975 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
1976 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
] =
1977 scav_vector_unsigned_byte_32
;
1979 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
1980 scav_vector_unsigned_byte_32
;
1981 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
1982 scav_vector_unsigned_byte_32
;
1983 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
1984 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
] =
1985 scav_vector_unsigned_byte_64
;
1987 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1988 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
1989 scav_vector_unsigned_byte_64
;
1991 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1992 scavtab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
1993 scav_vector_unsigned_byte_64
;
1995 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1996 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = scav_vector_unsigned_byte_8
;
1998 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1999 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2000 scav_vector_unsigned_byte_16
;
2002 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2003 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
] =
2004 scav_vector_unsigned_byte_32
;
2006 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2007 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2008 scav_vector_unsigned_byte_32
;
2010 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2011 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
] =
2012 scav_vector_unsigned_byte_64
;
2014 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2015 scavtab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2016 scav_vector_unsigned_byte_64
;
2018 scavtab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = scav_vector_single_float
;
2019 scavtab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = scav_vector_double_float
;
2020 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2021 scavtab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = scav_vector_long_float
;
2023 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2024 scavtab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2025 scav_vector_complex_single_float
;
2027 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2028 scavtab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2029 scav_vector_complex_double_float
;
2031 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2032 scavtab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2033 scav_vector_complex_long_float
;
2035 scavtab
[COMPLEX_BASE_STRING_WIDETAG
] = scav_boxed
;
2036 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2037 scavtab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = scav_boxed
;
2039 scavtab
[COMPLEX_VECTOR_NIL_WIDETAG
] = scav_boxed
;
2040 scavtab
[COMPLEX_BIT_VECTOR_WIDETAG
] = scav_boxed
;
2041 scavtab
[COMPLEX_VECTOR_WIDETAG
] = scav_boxed
;
2042 scavtab
[COMPLEX_ARRAY_WIDETAG
] = scav_boxed
;
2043 scavtab
[CODE_HEADER_WIDETAG
] = scav_code_header
;
2044 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2045 scavtab
[SIMPLE_FUN_HEADER_WIDETAG
] = scav_fun_header
;
2046 scavtab
[RETURN_PC_HEADER_WIDETAG
] = scav_return_pc_header
;
2048 scavtab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = scav_boxed
;
2049 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2050 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_closure_header
;
2052 scavtab
[CLOSURE_HEADER_WIDETAG
] = scav_boxed
;
2054 scavtab
[VALUE_CELL_HEADER_WIDETAG
] = scav_boxed
;
2055 scavtab
[SYMBOL_HEADER_WIDETAG
] = scav_boxed
;
2056 scavtab
[CHARACTER_WIDETAG
] = scav_immediate
;
2057 scavtab
[SAP_WIDETAG
] = scav_unboxed
;
2058 scavtab
[UNBOUND_MARKER_WIDETAG
] = scav_immediate
;
2059 scavtab
[NO_TLS_VALUE_MARKER_WIDETAG
] = scav_immediate
;
2060 scavtab
[INSTANCE_HEADER_WIDETAG
] = scav_instance
;
2061 #if defined(LISP_FEATURE_SPARC)
2062 scavtab
[FDEFN_WIDETAG
] = scav_boxed
;
2064 scavtab
[FDEFN_WIDETAG
] = scav_fdefn
;
2066 scavtab
[SIMPLE_VECTOR_WIDETAG
] = scav_vector
;
2068 /* transport other table, initialized same way as scavtab */
2069 for (i
= 0; i
< ((sizeof transother
)/(sizeof transother
[0])); i
++)
2070 transother
[i
] = trans_lose
;
2071 transother
[BIGNUM_WIDETAG
] = trans_unboxed
;
2072 transother
[RATIO_WIDETAG
] = trans_boxed
;
2074 #if N_WORD_BITS == 64
2075 transother
[SINGLE_FLOAT_WIDETAG
] = trans_immediate
;
2077 transother
[SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2079 transother
[DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2080 #ifdef LONG_FLOAT_WIDETAG
2081 transother
[LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2083 transother
[COMPLEX_WIDETAG
] = trans_boxed
;
2084 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2085 transother
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = trans_unboxed
;
2087 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2088 transother
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = trans_unboxed
;
2090 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2091 transother
[COMPLEX_LONG_FLOAT_WIDETAG
] = trans_unboxed
;
2093 transother
[SIMPLE_ARRAY_WIDETAG
] = trans_boxed
; /* but not GENCGC */
2094 transother
[SIMPLE_BASE_STRING_WIDETAG
] = trans_base_string
;
2095 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2096 transother
[SIMPLE_CHARACTER_STRING_WIDETAG
] = trans_character_string
;
2098 transother
[SIMPLE_BIT_VECTOR_WIDETAG
] = trans_vector_bit
;
2099 transother
[SIMPLE_VECTOR_WIDETAG
] = trans_vector
;
2100 transother
[SIMPLE_ARRAY_NIL_WIDETAG
] = trans_vector_nil
;
2101 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2102 trans_vector_unsigned_byte_2
;
2103 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2104 trans_vector_unsigned_byte_4
;
2105 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2106 trans_vector_unsigned_byte_8
;
2107 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2108 trans_vector_unsigned_byte_8
;
2109 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2110 trans_vector_unsigned_byte_16
;
2111 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2112 trans_vector_unsigned_byte_16
;
2113 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2114 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
] =
2115 trans_vector_unsigned_byte_32
;
2117 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2118 trans_vector_unsigned_byte_32
;
2119 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2120 trans_vector_unsigned_byte_32
;
2121 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2122 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
] =
2123 trans_vector_unsigned_byte_64
;
2125 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2126 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2127 trans_vector_unsigned_byte_64
;
2129 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2130 transother
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2131 trans_vector_unsigned_byte_64
;
2133 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2134 transother
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] =
2135 trans_vector_unsigned_byte_8
;
2137 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2138 transother
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2139 trans_vector_unsigned_byte_16
;
2141 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2142 transother
[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
] =
2143 trans_vector_unsigned_byte_32
;
2145 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2146 transother
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2147 trans_vector_unsigned_byte_32
;
2149 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2150 transother
[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
] =
2151 trans_vector_unsigned_byte_64
;
2153 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2154 transother
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2155 trans_vector_unsigned_byte_64
;
2157 transother
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] =
2158 trans_vector_single_float
;
2159 transother
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] =
2160 trans_vector_double_float
;
2161 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2162 transother
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] =
2163 trans_vector_long_float
;
2165 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2166 transother
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2167 trans_vector_complex_single_float
;
2169 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2170 transother
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2171 trans_vector_complex_double_float
;
2173 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2174 transother
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2175 trans_vector_complex_long_float
;
2177 transother
[COMPLEX_BASE_STRING_WIDETAG
] = trans_boxed
;
2178 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2179 transother
[COMPLEX_CHARACTER_STRING_WIDETAG
] = trans_boxed
;
2181 transother
[COMPLEX_BIT_VECTOR_WIDETAG
] = trans_boxed
;
2182 transother
[COMPLEX_VECTOR_NIL_WIDETAG
] = trans_boxed
;
2183 transother
[COMPLEX_VECTOR_WIDETAG
] = trans_boxed
;
2184 transother
[COMPLEX_ARRAY_WIDETAG
] = trans_boxed
;
2185 transother
[CODE_HEADER_WIDETAG
] = trans_code_header
;
2186 transother
[SIMPLE_FUN_HEADER_WIDETAG
] = trans_fun_header
;
2187 transother
[RETURN_PC_HEADER_WIDETAG
] = trans_return_pc_header
;
2188 transother
[CLOSURE_HEADER_WIDETAG
] = trans_boxed
;
2189 transother
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = trans_boxed
;
2190 transother
[VALUE_CELL_HEADER_WIDETAG
] = trans_boxed
;
2191 transother
[SYMBOL_HEADER_WIDETAG
] = trans_boxed
;
2192 transother
[CHARACTER_WIDETAG
] = trans_immediate
;
2193 transother
[SAP_WIDETAG
] = trans_unboxed
;
2194 transother
[UNBOUND_MARKER_WIDETAG
] = trans_immediate
;
2195 transother
[NO_TLS_VALUE_MARKER_WIDETAG
] = trans_immediate
;
2196 transother
[WEAK_POINTER_WIDETAG
] = trans_weak_pointer
;
2197 transother
[INSTANCE_HEADER_WIDETAG
] = trans_boxed
;
2198 transother
[FDEFN_WIDETAG
] = trans_boxed
;
2200 /* size table, initialized the same way as scavtab */
2201 for (i
= 0; i
< ((sizeof sizetab
)/(sizeof sizetab
[0])); i
++)
2202 sizetab
[i
] = size_lose
;
2203 for (i
= 0; i
< (1<<(N_WIDETAG_BITS
-N_LOWTAG_BITS
)); i
++) {
2204 sizetab
[EVEN_FIXNUM_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
2205 sizetab
[FUN_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2206 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2207 sizetab
[LIST_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2208 sizetab
[ODD_FIXNUM_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_immediate
;
2209 sizetab
[INSTANCE_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2210 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2211 sizetab
[OTHER_POINTER_LOWTAG
|(i
<<N_LOWTAG_BITS
)] = size_pointer
;
2213 sizetab
[BIGNUM_WIDETAG
] = size_unboxed
;
2214 sizetab
[RATIO_WIDETAG
] = size_boxed
;
2215 #if N_WORD_BITS == 64
2216 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_immediate
;
2218 sizetab
[SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2220 sizetab
[DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2221 #ifdef LONG_FLOAT_WIDETAG
2222 sizetab
[LONG_FLOAT_WIDETAG
] = size_unboxed
;
2224 sizetab
[COMPLEX_WIDETAG
] = size_boxed
;
2225 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2226 sizetab
[COMPLEX_SINGLE_FLOAT_WIDETAG
] = size_unboxed
;
2228 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2229 sizetab
[COMPLEX_DOUBLE_FLOAT_WIDETAG
] = size_unboxed
;
2231 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2232 sizetab
[COMPLEX_LONG_FLOAT_WIDETAG
] = size_unboxed
;
2234 sizetab
[SIMPLE_ARRAY_WIDETAG
] = size_boxed
;
2235 sizetab
[SIMPLE_BASE_STRING_WIDETAG
] = size_base_string
;
2236 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2237 sizetab
[SIMPLE_CHARACTER_STRING_WIDETAG
] = size_character_string
;
2239 sizetab
[SIMPLE_BIT_VECTOR_WIDETAG
] = size_vector_bit
;
2240 sizetab
[SIMPLE_VECTOR_WIDETAG
] = size_vector
;
2241 sizetab
[SIMPLE_ARRAY_NIL_WIDETAG
] = size_vector_nil
;
2242 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
] =
2243 size_vector_unsigned_byte_2
;
2244 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
] =
2245 size_vector_unsigned_byte_4
;
2246 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
] =
2247 size_vector_unsigned_byte_8
;
2248 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
] =
2249 size_vector_unsigned_byte_8
;
2250 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
] =
2251 size_vector_unsigned_byte_16
;
2252 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
] =
2253 size_vector_unsigned_byte_16
;
2254 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2255 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
] =
2256 size_vector_unsigned_byte_32
;
2258 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
] =
2259 size_vector_unsigned_byte_32
;
2260 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
] =
2261 size_vector_unsigned_byte_32
;
2262 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2263 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
] =
2264 size_vector_unsigned_byte_64
;
2266 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2267 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
] =
2268 size_vector_unsigned_byte_64
;
2270 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2271 sizetab
[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
] =
2272 size_vector_unsigned_byte_64
;
2274 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2275 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
] = size_vector_unsigned_byte_8
;
2277 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2278 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
] =
2279 size_vector_unsigned_byte_16
;
2281 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2282 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
] =
2283 size_vector_unsigned_byte_32
;
2285 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2286 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
] =
2287 size_vector_unsigned_byte_32
;
2289 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2290 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
] =
2291 size_vector_unsigned_byte_64
;
2293 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2294 sizetab
[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
] =
2295 size_vector_unsigned_byte_64
;
2297 sizetab
[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
] = size_vector_single_float
;
2298 sizetab
[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
] = size_vector_double_float
;
2299 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2300 sizetab
[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
] = size_vector_long_float
;
2302 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2303 sizetab
[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
] =
2304 size_vector_complex_single_float
;
2306 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2307 sizetab
[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
] =
2308 size_vector_complex_double_float
;
2310 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2311 sizetab
[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
] =
2312 size_vector_complex_long_float
;
2314 sizetab
[COMPLEX_BASE_STRING_WIDETAG
] = size_boxed
;
2315 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2316 sizetab
[COMPLEX_CHARACTER_STRING_WIDETAG
] = size_boxed
;
2318 sizetab
[COMPLEX_VECTOR_NIL_WIDETAG
] = size_boxed
;
2319 sizetab
[COMPLEX_BIT_VECTOR_WIDETAG
] = size_boxed
;
2320 sizetab
[COMPLEX_VECTOR_WIDETAG
] = size_boxed
;
2321 sizetab
[COMPLEX_ARRAY_WIDETAG
] = size_boxed
;
2322 sizetab
[CODE_HEADER_WIDETAG
] = size_code_header
;
2324 /* We shouldn't see these, so just lose if it happens. */
2325 sizetab
[SIMPLE_FUN_HEADER_WIDETAG
] = size_function_header
;
2326 sizetab
[RETURN_PC_HEADER_WIDETAG
] = size_return_pc_header
;
2328 sizetab
[CLOSURE_HEADER_WIDETAG
] = size_boxed
;
2329 sizetab
[FUNCALLABLE_INSTANCE_HEADER_WIDETAG
] = size_boxed
;
2330 sizetab
[VALUE_CELL_HEADER_WIDETAG
] = size_boxed
;
2331 sizetab
[SYMBOL_HEADER_WIDETAG
] = size_boxed
;
2332 sizetab
[CHARACTER_WIDETAG
] = size_immediate
;
2333 sizetab
[SAP_WIDETAG
] = size_unboxed
;
2334 sizetab
[UNBOUND_MARKER_WIDETAG
] = size_immediate
;
2335 sizetab
[NO_TLS_VALUE_MARKER_WIDETAG
] = size_immediate
;
2336 sizetab
[WEAK_POINTER_WIDETAG
] = size_weak_pointer
;
2337 sizetab
[INSTANCE_HEADER_WIDETAG
] = size_boxed
;
2338 sizetab
[FDEFN_WIDETAG
] = size_boxed
;
2342 /* Find the code object for the given pc, or return NULL on
2345 component_ptr_from_pc(lispobj
*pc
)
2347 lispobj
*object
= NULL
;
2349 if ( (object
= search_read_only_space(pc
)) )
2351 else if ( (object
= search_static_space(pc
)) )
2354 object
= search_dynamic_space(pc
);
2356 if (object
) /* if we found something */
2357 if (widetag_of(*object
) == CODE_HEADER_WIDETAG
)
2363 /* Scan an area looking for an object which encloses the given pointer.
2364 * Return the object start on success or NULL on failure. */
2366 gc_search_space(lispobj
*start
, size_t words
, lispobj
*pointer
)
2370 lispobj thing
= *start
;
2372 /* If thing is an immediate then this is a cons. */
2373 if (is_lisp_pointer(thing
)
2375 || (widetag_of(thing
) == CHARACTER_WIDETAG
)
2376 #if N_WORD_BITS == 64
2377 || (widetag_of(thing
) == SINGLE_FLOAT_WIDETAG
)
2379 || (widetag_of(thing
) == UNBOUND_MARKER_WIDETAG
))
2382 count
= (sizetab
[widetag_of(thing
)])(start
);
2384 /* Check whether the pointer is within this object. */
2385 if ((pointer
>= start
) && (pointer
< (start
+count
))) {
2387 /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2391 /* Round up the count. */
2392 count
= CEILING(count
,2);
2401 maybe_gc(os_context_t
*context
)
2403 #ifndef LISP_FEATURE_WIN32
2404 struct thread
*thread
= arch_os_get_current_thread();
2407 fake_foreign_function_call(context
);
2408 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2409 * which case we will be running with no gc trigger barrier
2410 * thing for a while. But it shouldn't be long until the end
2413 * FIXME: It would be good to protect the end of dynamic space for
2414 * CheneyGC and signal a storage condition from there.
2417 /* Restore the signal mask from the interrupted context before
2418 * calling into Lisp if interrupts are enabled. Why not always?
2420 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2421 * interrupt hits while in SUB-GC, it is deferred and the
2422 * os_context_sigmask of that interrupt is set to block further
2423 * deferrable interrupts (until the first one is
2424 * handled). Unfortunately, that context refers to this place and
2425 * when we return from here the signals will not be blocked.
2427 * A kludgy alternative is to propagate the sigmask change to the
2430 #ifndef LISP_FEATURE_WIN32
2431 if(SymbolValue(INTERRUPTS_ENABLED
,thread
)!=NIL
) {
2432 sigset_t
*context_sigmask
= os_context_sigmask_addr(context
);
2433 #ifdef LISP_FEATURE_SB_THREAD
2434 /* What if the context we'd like to restore has GC signals
2435 * blocked? Just skip the GC: we can't set GC_PENDING, because
2436 * that would block the next attempt, and we don't know when
2437 * we'd next check for it -- and it's hard to be sure that
2438 * unblocking would be safe.
2440 * FIXME: This is not actually much better: we may already have
2441 * GC_PENDING set, and presumably our caller assumes that we will
2442 * clear it. Perhaps we should, even though we don't actually GC? */
2443 if (sigismember(context_sigmask
,SIG_STOP_FOR_GC
)) {
2444 undo_fake_foreign_function_call(context
);
2448 thread_sigmask(SIG_SETMASK
, context_sigmask
, 0);
2451 unblock_gc_signals();
2453 /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
2454 * otherwise two threads racing here may deadlock: the other will
2455 * wait on the GC lock, and the other cannot stop the first one... */
2456 funcall0(StaticSymbolFunction(SUB_GC
));
2457 undo_fake_foreign_function_call(context
);