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"
41 #include "genesis/primitive-objects.h"
42 #include "genesis/static-symbols.h"
43 #include "genesis/layout.h"
44 #include "genesis/hash-table.h"
45 #include "gc-internal.h"
47 #ifdef LISP_FEATURE_SPARC
48 #define LONG_FLOAT_SIZE 4
50 #ifdef LISP_FEATURE_X86
51 #define LONG_FLOAT_SIZE 3
55 os_vm_size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE;
56 os_vm_size_t thread_control_stack_size = DEFAULT_CONTROL_STACK_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 sword_t (*scavtab[256])(lispobj *where, lispobj object);
89 lispobj (*transother[256])(lispobj object);
90 sword_t (*sizetab[256])(lispobj *where);
91 struct weak_pointer *weak_pointers;
93 os_vm_size_t bytes_consed_between_gcs = 12*1024*1024;
99 /* gc_general_copy_object is inline from gc-internal.h */
101 /* to copy a boxed object */
103 copy_object(lispobj object, sword_t nwords)
105 return gc_general_copy_object(object, nwords, BOXED_PAGE_FLAG);
109 copy_code_object(lispobj object, sword_t nwords)
111 return gc_general_copy_object(object, nwords, CODE_PAGE_FLAG);
114 static sword_t scav_lose(lispobj *where, lispobj object); /* forward decl */
116 /* FIXME: Most calls end up going to some trouble to compute an
117 * 'n_words' value for this function. The system might be a little
118 * simpler if this function used an 'end' parameter instead. */
120 scavenge(lispobj *start, sword_t n_words)
122 lispobj *end = start + n_words;
125 for (object_ptr = start; object_ptr < end;) {
126 lispobj object = *object_ptr;
127 #ifdef LISP_FEATURE_GENCGC
128 if (forwarding_pointer_p(object_ptr))
129 lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
130 object_ptr, start, n_words);
132 if (is_lisp_pointer(object)) {
133 if (from_space_p(object)) {
134 /* It currently points to old space. Check for a
135 * forwarding pointer. */
136 lispobj *ptr = native_pointer(object);
137 if (forwarding_pointer_p(ptr)) {
138 /* Yes, there's a forwarding pointer. */
139 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
142 /* Scavenge that pointer. */
144 (scavtab[widetag_of(object)])(object_ptr, object);
147 /* It points somewhere other than oldspace. Leave it
152 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
153 /* This workaround is probably not needed for those ports
154 which don't have a partitioned register set (and therefore
155 scan the stack conservatively for roots). */
156 else if (n_words == 1) {
157 /* there are some situations where an other-immediate may
158 end up in a descriptor register. I'm not sure whether
159 this is supposed to happen, but if it does then we
160 don't want to (a) barf or (b) scavenge over the
161 data-block, because there isn't one. So, if we're
162 checking a single word and it's anything other than a
163 pointer, just hush it up */
164 int widetag = widetag_of(object);
166 if ((scavtab[widetag] == scav_lose) ||
167 (((sizetab[widetag])(object_ptr)) > 1)) {
168 fprintf(stderr,"warning: \
169 attempted to scavenge non-descriptor value %x at %p.\n\n\
170 If you can reproduce this warning, please send a bug report\n\
171 (see manual page for details).\n",
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 first, 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 first = code->header;
240 if (forwarding_pointer_p((lispobj *)code)) {
242 printf("Was already transported\n");
244 return (struct code *) forwarding_pointer_value
245 ((lispobj *)((pointer_sized_uint_t) code));
248 gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
250 /* prepare to transport the code vector */
251 l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
253 ncode_words = fixnum_value(code->code_size);
254 nheader_words = HeaderValue(code->header);
255 nwords = ncode_words + nheader_words;
256 nwords = CEILING(nwords, 2);
258 l_new_code = copy_code_object(l_code, nwords);
259 new_code = (struct code *) native_pointer(l_new_code);
261 #if defined(DEBUG_CODE_GC)
262 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
263 (uword_t) code, (uword_t) new_code);
264 printf("Code object is %d words long.\n", nwords);
267 #ifdef LISP_FEATURE_GENCGC
268 if (new_code == code)
272 displacement = l_new_code - l_code;
274 set_forwarding_pointer((lispobj *)code, l_new_code);
276 /* set forwarding pointers for all the function headers in the */
277 /* code object. also fix all self pointers */
279 fheaderl = code->entry_points;
280 prev_pointer = &new_code->entry_points;
282 while (fheaderl != NIL) {
283 struct simple_fun *fheaderp, *nfheaderp;
286 fheaderp = (struct simple_fun *) native_pointer(fheaderl);
287 gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
289 /* Calculate the new function pointer and the new */
290 /* function header. */
291 nfheaderl = fheaderl + displacement;
292 nfheaderp = (struct simple_fun *) native_pointer(nfheaderl);
295 printf("fheaderp->header (at %x) <- %x\n",
296 &(fheaderp->header) , nfheaderl);
298 set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
300 /* fix self pointer. */
302 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
303 FUN_RAW_ADDR_OFFSET +
307 *prev_pointer = nfheaderl;
309 fheaderl = fheaderp->next;
310 prev_pointer = &nfheaderp->next;
312 #ifdef LISP_FEATURE_GENCGC
313 /* Cheneygc doesn't need this os_flush_icache, it flushes the whole
314 spaces once when all copying is done. */
315 os_flush_icache((os_vm_address_t) (((sword_t *)new_code) + nheader_words),
316 ncode_words * sizeof(sword_t));
320 #ifdef LISP_FEATURE_X86
321 gencgc_apply_code_fixups(code, new_code);
328 scav_code_header(lispobj *where, lispobj object)
331 sword_t n_header_words, n_code_words, n_words;
332 lispobj entry_point; /* tagged pointer to entry point */
333 struct simple_fun *function_ptr; /* untagged pointer to entry point */
335 code = (struct code *) where;
336 n_code_words = fixnum_value(code->code_size);
337 n_header_words = HeaderValue(object);
338 n_words = n_code_words + n_header_words;
339 n_words = CEILING(n_words, 2);
341 /* Scavenge the boxed section of the code data block. */
342 scavenge(where + 1, n_header_words - 1);
344 /* Scavenge the boxed section of each function object in the
345 * code data block. */
346 for (entry_point = code->entry_points;
348 entry_point = function_ptr->next) {
350 gc_assert_verbose(is_lisp_pointer(entry_point),
351 "Entry point %lx\n is not a lisp pointer.",
352 (sword_t)entry_point);
354 function_ptr = (struct simple_fun *) native_pointer(entry_point);
355 gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG);
357 scavenge(&function_ptr->name, 1);
358 scavenge(&function_ptr->arglist, 1);
359 scavenge(&function_ptr->type, 1);
360 scavenge(&function_ptr->info, 1);
367 trans_code_header(lispobj object)
371 ncode = trans_code((struct code *) native_pointer(object));
372 return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
377 size_code_header(lispobj *where)
380 sword_t nheader_words, ncode_words, nwords;
382 code = (struct code *) where;
384 ncode_words = fixnum_value(code->code_size);
385 nheader_words = HeaderValue(code->header);
386 nwords = ncode_words + nheader_words;
387 nwords = CEILING(nwords, 2);
392 #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64)
394 scav_return_pc_header(lispobj *where, lispobj object)
396 lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n",
399 return 0; /* bogus return value to satisfy static type checking */
401 #endif /* LISP_FEATURE_X86 */
404 trans_return_pc_header(lispobj object)
406 struct simple_fun *return_pc;
408 struct code *code, *ncode;
410 return_pc = (struct simple_fun *) native_pointer(object);
411 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
412 offset = HeaderValue(return_pc->header) * N_WORD_BYTES;
414 /* Transport the whole code object */
415 code = (struct code *) ((uword_t) return_pc - offset);
416 ncode = trans_code(code);
418 return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
421 /* On the 386, closures hold a pointer to the raw address instead of the
422 * function object, so we can use CALL [$FDEFN+const] to invoke
423 * the function without loading it into a register. Given that code
424 * objects don't move, we don't need to update anything, but we do
425 * have to figure out that the function is still live. */
427 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
429 scav_closure_header(lispobj *where, lispobj object)
431 struct closure *closure;
434 closure = (struct closure *)where;
435 fun = closure->fun - FUN_RAW_ADDR_OFFSET;
437 #ifdef LISP_FEATURE_GENCGC
438 /* The function may have moved so update the raw address. But
439 * don't write unnecessarily. */
440 if (closure->fun != fun + FUN_RAW_ADDR_OFFSET)
441 closure->fun = fun + FUN_RAW_ADDR_OFFSET;
447 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
449 scav_fun_header(lispobj *where, lispobj object)
451 lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n",
454 return 0; /* bogus return value to satisfy static type checking */
456 #endif /* LISP_FEATURE_X86 */
459 trans_fun_header(lispobj object)
461 struct simple_fun *fheader;
463 struct code *code, *ncode;
465 fheader = (struct simple_fun *) native_pointer(object);
466 /* FIXME: was times 4, should it really be N_WORD_BYTES? */
467 offset = HeaderValue(fheader->header) * N_WORD_BYTES;
469 /* Transport the whole code object */
470 code = (struct code *) ((uword_t) fheader - offset);
471 ncode = trans_code(code);
473 return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
482 scav_instance_pointer(lispobj *where, lispobj object)
484 lispobj copy, *first_pointer;
486 /* Object is a pointer into from space - not a FP. */
487 copy = trans_boxed(object);
489 #ifdef LISP_FEATURE_GENCGC
490 gc_assert(copy != object);
493 first_pointer = (lispobj *) native_pointer(object);
494 set_forwarding_pointer(first_pointer,copy);
505 static lispobj trans_list(lispobj object);
508 scav_list_pointer(lispobj *where, lispobj object)
510 lispobj first, *first_pointer;
512 gc_assert(is_lisp_pointer(object));
514 /* Object is a pointer into from space - not FP. */
515 first_pointer = (lispobj *) native_pointer(object);
517 first = trans_list(object);
518 gc_assert(first != object);
520 /* Set forwarding pointer */
521 set_forwarding_pointer(first_pointer, first);
523 gc_assert(is_lisp_pointer(first));
524 gc_assert(!from_space_p(first));
532 trans_list(lispobj object)
534 lispobj new_list_pointer;
535 struct cons *cons, *new_cons;
538 cons = (struct cons *) native_pointer(object);
541 new_cons = (struct cons *)
542 gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
543 new_cons->car = cons->car;
544 new_cons->cdr = cons->cdr; /* updated later */
545 new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
547 /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */
550 set_forwarding_pointer((lispobj *)cons, new_list_pointer);
552 /* Try to linearize the list in the cdr direction to help reduce
556 struct cons *cdr_cons, *new_cdr_cons;
558 if(lowtag_of(cdr) != LIST_POINTER_LOWTAG ||
559 !from_space_p(cdr) ||
560 forwarding_pointer_p((lispobj *)native_pointer(cdr)))
563 cdr_cons = (struct cons *) native_pointer(cdr);
566 new_cdr_cons = (struct cons*)
567 gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
568 new_cdr_cons->car = cdr_cons->car;
569 new_cdr_cons->cdr = cdr_cons->cdr;
570 new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
572 /* Grab the cdr before it is clobbered. */
574 set_forwarding_pointer((lispobj *)cdr_cons, new_cdr);
576 /* Update the cdr of the last cons copied into new space to
577 * keep the newspace scavenge from having to do it. */
578 new_cons->cdr = new_cdr;
580 new_cons = new_cdr_cons;
583 return new_list_pointer;
588 * scavenging and transporting other pointers
592 scav_other_pointer(lispobj *where, lispobj object)
594 lispobj first, *first_pointer;
596 gc_assert(is_lisp_pointer(object));
598 /* Object is a pointer into from space - not FP. */
599 first_pointer = (lispobj *) native_pointer(object);
600 first = (transother[widetag_of(*first_pointer)])(object);
602 if (first != object) {
603 set_forwarding_pointer(first_pointer, first);
604 #ifdef LISP_FEATURE_GENCGC
608 #ifndef LISP_FEATURE_GENCGC
611 gc_assert(is_lisp_pointer(first));
612 gc_assert(!from_space_p(first));
618 * immediate, boxed, and unboxed objects
622 size_pointer(lispobj *where)
628 scav_immediate(lispobj *where, lispobj object)
634 trans_immediate(lispobj object)
636 lose("trying to transport an immediate\n");
637 return NIL; /* bogus return value to satisfy static type checking */
641 size_immediate(lispobj *where)
648 scav_boxed(lispobj *where, lispobj object)
654 scav_instance(lispobj *where, lispobj object)
657 sword_t ntotal = HeaderValue(object);
658 lispobj layout = ((struct instance *)where)->slots[0];
662 if (forwarding_pointer_p(native_pointer(layout)))
663 layout = (lispobj) forwarding_pointer_value(native_pointer(layout));
665 nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots;
666 scavenge(where + 1, ntotal - fixnum_value(nuntagged));
672 trans_boxed(lispobj object)
677 gc_assert(is_lisp_pointer(object));
679 header = *((lispobj *) native_pointer(object));
680 length = HeaderValue(header) + 1;
681 length = CEILING(length, 2);
683 return copy_object(object, length);
688 size_boxed(lispobj *where)
694 length = HeaderValue(header) + 1;
695 length = CEILING(length, 2);
700 /* Note: on the sparc we don't have to do anything special for fdefns, */
701 /* 'cause the raw-addr has a function lowtag. */
702 #if !defined(LISP_FEATURE_SPARC)
704 scav_fdefn(lispobj *where, lispobj object)
708 fdefn = (struct fdefn *)where;
710 /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
711 fdefn->fun, fdefn->raw_addr)); */
713 if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
714 scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
716 /* Don't write unnecessarily. */
717 if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
718 fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
719 /* gc.c has more casts here, which may be relevant or alternatively
720 may be compiler warning defeaters. try
721 fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
723 return sizeof(struct fdefn) / sizeof(lispobj);
731 scav_unboxed(lispobj *where, lispobj object)
735 length = HeaderValue(object) + 1;
736 length = CEILING(length, 2);
742 trans_unboxed(lispobj object)
748 gc_assert(is_lisp_pointer(object));
750 header = *((lispobj *) native_pointer(object));
751 length = HeaderValue(header) + 1;
752 length = CEILING(length, 2);
754 return copy_unboxed_object(object, length);
758 size_unboxed(lispobj *where)
764 length = HeaderValue(header) + 1;
765 length = CEILING(length, 2);
771 /* vector-like objects */
773 scav_base_string(lispobj *where, lispobj object)
775 struct vector *vector;
776 sword_t length, nwords;
778 /* NOTE: Strings contain one more byte of data than the length */
779 /* slot indicates. */
781 vector = (struct vector *) where;
782 length = fixnum_value(vector->length) + 1;
783 nwords = CEILING(NWORDS(length, 8) + 2, 2);
788 trans_base_string(lispobj object)
790 struct vector *vector;
791 sword_t length, nwords;
793 gc_assert(is_lisp_pointer(object));
795 /* NOTE: A string contains one more byte of data (a terminating
796 * '\0' to help when interfacing with C functions) than indicated
797 * by the length slot. */
799 vector = (struct vector *) native_pointer(object);
800 length = fixnum_value(vector->length) + 1;
801 nwords = CEILING(NWORDS(length, 8) + 2, 2);
803 return copy_large_unboxed_object(object, nwords);
807 size_base_string(lispobj *where)
809 struct vector *vector;
810 sword_t length, nwords;
812 /* NOTE: A string contains one more byte of data (a terminating
813 * '\0' to help when interfacing with C functions) than indicated
814 * by the length slot. */
816 vector = (struct vector *) where;
817 length = fixnum_value(vector->length) + 1;
818 nwords = CEILING(NWORDS(length, 8) + 2, 2);
824 scav_character_string(lispobj *where, lispobj object)
826 struct vector *vector;
829 /* NOTE: Strings contain one more byte of data than the length */
830 /* slot indicates. */
832 vector = (struct vector *) where;
833 length = fixnum_value(vector->length) + 1;
834 nwords = CEILING(NWORDS(length, 32) + 2, 2);
839 trans_character_string(lispobj object)
841 struct vector *vector;
844 gc_assert(is_lisp_pointer(object));
846 /* NOTE: A string contains one more byte of data (a terminating
847 * '\0' to help when interfacing with C functions) than indicated
848 * by the length slot. */
850 vector = (struct vector *) native_pointer(object);
851 length = fixnum_value(vector->length) + 1;
852 nwords = CEILING(NWORDS(length, 32) + 2, 2);
854 return copy_large_unboxed_object(object, nwords);
858 size_character_string(lispobj *where)
860 struct vector *vector;
863 /* NOTE: A string contains one more byte of data (a terminating
864 * '\0' to help when interfacing with C functions) than indicated
865 * by the length slot. */
867 vector = (struct vector *) where;
868 length = fixnum_value(vector->length) + 1;
869 nwords = CEILING(NWORDS(length, 32) + 2, 2);
875 trans_vector(lispobj object)
877 struct vector *vector;
878 sword_t length, nwords;
880 gc_assert(is_lisp_pointer(object));
882 vector = (struct vector *) native_pointer(object);
884 length = fixnum_value(vector->length);
885 nwords = CEILING(length + 2, 2);
887 return copy_large_object(object, nwords);
891 size_vector(lispobj *where)
893 struct vector *vector;
894 sword_t length, nwords;
896 vector = (struct vector *) where;
897 length = fixnum_value(vector->length);
898 nwords = CEILING(length + 2, 2);
904 scav_vector_nil(lispobj *where, lispobj object)
910 trans_vector_nil(lispobj object)
912 gc_assert(is_lisp_pointer(object));
913 return copy_unboxed_object(object, 2);
917 size_vector_nil(lispobj *where)
919 /* Just the header word and the length word */
924 scav_vector_bit(lispobj *where, lispobj object)
926 struct vector *vector;
927 sword_t length, nwords;
929 vector = (struct vector *) where;
930 length = fixnum_value(vector->length);
931 nwords = CEILING(NWORDS(length, 1) + 2, 2);
937 trans_vector_bit(lispobj object)
939 struct vector *vector;
940 sword_t length, nwords;
942 gc_assert(is_lisp_pointer(object));
944 vector = (struct vector *) native_pointer(object);
945 length = fixnum_value(vector->length);
946 nwords = CEILING(NWORDS(length, 1) + 2, 2);
948 return copy_large_unboxed_object(object, nwords);
952 size_vector_bit(lispobj *where)
954 struct vector *vector;
955 sword_t length, nwords;
957 vector = (struct vector *) where;
958 length = fixnum_value(vector->length);
959 nwords = CEILING(NWORDS(length, 1) + 2, 2);
965 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
967 struct vector *vector;
968 sword_t length, nwords;
970 vector = (struct vector *) where;
971 length = fixnum_value(vector->length);
972 nwords = CEILING(NWORDS(length, 2) + 2, 2);
978 trans_vector_unsigned_byte_2(lispobj object)
980 struct vector *vector;
981 sword_t length, nwords;
983 gc_assert(is_lisp_pointer(object));
985 vector = (struct vector *) native_pointer(object);
986 length = fixnum_value(vector->length);
987 nwords = CEILING(NWORDS(length, 2) + 2, 2);
989 return copy_large_unboxed_object(object, nwords);
993 size_vector_unsigned_byte_2(lispobj *where)
995 struct vector *vector;
996 sword_t length, nwords;
998 vector = (struct vector *) where;
999 length = fixnum_value(vector->length);
1000 nwords = CEILING(NWORDS(length, 2) + 2, 2);
1006 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1008 struct vector *vector;
1009 sword_t length, nwords;
1011 vector = (struct vector *) where;
1012 length = fixnum_value(vector->length);
1013 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1019 trans_vector_unsigned_byte_4(lispobj object)
1021 struct vector *vector;
1022 sword_t length, nwords;
1024 gc_assert(is_lisp_pointer(object));
1026 vector = (struct vector *) native_pointer(object);
1027 length = fixnum_value(vector->length);
1028 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1030 return copy_large_unboxed_object(object, nwords);
1033 size_vector_unsigned_byte_4(lispobj *where)
1035 struct vector *vector;
1036 sword_t length, nwords;
1038 vector = (struct vector *) where;
1039 length = fixnum_value(vector->length);
1040 nwords = CEILING(NWORDS(length, 4) + 2, 2);
1047 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1049 struct vector *vector;
1050 sword_t length, nwords;
1052 vector = (struct vector *) where;
1053 length = fixnum_value(vector->length);
1054 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1059 /*********************/
1064 trans_vector_unsigned_byte_8(lispobj object)
1066 struct vector *vector;
1067 sword_t length, nwords;
1069 gc_assert(is_lisp_pointer(object));
1071 vector = (struct vector *) native_pointer(object);
1072 length = fixnum_value(vector->length);
1073 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1075 return copy_large_unboxed_object(object, nwords);
1079 size_vector_unsigned_byte_8(lispobj *where)
1081 struct vector *vector;
1082 sword_t length, nwords;
1084 vector = (struct vector *) where;
1085 length = fixnum_value(vector->length);
1086 nwords = CEILING(NWORDS(length, 8) + 2, 2);
1093 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1095 struct vector *vector;
1096 sword_t length, nwords;
1098 vector = (struct vector *) where;
1099 length = fixnum_value(vector->length);
1100 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1106 trans_vector_unsigned_byte_16(lispobj object)
1108 struct vector *vector;
1109 sword_t length, nwords;
1111 gc_assert(is_lisp_pointer(object));
1113 vector = (struct vector *) native_pointer(object);
1114 length = fixnum_value(vector->length);
1115 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1117 return copy_large_unboxed_object(object, nwords);
1121 size_vector_unsigned_byte_16(lispobj *where)
1123 struct vector *vector;
1124 sword_t length, nwords;
1126 vector = (struct vector *) where;
1127 length = fixnum_value(vector->length);
1128 nwords = CEILING(NWORDS(length, 16) + 2, 2);
1134 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1136 struct vector *vector;
1137 sword_t length, nwords;
1139 vector = (struct vector *) where;
1140 length = fixnum_value(vector->length);
1141 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1147 trans_vector_unsigned_byte_32(lispobj object)
1149 struct vector *vector;
1150 sword_t length, nwords;
1152 gc_assert(is_lisp_pointer(object));
1154 vector = (struct vector *) native_pointer(object);
1155 length = fixnum_value(vector->length);
1156 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1158 return copy_large_unboxed_object(object, nwords);
1162 size_vector_unsigned_byte_32(lispobj *where)
1164 struct vector *vector;
1165 sword_t length, nwords;
1167 vector = (struct vector *) where;
1168 length = fixnum_value(vector->length);
1169 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1174 #if N_WORD_BITS == 64
1176 scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
1178 struct vector *vector;
1179 sword_t length, nwords;
1181 vector = (struct vector *) where;
1182 length = fixnum_value(vector->length);
1183 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1189 trans_vector_unsigned_byte_64(lispobj object)
1191 struct vector *vector;
1192 sword_t length, nwords;
1194 gc_assert(is_lisp_pointer(object));
1196 vector = (struct vector *) native_pointer(object);
1197 length = fixnum_value(vector->length);
1198 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1200 return copy_large_unboxed_object(object, nwords);
1204 size_vector_unsigned_byte_64(lispobj *where)
1206 struct vector *vector;
1207 sword_t length, nwords;
1209 vector = (struct vector *) where;
1210 length = fixnum_value(vector->length);
1211 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1218 scav_vector_single_float(lispobj *where, lispobj object)
1220 struct vector *vector;
1221 sword_t length, nwords;
1223 vector = (struct vector *) where;
1224 length = fixnum_value(vector->length);
1225 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1231 trans_vector_single_float(lispobj object)
1233 struct vector *vector;
1234 sword_t length, nwords;
1236 gc_assert(is_lisp_pointer(object));
1238 vector = (struct vector *) native_pointer(object);
1239 length = fixnum_value(vector->length);
1240 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1242 return copy_large_unboxed_object(object, nwords);
1246 size_vector_single_float(lispobj *where)
1248 struct vector *vector;
1249 sword_t length, nwords;
1251 vector = (struct vector *) where;
1252 length = fixnum_value(vector->length);
1253 nwords = CEILING(NWORDS(length, 32) + 2, 2);
1259 scav_vector_double_float(lispobj *where, lispobj object)
1261 struct vector *vector;
1262 sword_t length, nwords;
1264 vector = (struct vector *) where;
1265 length = fixnum_value(vector->length);
1266 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1272 trans_vector_double_float(lispobj object)
1274 struct vector *vector;
1275 sword_t length, nwords;
1277 gc_assert(is_lisp_pointer(object));
1279 vector = (struct vector *) native_pointer(object);
1280 length = fixnum_value(vector->length);
1281 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1283 return copy_large_unboxed_object(object, nwords);
1287 size_vector_double_float(lispobj *where)
1289 struct vector *vector;
1290 sword_t length, nwords;
1292 vector = (struct vector *) where;
1293 length = fixnum_value(vector->length);
1294 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1299 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1301 scav_vector_long_float(lispobj *where, lispobj object)
1303 struct vector *vector;
1304 long length, nwords;
1306 vector = (struct vector *) where;
1307 length = fixnum_value(vector->length);
1308 nwords = CEILING(length *
1315 trans_vector_long_float(lispobj object)
1317 struct vector *vector;
1318 long length, nwords;
1320 gc_assert(is_lisp_pointer(object));
1322 vector = (struct vector *) native_pointer(object);
1323 length = fixnum_value(vector->length);
1324 nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1326 return copy_large_unboxed_object(object, nwords);
1330 size_vector_long_float(lispobj *where)
1332 struct vector *vector;
1333 sword_t length, nwords;
1335 vector = (struct vector *) where;
1336 length = fixnum_value(vector->length);
1337 nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2);
1344 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1346 scav_vector_complex_single_float(lispobj *where, lispobj object)
1348 struct vector *vector;
1349 sword_t length, nwords;
1351 vector = (struct vector *) where;
1352 length = fixnum_value(vector->length);
1353 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1359 trans_vector_complex_single_float(lispobj object)
1361 struct vector *vector;
1362 sword_t length, nwords;
1364 gc_assert(is_lisp_pointer(object));
1366 vector = (struct vector *) native_pointer(object);
1367 length = fixnum_value(vector->length);
1368 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1370 return copy_large_unboxed_object(object, nwords);
1374 size_vector_complex_single_float(lispobj *where)
1376 struct vector *vector;
1377 sword_t length, nwords;
1379 vector = (struct vector *) where;
1380 length = fixnum_value(vector->length);
1381 nwords = CEILING(NWORDS(length, 64) + 2, 2);
1387 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1389 scav_vector_complex_double_float(lispobj *where, lispobj object)
1391 struct vector *vector;
1392 sword_t length, nwords;
1394 vector = (struct vector *) where;
1395 length = fixnum_value(vector->length);
1396 nwords = CEILING(NWORDS(length, 128) + 2, 2);
1402 trans_vector_complex_double_float(lispobj object)
1404 struct vector *vector;
1405 sword_t length, nwords;
1407 gc_assert(is_lisp_pointer(object));
1409 vector = (struct vector *) native_pointer(object);
1410 length = fixnum_value(vector->length);
1411 nwords = CEILING(NWORDS(length, 128) + 2, 2);
1413 return copy_large_unboxed_object(object, nwords);
1417 size_vector_complex_double_float(lispobj *where)
1419 struct vector *vector;
1420 sword_t length, nwords;
1422 vector = (struct vector *) where;
1423 length = fixnum_value(vector->length);
1424 nwords = CEILING(NWORDS(length, 128) + 2, 2);
1431 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1433 scav_vector_complex_long_float(lispobj *where, lispobj object)
1435 struct vector *vector;
1436 sword_t length, nwords;
1438 vector = (struct vector *) where;
1439 length = fixnum_value(vector->length);
1440 nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2);
1446 trans_vector_complex_long_float(lispobj object)
1448 struct vector *vector;
1449 long length, nwords;
1451 gc_assert(is_lisp_pointer(object));
1453 vector = (struct vector *) native_pointer(object);
1454 length = fixnum_value(vector->length);
1455 nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1457 return copy_large_unboxed_object(object, nwords);
1461 size_vector_complex_long_float(lispobj *where)
1463 struct vector *vector;
1464 long length, nwords;
1466 vector = (struct vector *) where;
1467 length = fixnum_value(vector->length);
1468 nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2);
1474 #define WEAK_POINTER_NWORDS \
1475 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1478 trans_weak_pointer(lispobj object)
1481 #ifndef LISP_FEATURE_GENCGC
1482 struct weak_pointer *wp;
1484 gc_assert(is_lisp_pointer(object));
1486 #if defined(DEBUG_WEAK)
1487 printf("Transporting weak pointer from 0x%08x\n", object);
1490 /* Need to remember where all the weak pointers are that have */
1491 /* been transported so they can be fixed up in a post-GC pass. */
1493 copy = copy_object(object, WEAK_POINTER_NWORDS);
1494 #ifndef LISP_FEATURE_GENCGC
1495 wp = (struct weak_pointer *) native_pointer(copy);
1497 gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1498 /* Push the weak pointer onto the list of weak pointers. */
1499 wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers);
1506 size_weak_pointer(lispobj *where)
1508 return WEAK_POINTER_NWORDS;
1512 void scan_weak_pointers(void)
1514 struct weak_pointer *wp, *next_wp;
1515 for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
1516 lispobj value = wp->value;
1517 lispobj *first_pointer;
1518 gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
1522 if (next_wp == wp) /* gencgc uses a ref to self for end of list */
1525 if (!(is_lisp_pointer(value) && from_space_p(value)))
1528 /* Now, we need to check whether the object has been forwarded. If
1529 * it has been, the weak pointer is still good and needs to be
1530 * updated. Otherwise, the weak pointer needs to be nil'ed
1533 first_pointer = (lispobj *)native_pointer(value);
1535 if (forwarding_pointer_p(first_pointer)) {
1537 (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer));
1549 #if N_WORD_BITS == 32
1550 #define EQ_HASH_MASK 0x1fffffff
1551 #elif N_WORD_BITS == 64
1552 #define EQ_HASH_MASK 0x1fffffffffffffff
1555 /* Compute the EQ-hash of KEY. This must match POINTER-HASH in
1556 * target-hash-table.lisp. */
1557 #define EQ_HASH(key) ((key) & EQ_HASH_MASK)
1559 /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
1560 * slot. Set to NULL at the end of a collection.
1562 * This is not optimal because, when a table is tenured, it won't be
1563 * processed automatically; only the yougest generation is GC'd by
1564 * default. On the other hand, all applications will need an
1565 * occasional full GC anyway, so it's not that bad either. */
1566 struct hash_table *weak_hash_tables = NULL;
1568 /* Return true if OBJ has already survived the current GC. */
1570 survived_gc_yet (lispobj obj)
1572 return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
1573 forwarding_pointer_p(native_pointer(obj)));
1577 weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
1581 return survived_gc_yet(key);
1583 return survived_gc_yet(value);
1585 return (survived_gc_yet(key) || survived_gc_yet(value));
1587 return (survived_gc_yet(key) && survived_gc_yet(value));
1590 /* Shut compiler up. */
1595 /* Return the beginning of data in ARRAY (skipping the header and the
1596 * length) or NULL if it isn't an array of the specified widetag after
1598 static inline lispobj *
1599 get_array_data (lispobj array, int widetag, uword_t *length)
1601 if (is_lisp_pointer(array) &&
1602 (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
1604 *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
1605 return ((lispobj *)native_pointer(array)) + 2;
1611 /* Only need to worry about scavenging the _real_ entries in the
1612 * table. Phantom entries such as the hash table itself at index 0 and
1613 * the empty marker at index 1 were scavenged by scav_vector that
1614 * either called this function directly or arranged for it to be
1615 * called later by pushing the hash table onto weak_hash_tables. */
1617 scav_hash_table_entries (struct hash_table *hash_table)
1621 lispobj *index_vector;
1623 lispobj *next_vector;
1624 uword_t next_vector_length;
1625 lispobj *hash_vector;
1626 uword_t hash_vector_length;
1627 lispobj empty_symbol;
1628 lispobj weakness = hash_table->weakness;
1631 kv_vector = get_array_data(hash_table->table,
1632 SIMPLE_VECTOR_WIDETAG, &kv_length);
1633 if (kv_vector == NULL)
1634 lose("invalid kv_vector %x\n", hash_table->table);
1636 index_vector = get_array_data(hash_table->index_vector,
1637 SIMPLE_ARRAY_WORD_WIDETAG, &length);
1638 if (index_vector == NULL)
1639 lose("invalid index_vector %x\n", hash_table->index_vector);
1641 next_vector = get_array_data(hash_table->next_vector,
1642 SIMPLE_ARRAY_WORD_WIDETAG,
1643 &next_vector_length);
1644 if (next_vector == NULL)
1645 lose("invalid next_vector %x\n", hash_table->next_vector);
1647 hash_vector = get_array_data(hash_table->hash_vector,
1648 SIMPLE_ARRAY_WORD_WIDETAG,
1649 &hash_vector_length);
1650 if (hash_vector != NULL)
1651 gc_assert(hash_vector_length == next_vector_length);
1653 /* These lengths could be different as the index_vector can be a
1654 * different length from the others, a larger index_vector could
1655 * help reduce collisions. */
1656 gc_assert(next_vector_length*2 == kv_length);
1658 empty_symbol = kv_vector[1];
1659 /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1660 if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1661 SYMBOL_HEADER_WIDETAG) {
1662 lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1663 *(lispobj *)native_pointer(empty_symbol));
1666 /* Work through the KV vector. */
1667 for (i = 1; i < next_vector_length; i++) {
1668 lispobj old_key = kv_vector[2*i];
1669 lispobj value = kv_vector[2*i+1];
1670 if ((weakness == NIL) ||
1671 weak_hash_entry_alivep(weakness, old_key, value)) {
1673 /* Scavenge the key and value. */
1674 scavenge(&kv_vector[2*i],2);
1676 /* If an EQ-based key has moved, mark the hash-table for
1678 if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
1679 lispobj new_key = kv_vector[2*i];
1681 if (old_key != new_key && new_key != empty_symbol) {
1682 hash_table->needs_rehash_p = T;
1690 scav_vector (lispobj *where, lispobj object)
1693 struct hash_table *hash_table;
1695 /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
1696 * hash tables in the Lisp HASH-TABLE code to indicate need for
1697 * special GC support. */
1698 if (HeaderValue(object) == subtype_VectorNormal)
1701 kv_length = fixnum_value(where[1]);
1702 /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1704 /* Scavenge element 0, which may be a hash-table structure. */
1705 scavenge(where+2, 1);
1706 if (!is_lisp_pointer(where[2])) {
1707 /* This'll happen when REHASH clears the header of old-kv-vector
1708 * and fills it with zero, but some other thread simulatenously
1709 * sets the header in %%PUTHASH.
1712 "Warning: no pointer at %p in hash table: this indicates "
1713 "non-fatal corruption caused by concurrent access to a "
1714 "hash-table from multiple threads. Any accesses to "
1715 "hash-tables shared between threads should be protected "
1716 "by locks.\n", (uword_t)&where[2]);
1717 // We've scavenged three words.
1720 hash_table = (struct hash_table *)native_pointer(where[2]);
1721 /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1722 if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1723 lose("hash table not instance (%x at %x)\n",
1728 /* Scavenge element 1, which should be some internal symbol that
1729 * the hash table code reserves for marking empty slots. */
1730 scavenge(where+3, 1);
1731 if (!is_lisp_pointer(where[3])) {
1732 lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1735 /* Scavenge hash table, which will fix the positions of the other
1736 * needed objects. */
1737 scavenge((lispobj *)hash_table,
1738 sizeof(struct hash_table) / sizeof(lispobj));
1740 /* Cross-check the kv_vector. */
1741 if (where != (lispobj *)native_pointer(hash_table->table)) {
1742 lose("hash_table table!=this table %x\n", hash_table->table);
1745 if (hash_table->weakness == NIL) {
1746 scav_hash_table_entries(hash_table);
1748 /* Delay scavenging of this table by pushing it onto
1749 * weak_hash_tables (if it's not there already) for the weak
1751 if (hash_table->next_weak_hash_table == NIL) {
1752 hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
1753 weak_hash_tables = hash_table;
1757 return (CEILING(kv_length + 2, 2));
1761 scav_weak_hash_tables (void)
1763 struct hash_table *table;
1765 /* Scavenge entries whose triggers are known to survive. */
1766 for (table = weak_hash_tables; table != NULL;
1767 table = (struct hash_table *)table->next_weak_hash_table) {
1768 scav_hash_table_entries(table);
1772 /* Walk through the chain whose first element is *FIRST and remove
1773 * dead weak entries. */
1775 scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
1776 lispobj *kv_vector, lispobj *index_vector,
1777 lispobj *next_vector, lispobj *hash_vector,
1778 lispobj empty_symbol, lispobj weakness)
1780 unsigned index = *prev;
1782 unsigned next = next_vector[index];
1783 lispobj key = kv_vector[2 * index];
1784 lispobj value = kv_vector[2 * index + 1];
1785 gc_assert(key != empty_symbol);
1786 gc_assert(value != empty_symbol);
1787 if (!weak_hash_entry_alivep(weakness, key, value)) {
1788 unsigned count = fixnum_value(hash_table->number_entries);
1789 gc_assert(count > 0);
1791 hash_table->number_entries = make_fixnum(count - 1);
1792 next_vector[index] = fixnum_value(hash_table->next_free_kv);
1793 hash_table->next_free_kv = make_fixnum(index);
1794 kv_vector[2 * index] = empty_symbol;
1795 kv_vector[2 * index + 1] = empty_symbol;
1797 hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
1799 prev = &next_vector[index];
1806 scan_weak_hash_table (struct hash_table *hash_table)
1809 lispobj *index_vector;
1810 uword_t length = 0; /* prevent warning */
1811 lispobj *next_vector;
1812 uword_t next_vector_length = 0; /* prevent warning */
1813 lispobj *hash_vector;
1814 lispobj empty_symbol;
1815 lispobj weakness = hash_table->weakness;
1818 kv_vector = get_array_data(hash_table->table,
1819 SIMPLE_VECTOR_WIDETAG, NULL);
1820 index_vector = get_array_data(hash_table->index_vector,
1821 SIMPLE_ARRAY_WORD_WIDETAG, &length);
1822 next_vector = get_array_data(hash_table->next_vector,
1823 SIMPLE_ARRAY_WORD_WIDETAG,
1824 &next_vector_length);
1825 hash_vector = get_array_data(hash_table->hash_vector,
1826 SIMPLE_ARRAY_WORD_WIDETAG, NULL);
1827 empty_symbol = kv_vector[1];
1829 for (i = 0; i < length; i++) {
1830 scan_weak_hash_table_chain(hash_table, &index_vector[i],
1831 kv_vector, index_vector, next_vector,
1832 hash_vector, empty_symbol, weakness);
1836 /* Remove dead entries from weak hash tables. */
1838 scan_weak_hash_tables (void)
1840 struct hash_table *table, *next;
1842 for (table = weak_hash_tables; table != NULL; table = next) {
1843 next = (struct hash_table *)table->next_weak_hash_table;
1844 table->next_weak_hash_table = NIL;
1845 scan_weak_hash_table(table);
1848 weak_hash_tables = NULL;
1857 scav_lose(lispobj *where, lispobj object)
1859 lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
1861 widetag_of(*where));
1863 return 0; /* bogus return value to satisfy static type checking */
1867 trans_lose(lispobj object)
1869 lose("no transport function for object 0x%08x (widetag 0x%x)\n",
1871 widetag_of(*(lispobj*)native_pointer(object)));
1872 return NIL; /* bogus return value to satisfy static type checking */
1876 size_lose(lispobj *where)
1878 lose("no size function for object at 0x%08x (widetag 0x%x)\n",
1880 widetag_of(*where));
1881 return 1; /* bogus return value to satisfy static type checking */
1890 gc_init_tables(void)
1894 /* Set default value in all slots of scavenge table. FIXME
1895 * replace this gnarly sizeof with something based on
1897 for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) {
1898 scavtab[i] = scav_lose;
1901 /* For each type which can be selected by the lowtag alone, set
1902 * multiple entries in our widetag scavenge table (one for each
1903 * possible value of the high bits).
1906 for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
1907 for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
1909 scavtab[j|(i<<N_LOWTAG_BITS)] = scav_immediate;
1912 scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
1913 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
1914 scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
1915 scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
1916 scav_instance_pointer;
1917 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
1918 scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
1921 /* Other-pointer types (those selected by all eight bits of the
1922 * tag) get one entry each in the scavenge table. */
1923 scavtab[BIGNUM_WIDETAG] = scav_unboxed;
1924 scavtab[RATIO_WIDETAG] = scav_boxed;
1925 #if N_WORD_BITS == 64
1926 scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate;
1928 scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1930 scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1931 #ifdef LONG_FLOAT_WIDETAG
1932 scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
1934 scavtab[COMPLEX_WIDETAG] = scav_boxed;
1935 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
1936 scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
1938 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
1939 scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
1941 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
1942 scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
1944 #ifdef SIMD_PACK_WIDETAG
1945 scavtab[SIMD_PACK_WIDETAG] = scav_unboxed;
1947 scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
1948 scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
1949 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1950 scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string;
1952 scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
1953 scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
1954 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
1955 scav_vector_unsigned_byte_2;
1956 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
1957 scav_vector_unsigned_byte_4;
1958 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
1959 scav_vector_unsigned_byte_8;
1960 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
1961 scav_vector_unsigned_byte_8;
1962 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
1963 scav_vector_unsigned_byte_16;
1964 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
1965 scav_vector_unsigned_byte_16;
1966 #if (N_WORD_BITS == 32)
1967 scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1968 scav_vector_unsigned_byte_32;
1970 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
1971 scav_vector_unsigned_byte_32;
1972 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
1973 scav_vector_unsigned_byte_32;
1974 #if (N_WORD_BITS == 64)
1975 scavtab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
1976 scav_vector_unsigned_byte_64;
1978 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
1979 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
1980 scav_vector_unsigned_byte_64;
1982 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
1983 scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
1984 scav_vector_unsigned_byte_64;
1986 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1987 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
1989 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1990 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
1991 scav_vector_unsigned_byte_16;
1993 #if (N_WORD_BITS == 32)
1994 scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
1995 scav_vector_unsigned_byte_32;
1997 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1998 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
1999 scav_vector_unsigned_byte_32;
2001 #if (N_WORD_BITS == 64)
2002 scavtab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2003 scav_vector_unsigned_byte_64;
2005 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2006 scavtab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2007 scav_vector_unsigned_byte_64;
2009 scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
2010 scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
2011 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2012 scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
2014 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2015 scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2016 scav_vector_complex_single_float;
2018 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2019 scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2020 scav_vector_complex_double_float;
2022 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2023 scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2024 scav_vector_complex_long_float;
2026 scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
2027 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2028 scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed;
2030 scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
2031 scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
2032 scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
2033 scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
2034 scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
2035 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2036 scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
2037 scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
2039 scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
2040 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
2041 scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
2043 scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
2045 scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
2046 scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
2047 scavtab[CHARACTER_WIDETAG] = scav_immediate;
2048 scavtab[SAP_WIDETAG] = scav_unboxed;
2049 scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
2050 scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
2051 scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
2052 #if defined(LISP_FEATURE_SPARC)
2053 scavtab[FDEFN_WIDETAG] = scav_boxed;
2055 scavtab[FDEFN_WIDETAG] = scav_fdefn;
2057 scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
2059 /* transport other table, initialized same way as scavtab */
2060 for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
2061 transother[i] = trans_lose;
2062 transother[BIGNUM_WIDETAG] = trans_unboxed;
2063 transother[RATIO_WIDETAG] = trans_boxed;
2065 #if N_WORD_BITS == 64
2066 transother[SINGLE_FLOAT_WIDETAG] = trans_immediate;
2068 transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2070 transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2071 #ifdef LONG_FLOAT_WIDETAG
2072 transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
2074 transother[COMPLEX_WIDETAG] = trans_boxed;
2075 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2076 transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
2078 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2079 transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
2081 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2082 transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
2084 transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
2085 transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
2086 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2087 transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string;
2089 transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
2090 transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
2091 transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
2092 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2093 trans_vector_unsigned_byte_2;
2094 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2095 trans_vector_unsigned_byte_4;
2096 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2097 trans_vector_unsigned_byte_8;
2098 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2099 trans_vector_unsigned_byte_8;
2100 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2101 trans_vector_unsigned_byte_16;
2102 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2103 trans_vector_unsigned_byte_16;
2104 #if (N_WORD_BITS == 32)
2105 transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2106 trans_vector_unsigned_byte_32;
2108 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2109 trans_vector_unsigned_byte_32;
2110 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2111 trans_vector_unsigned_byte_32;
2112 #if (N_WORD_BITS == 64)
2113 transother[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2114 trans_vector_unsigned_byte_64;
2116 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2117 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2118 trans_vector_unsigned_byte_64;
2120 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2121 transother[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2122 trans_vector_unsigned_byte_64;
2124 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2125 transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
2126 trans_vector_unsigned_byte_8;
2128 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2129 transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2130 trans_vector_unsigned_byte_16;
2132 #if (N_WORD_BITS == 32)
2133 transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2134 trans_vector_unsigned_byte_32;
2136 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2137 transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2138 trans_vector_unsigned_byte_32;
2140 #if (N_WORD_BITS == 64)
2141 transother[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2142 trans_vector_unsigned_byte_64;
2144 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2145 transother[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2146 trans_vector_unsigned_byte_64;
2148 transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
2149 trans_vector_single_float;
2150 transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
2151 trans_vector_double_float;
2152 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2153 transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
2154 trans_vector_long_float;
2156 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2157 transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2158 trans_vector_complex_single_float;
2160 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2161 transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2162 trans_vector_complex_double_float;
2164 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2165 transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2166 trans_vector_complex_long_float;
2168 transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
2169 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2170 transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed;
2172 transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
2173 transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
2174 transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
2175 transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
2176 transother[CODE_HEADER_WIDETAG] = trans_code_header;
2177 transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
2178 transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
2179 transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
2180 transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
2181 transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
2182 transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
2183 transother[CHARACTER_WIDETAG] = trans_immediate;
2184 transother[SAP_WIDETAG] = trans_unboxed;
2185 #ifdef SIMD_PACK_WIDETAG
2186 transother[SIMD_PACK_WIDETAG] = trans_unboxed;
2188 transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
2189 transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
2190 transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
2191 transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
2192 transother[FDEFN_WIDETAG] = trans_boxed;
2194 /* size table, initialized the same way as scavtab */
2195 for (i = 0; i < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
2196 sizetab[i] = size_lose;
2197 for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
2198 for (j = 0; j < (1<<N_LOWTAG_BITS); j++) {
2200 sizetab[j|(i<<N_LOWTAG_BITS)] = size_immediate;
2203 sizetab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2204 /* skipping OTHER_IMMEDIATE_0_LOWTAG */
2205 sizetab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2206 sizetab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2207 /* skipping OTHER_IMMEDIATE_1_LOWTAG */
2208 sizetab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = size_pointer;
2210 sizetab[BIGNUM_WIDETAG] = size_unboxed;
2211 sizetab[RATIO_WIDETAG] = size_boxed;
2212 #if N_WORD_BITS == 64
2213 sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate;
2215 sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
2217 sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2218 #ifdef LONG_FLOAT_WIDETAG
2219 sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
2221 sizetab[COMPLEX_WIDETAG] = size_boxed;
2222 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2223 sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
2225 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2226 sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
2228 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2229 sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
2231 sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
2232 sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
2233 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2234 sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string;
2236 sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
2237 sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
2238 sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
2239 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
2240 size_vector_unsigned_byte_2;
2241 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
2242 size_vector_unsigned_byte_4;
2243 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] =
2244 size_vector_unsigned_byte_8;
2245 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
2246 size_vector_unsigned_byte_8;
2247 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] =
2248 size_vector_unsigned_byte_16;
2249 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
2250 size_vector_unsigned_byte_16;
2251 #if (N_WORD_BITS == 32)
2252 sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2253 size_vector_unsigned_byte_32;
2255 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] =
2256 size_vector_unsigned_byte_32;
2257 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
2258 size_vector_unsigned_byte_32;
2259 #if (N_WORD_BITS == 64)
2260 sizetab[SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG] =
2261 size_vector_unsigned_byte_64;
2263 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2264 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] =
2265 size_vector_unsigned_byte_64;
2267 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2268 sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] =
2269 size_vector_unsigned_byte_64;
2271 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2272 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
2274 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2275 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
2276 size_vector_unsigned_byte_16;
2278 #if (N_WORD_BITS == 32)
2279 sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2280 size_vector_unsigned_byte_32;
2282 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2283 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
2284 size_vector_unsigned_byte_32;
2286 #if (N_WORD_BITS == 64)
2287 sizetab[SIMPLE_ARRAY_FIXNUM_WIDETAG] =
2288 size_vector_unsigned_byte_64;
2290 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2291 sizetab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] =
2292 size_vector_unsigned_byte_64;
2294 sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
2295 sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
2296 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2297 sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
2299 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2300 sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
2301 size_vector_complex_single_float;
2303 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2304 sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
2305 size_vector_complex_double_float;
2307 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2308 sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
2309 size_vector_complex_long_float;
2311 sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
2312 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2313 sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed;
2315 sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
2316 sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
2317 sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
2318 sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
2319 sizetab[CODE_HEADER_WIDETAG] = size_code_header;
2321 /* We shouldn't see these, so just lose if it happens. */
2322 sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
2323 sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
2325 sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
2326 sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
2327 sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
2328 sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
2329 sizetab[CHARACTER_WIDETAG] = size_immediate;
2330 sizetab[SAP_WIDETAG] = size_unboxed;
2331 #ifdef SIMD_PACK_WIDETAG
2332 sizetab[SIMD_PACK_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) || is_lisp_immediate(thing))
2376 count = (sizetab[widetag_of(thing)])(start);
2378 /* Check whether the pointer is within this object. */
2379 if ((pointer >= start) && (pointer < (start+count))) {
2381 /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
2385 /* Round up the count. */
2386 count = CEILING(count,2);
2394 /* Helper for valid_lisp_pointer_p (below) and
2395 * possibly_valid_dynamic_space_pointer (gencgc).
2397 * pointer is the pointer to validate, and start_addr is the address
2398 * of the enclosing object.
2401 looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr)
2403 if (!is_lisp_pointer(pointer)) {
2407 /* Check that the object pointed to is consistent with the pointer
2409 switch (lowtag_of(pointer)) {
2410 case FUN_POINTER_LOWTAG:
2411 /* Start_addr should be the enclosing code object, or a closure
2413 switch (widetag_of(*start_addr)) {
2414 case CODE_HEADER_WIDETAG:
2415 /* Make sure we actually point to a function in the code object,
2416 * as opposed to a random point there. */
2417 if (SIMPLE_FUN_HEADER_WIDETAG==widetag_of(native_pointer(pointer)[0]))
2421 case CLOSURE_HEADER_WIDETAG:
2422 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2423 if (pointer != make_lispobj(start_addr, FUN_POINTER_LOWTAG)) {
2431 case LIST_POINTER_LOWTAG:
2432 if (pointer != make_lispobj(start_addr, LIST_POINTER_LOWTAG)) {
2435 /* Is it plausible cons? */
2436 if ((is_lisp_pointer(start_addr[0]) ||
2437 is_lisp_immediate(start_addr[0])) &&
2438 (is_lisp_pointer(start_addr[1]) ||
2439 is_lisp_immediate(start_addr[1])))
2444 case INSTANCE_POINTER_LOWTAG:
2445 if (pointer != make_lispobj(start_addr, INSTANCE_POINTER_LOWTAG)) {
2448 if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2452 case OTHER_POINTER_LOWTAG:
2454 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2455 /* The all-architecture test below is good as far as it goes,
2456 * but an LRA object is similar to a FUN-POINTER: It is
2457 * embedded within a CODE-OBJECT pointed to by start_addr, and
2458 * cannot be found by simply walking the heap, therefore we
2459 * need to check for it. -- AB, 2010-Jun-04 */
2460 if ((widetag_of(start_addr[0]) == CODE_HEADER_WIDETAG)) {
2461 lispobj *potential_lra = native_pointer(pointer);
2462 if ((widetag_of(potential_lra[0]) == RETURN_PC_HEADER_WIDETAG) &&
2463 ((potential_lra - HeaderValue(potential_lra[0])) == start_addr)) {
2464 return 1; /* It's as good as we can verify. */
2469 if (pointer != make_lispobj(start_addr, OTHER_POINTER_LOWTAG)) {
2472 /* Is it plausible? Not a cons. XXX should check the headers. */
2473 if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2476 switch (widetag_of(start_addr[0])) {
2477 case UNBOUND_MARKER_WIDETAG:
2478 case NO_TLS_VALUE_MARKER_WIDETAG:
2479 case CHARACTER_WIDETAG:
2480 #if N_WORD_BITS == 64
2481 case SINGLE_FLOAT_WIDETAG:
2485 /* only pointed to by function pointers? */
2486 case CLOSURE_HEADER_WIDETAG:
2487 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2490 case INSTANCE_HEADER_WIDETAG:
2493 /* the valid other immediate pointer objects */
2494 case SIMPLE_VECTOR_WIDETAG:
2496 case COMPLEX_WIDETAG:
2497 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2498 case COMPLEX_SINGLE_FLOAT_WIDETAG:
2500 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2501 case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2503 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2504 case COMPLEX_LONG_FLOAT_WIDETAG:
2506 #ifdef SIMD_PACK_WIDETAG
2507 case SIMD_PACK_WIDETAG:
2509 case SIMPLE_ARRAY_WIDETAG:
2510 case COMPLEX_BASE_STRING_WIDETAG:
2511 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2512 case COMPLEX_CHARACTER_STRING_WIDETAG:
2514 case COMPLEX_VECTOR_NIL_WIDETAG:
2515 case COMPLEX_BIT_VECTOR_WIDETAG:
2516 case COMPLEX_VECTOR_WIDETAG:
2517 case COMPLEX_ARRAY_WIDETAG:
2518 case VALUE_CELL_HEADER_WIDETAG:
2519 case SYMBOL_HEADER_WIDETAG:
2521 case CODE_HEADER_WIDETAG:
2522 case BIGNUM_WIDETAG:
2523 #if N_WORD_BITS != 64
2524 case SINGLE_FLOAT_WIDETAG:
2526 case DOUBLE_FLOAT_WIDETAG:
2527 #ifdef LONG_FLOAT_WIDETAG
2528 case LONG_FLOAT_WIDETAG:
2530 case SIMPLE_BASE_STRING_WIDETAG:
2531 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2532 case SIMPLE_CHARACTER_STRING_WIDETAG:
2534 case SIMPLE_BIT_VECTOR_WIDETAG:
2535 case SIMPLE_ARRAY_NIL_WIDETAG:
2536 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2537 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2538 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2539 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2540 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2541 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2543 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
2545 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2546 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2547 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2548 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2550 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2551 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2553 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2554 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2556 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2557 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2560 case SIMPLE_ARRAY_FIXNUM_WIDETAG:
2562 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2563 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2565 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2566 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2568 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2569 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2570 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2571 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2573 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2574 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2576 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2577 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2579 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2580 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2583 case WEAK_POINTER_WIDETAG:
2598 /* Used by the debugger to validate possibly bogus pointers before
2599 * calling MAKE-LISP-OBJ on them.
2601 * FIXME: We would like to make this perfect, because if the debugger
2602 * constructs a reference to a bugs lisp object, and it ends up in a
2603 * location scavenged by the GC all hell breaks loose.
2605 * Whereas possibly_valid_dynamic_space_pointer has to be conservative
2606 * and return true for all valid pointers, this could actually be eager
2607 * and lie about a few pointers without bad results... but that should
2608 * be reflected in the name.
2611 valid_lisp_pointer_p(lispobj *pointer)
2614 if (((start=search_dynamic_space(pointer))!=NULL) ||
2615 ((start=search_static_space(pointer))!=NULL) ||
2616 ((start=search_read_only_space(pointer))!=NULL))
2617 return looks_like_valid_lisp_pointer_p((lispobj)pointer, start);
2623 maybe_gc(os_context_t *context)
2625 lispobj gc_happened;
2626 struct thread *thread = arch_os_get_current_thread();
2628 fake_foreign_function_call(context);
2629 /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
2630 * which case we will be running with no gc trigger barrier
2631 * thing for a while. But it shouldn't be long until the end
2634 * FIXME: It would be good to protect the end of dynamic space for
2635 * CheneyGC and signal a storage condition from there.
2638 /* Restore the signal mask from the interrupted context before
2639 * calling into Lisp if interrupts are enabled. Why not always?
2641 * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
2642 * interrupt hits while in SUB-GC, it is deferred and the
2643 * os_context_sigmask of that interrupt is set to block further
2644 * deferrable interrupts (until the first one is
2645 * handled). Unfortunately, that context refers to this place and
2646 * when we return from here the signals will not be blocked.
2648 * A kludgy alternative is to propagate the sigmask change to the
2651 #if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
2652 check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
2653 unblock_gc_signals(0, 0);
2655 FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
2656 /* FIXME: Nothing must go wrong during GC else we end up running
2657 * the debugger, error handlers, and user code in general in a
2658 * potentially unsafe place. Running out of the control stack or
2659 * the heap in SUB-GC are ways to lose. Of course, deferrables
2660 * cannot be unblocked because there may be a pending handler, or
2661 * we may even be in a WITHOUT-INTERRUPTS. */
2662 gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
2663 FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
2664 (gc_happened == NIL)
2666 : ((gc_happened == T)
2669 /* gc_happened can take three values: T, NIL, 0.
2671 * T means that the thread managed to trigger a GC, and post-gc
2674 * NIL means that the thread is within without-gcing, and no GC
2677 * Finally, 0 means that *a* GC has occurred, but it wasn't
2678 * triggered by this thread; success, but post-gc doesn't have
2681 if ((gc_happened == T) &&
2682 /* See if interrupts are enabled or it's possible to enable
2683 * them. POST-GC has a similar check, but we don't want to
2684 * unlock deferrables in that case and get a pending interrupt
2686 ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
2687 (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
2688 #ifndef LISP_FEATURE_WIN32
2689 sigset_t *context_sigmask = os_context_sigmask_addr(context);
2690 if (!deferrables_blocked_p(context_sigmask)) {
2691 thread_sigmask(SIG_SETMASK, context_sigmask, 0);
2692 #ifndef LISP_FEATURE_SB_SAFEPOINT
2693 check_gc_signals_unblocked_or_lose(0);
2696 FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
2697 funcall0(StaticSymbolFunction(POST_GC));
2698 #ifndef LISP_FEATURE_WIN32
2700 FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
2704 undo_fake_foreign_function_call(context);
2705 FSHOW((stderr, "/maybe_gc: returning\n"));
2706 return (gc_happened != NIL);
2709 #define BYTES_ZERO_BEFORE_END (1<<12)
2711 /* There used to be a similar function called SCRUB-CONTROL-STACK in
2712 * Lisp and another called zero_stack() in cheneygc.c, but since it's
2713 * shorter to express in, and more often called from C, I keep only
2714 * the C one after fixing it. -- MG 2009-03-25 */
2716 /* Zero the unused portion of the control stack so that old objects
2717 * are not kept alive because of uninitialized stack variables.
2719 * "To summarize the problem, since not all allocated stack frame
2720 * slots are guaranteed to be written by the time you call an another
2721 * function or GC, there may be garbage pointers retained in your dead
2722 * stack locations. The stack scrubbing only affects the part of the
2723 * stack from the SP to the end of the allocated stack." - ram, on
2724 * cmucl-imp, Tue, 25 Sep 2001
2726 * So, as an (admittedly lame) workaround, from time to time we call
2727 * scrub-control-stack to zero out all the unused portion. This is
2728 * supposed to happen when the stack is mostly empty, so that we have
2729 * a chance of clearing more of it: callers are currently (2002.07.18)
2730 * REPL, SUB-GC and sig_stop_for_gc_handler. */
2732 /* Take care not to tread on the guard page and the hard guard page as
2733 * it would be unkind to sig_stop_for_gc_handler. Touching the return
2734 * guard page is not dangerous. For this to work the guard page must
2735 * be zeroed when protected. */
2737 /* FIXME: I think there is no guarantee that once
2738 * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
2739 * may be what the "lame" adjective in the above comment is for. In
2740 * this case, exact gc may lose badly. */
2742 scrub_control_stack()
2744 scrub_thread_control_stack(arch_os_get_current_thread());
2748 scrub_thread_control_stack(struct thread *th)
2750 os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
2751 os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
2752 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
2753 /* On these targets scrubbing from C is a bad idea, so we punt to
2754 * a routine in $ARCH-assem.S. */
2755 extern void arch_scrub_control_stack(struct thread *, os_vm_address_t, os_vm_address_t);
2756 arch_scrub_control_stack(th, guard_page_address, hard_guard_page_address);
2758 lispobj *sp = access_control_stack_pointer(th);
2760 if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
2761 ((os_vm_address_t)sp >= hard_guard_page_address)) ||
2762 (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
2763 ((os_vm_address_t)sp >= guard_page_address) &&
2764 (th->control_stack_guard_page_protected != NIL)))
2766 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
2769 } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2770 if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
2775 } while (((uword_t)sp--) & (BYTES_ZERO_BEFORE_END - 1));
2779 } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2780 if ((os_vm_address_t)sp >= hard_guard_page_address)
2785 } while (((uword_t)++sp) & (BYTES_ZERO_BEFORE_END - 1));
2787 #endif /* LISP_FEATURE_C_STACK_IS_CONTROL_STACK */
2790 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
2793 scavenge_control_stack(struct thread *th)
2795 lispobj *object_ptr;
2797 /* In order to properly support dynamic-extent allocation of
2798 * non-CONS objects, the control stack requires special handling.
2799 * Rather than calling scavenge() directly, grovel over it fixing
2800 * broken hearts, scavenging pointers to oldspace, and pitching a
2801 * fit when encountering unboxed data. This prevents stray object
2802 * headers from causing the scavenger to blow past the end of the
2803 * stack (an error case checked in scavenge()). We don't worry
2804 * about treating unboxed words as boxed or vice versa, because
2805 * the compiler isn't allowed to store unboxed objects on the
2806 * control stack. -- AB, 2011-Dec-02 */
2808 for (object_ptr = th->control_stack_start;
2809 object_ptr < access_control_stack_pointer(th);
2812 lispobj object = *object_ptr;
2813 #ifdef LISP_FEATURE_GENCGC
2814 if (forwarding_pointer_p(object_ptr))
2815 lose("unexpected forwarding pointer in scavenge_control_stack: %p, start=%p, end=%p\n",
2816 object_ptr, th->control_stack_start, access_control_stack_pointer(th));
2818 if (is_lisp_pointer(object) && from_space_p(object)) {
2819 /* It currently points to old space. Check for a
2820 * forwarding pointer. */
2821 lispobj *ptr = native_pointer(object);
2822 if (forwarding_pointer_p(ptr)) {
2823 /* Yes, there's a forwarding pointer. */
2824 *object_ptr = LOW_WORD(forwarding_pointer_value(ptr));
2826 /* Scavenge that pointer. */
2827 long n_words_scavenged =
2828 (scavtab[widetag_of(object)])(object_ptr, object);
2829 gc_assert(n_words_scavenged == 1);
2831 } else if (scavtab[widetag_of(object)] == scav_lose) {
2832 lose("unboxed object in scavenge_control_stack: %p->%x, start=%p, end=%p\n",
2833 object_ptr, object, th->control_stack_start, access_control_stack_pointer(th));
2838 /* Scavenging Interrupt Contexts */
2840 static int boxed_registers[] = BOXED_REGISTERS;
2842 /* The GC has a notion of an "interior pointer" register, an unboxed
2843 * register that typically contains a pointer to inside an object
2844 * referenced by another pointer. The most obvious of these is the
2845 * program counter, although many compiler backends define a "Lisp
2846 * Interior Pointer" register known to the runtime as reg_LIP, and
2847 * various CPU architectures have other registers that also partake of
2848 * the interior-pointer nature. As the code for pairing an interior
2849 * pointer value up with its "base" register, and fixing it up after
2850 * scavenging is complete is horribly repetitive, a few macros paper
2851 * over the monotony. --AB, 2010-Jul-14 */
2853 /* These macros are only ever used over a lexical environment which
2854 * defines a pointer to an os_context_t called context, thus we don't
2855 * bother to pass that context in as a parameter. */
2857 /* Define how to access a given interior pointer. */
2858 #define ACCESS_INTERIOR_POINTER_pc \
2859 *os_context_pc_addr(context)
2860 #define ACCESS_INTERIOR_POINTER_lip \
2861 *os_context_register_addr(context, reg_LIP)
2862 #define ACCESS_INTERIOR_POINTER_lr \
2863 *os_context_lr_addr(context)
2864 #define ACCESS_INTERIOR_POINTER_npc \
2865 *os_context_npc_addr(context)
2866 #define ACCESS_INTERIOR_POINTER_ctr \
2867 *os_context_ctr_addr(context)
2869 #define INTERIOR_POINTER_VARS(name) \
2870 uword_t name##_offset; \
2871 int name##_register_pair
2873 #define PAIR_INTERIOR_POINTER(name) \
2874 pair_interior_pointer(context, \
2875 ACCESS_INTERIOR_POINTER_##name, \
2877 &name##_register_pair)
2879 /* One complexity here is that if a paired register is not found for
2880 * an interior pointer, then that pointer does not get updated.
2881 * Originally, there was some commentary about using an index of -1
2882 * when calling os_context_register_addr() on SPARC referring to the
2883 * program counter, but the real reason is to allow an interior
2884 * pointer register to point to the runtime, read-only space, or
2885 * static space without problems. */
2886 #define FIXUP_INTERIOR_POINTER(name) \
2888 if (name##_register_pair >= 0) { \
2889 ACCESS_INTERIOR_POINTER_##name = \
2890 (*os_context_register_addr(context, \
2891 name##_register_pair) \
2899 pair_interior_pointer(os_context_t *context, uword_t pointer,
2900 uword_t *saved_offset, int *register_pair)
2905 * I (RLT) think this is trying to find the boxed register that is
2906 * closest to the LIP address, without going past it. Usually, it's
2907 * reg_CODE or reg_LRA. But sometimes, nothing can be found.
2909 /* 0x7FFFFFFF on 32-bit platforms;
2910 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
2911 *saved_offset = (((uword_t)1) << (N_WORD_BITS - 1)) - 1;
2912 *register_pair = -1;
2913 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2918 index = boxed_registers[i];
2919 reg = *os_context_register_addr(context, index);
2921 /* An interior pointer is never relative to a non-pointer
2922 * register (an oversight in the original implementation).
2923 * The simplest argument for why this is true is to consider
2924 * the fixnum that happens by coincide to be the word-index in
2925 * memory of the header for some object plus two. This is
2926 * happenstance would cause the register containing the fixnum
2927 * to be selected as the register_pair if the interior pointer
2928 * is to anywhere after the first two words of the object.
2929 * The fixnum won't be changed during GC, but the object might
2930 * move, thus destroying the interior pointer. --AB,
2933 if (is_lisp_pointer(reg) &&
2934 ((reg & ~LOWTAG_MASK) <= pointer)) {
2935 offset = pointer - (reg & ~LOWTAG_MASK);
2936 if (offset < *saved_offset) {
2937 *saved_offset = offset;
2938 *register_pair = index;
2945 scavenge_interrupt_context(os_context_t * context)
2949 /* FIXME: The various #ifdef noise here is precisely that: noise.
2950 * Is it possible to fold it into the macrology so that we have
2951 * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
2952 * compile out for the registers that don't exist on a given
2955 INTERIOR_POINTER_VARS(pc);
2957 INTERIOR_POINTER_VARS(lip);
2959 #ifdef ARCH_HAS_LINK_REGISTER
2960 INTERIOR_POINTER_VARS(lr);
2962 #ifdef ARCH_HAS_NPC_REGISTER
2963 INTERIOR_POINTER_VARS(npc);
2965 #ifdef LISP_FEATURE_PPC
2966 INTERIOR_POINTER_VARS(ctr);
2969 PAIR_INTERIOR_POINTER(pc);
2971 PAIR_INTERIOR_POINTER(lip);
2973 #ifdef ARCH_HAS_LINK_REGISTER
2974 PAIR_INTERIOR_POINTER(lr);
2976 #ifdef ARCH_HAS_NPC_REGISTER
2977 PAIR_INTERIOR_POINTER(npc);
2979 #ifdef LISP_FEATURE_PPC
2980 PAIR_INTERIOR_POINTER(ctr);
2983 /* Scavenge all boxed registers in the context. */
2984 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2988 index = boxed_registers[i];
2989 foo = *os_context_register_addr(context, index);
2991 *os_context_register_addr(context, index) = foo;
2993 /* this is unlikely to work as intended on bigendian
2994 * 64 bit platforms */
2996 scavenge((lispobj *) os_context_register_addr(context, index), 1);
2999 /* Now that the scavenging is done, repair the various interior
3001 FIXUP_INTERIOR_POINTER(pc);
3003 FIXUP_INTERIOR_POINTER(lip);
3005 #ifdef ARCH_HAS_LINK_REGISTER
3006 FIXUP_INTERIOR_POINTER(lr);
3008 #ifdef ARCH_HAS_NPC_REGISTER
3009 FIXUP_INTERIOR_POINTER(npc);
3011 #ifdef LISP_FEATURE_PPC
3012 FIXUP_INTERIOR_POINTER(ctr);
3017 scavenge_interrupt_contexts(struct thread *th)
3020 os_context_t *context;
3022 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
3024 #if defined(DEBUG_PRINT_CONTEXT_INDEX)
3025 printf("Number of active contexts: %d\n", index);
3028 for (i = 0; i < index; i++) {
3029 context = th->interrupt_contexts[i];
3030 scavenge_interrupt_context(context);
3033 #endif /* x86oid targets */