/* * Garbage Collection common functions for scavenging, moving and sizing * objects. These are for use with both GC (stop & copy GC) and GENCGC */ /* * This software is part of the SBCL system. See the README file for * more information. * * This software is derived from the CMU CL system, which was * written at Carnegie Mellon University and released into the * public domain. The software is in the public domain and is * provided with absolutely no warranty. See the COPYING and CREDITS * files for more information. */ /* * For a review of garbage collection techniques (e.g. generational * GC) and terminology (e.g. "scavenging") see Paul R. Wilson, * "Uniprocessor Garbage Collection Techniques". As of 20000618, this * had been accepted for _ACM Computing Surveys_ and was available * as a PostScript preprint through * * as * . */ #include #include #include #include "sbcl.h" #include "runtime.h" #include "os.h" #include "interr.h" #include "globals.h" #include "interrupt.h" #include "validate.h" #include "lispregs.h" #include "arch.h" #include "fixnump.h" #include "gc.h" #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" #include "genesis/layout.h" #include "genesis/hash-table.h" #include "gc-internal.h" #ifdef LISP_FEATURE_SPARC #define LONG_FLOAT_SIZE 4 #else #ifdef LISP_FEATURE_X86 #define LONG_FLOAT_SIZE 3 #endif #endif size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE; inline static boolean forwarding_pointer_p(lispobj *pointer) { lispobj first_word=*pointer; #ifdef LISP_FEATURE_GENCGC return (first_word == 0x01); #else return (is_lisp_pointer(first_word) && new_space_p(first_word)); #endif } static inline lispobj * forwarding_pointer_value(lispobj *pointer) { #ifdef LISP_FEATURE_GENCGC return (lispobj *) ((pointer_sized_uint_t) pointer[1]); #else return (lispobj *) ((pointer_sized_uint_t) pointer[0]); #endif } static inline lispobj set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) { #ifdef LISP_FEATURE_GENCGC pointer[0]=0x01; pointer[1]=newspace_copy; #else pointer[0]=newspace_copy; #endif return newspace_copy; } long (*scavtab[256])(lispobj *where, lispobj object); lispobj (*transother[256])(lispobj object); long (*sizetab[256])(lispobj *where); struct weak_pointer *weak_pointers; unsigned long bytes_consed_between_gcs = 12*1024*1024; /* * copying objects */ /* to copy a boxed object */ lispobj copy_object(lispobj object, long nwords) { int tag; lispobj *new; gc_assert(is_lisp_pointer(object)); gc_assert(from_space_p(object)); gc_assert((nwords & 0x01) == 0); /* Get tag of object. */ tag = lowtag_of(object); /* Allocate space. */ new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK); /* Copy the object. */ memcpy(new,native_pointer(object),nwords*N_WORD_BYTES); return make_lispobj(new,tag); } static long scav_lose(lispobj *where, lispobj object); /* forward decl */ /* FIXME: Most calls end up going to some trouble to compute an * 'n_words' value for this function. The system might be a little * simpler if this function used an 'end' parameter instead. */ void scavenge(lispobj *start, long n_words) { lispobj *end = start + n_words; lispobj *object_ptr; long n_words_scavenged; for (object_ptr = start; object_ptr < end; object_ptr += n_words_scavenged) { lispobj object = *object_ptr; #ifdef LISP_FEATURE_GENCGC gc_assert(!forwarding_pointer_p(object_ptr)); #endif if (is_lisp_pointer(object)) { if (from_space_p(object)) { /* It currently points to old space. Check for a * forwarding pointer. */ lispobj *ptr = native_pointer(object); if (forwarding_pointer_p(ptr)) { /* Yes, there's a forwarding pointer. */ *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); n_words_scavenged = 1; } else { /* Scavenge that pointer. */ n_words_scavenged = (scavtab[widetag_of(object)])(object_ptr, object); } } else { /* It points somewhere other than oldspace. Leave it * alone. */ n_words_scavenged = 1; } } #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) /* This workaround is probably not needed for those ports which don't have a partitioned register set (and therefore scan the stack conservatively for roots). */ else if (n_words == 1) { /* there are some situations where an other-immediate may end up in a descriptor register. I'm not sure whether this is supposed to happen, but if it does then we don't want to (a) barf or (b) scavenge over the data-block, because there isn't one. So, if we're checking a single word and it's anything other than a pointer, just hush it up */ int widetag = widetag_of(object); n_words_scavenged = 1; if ((scavtab[widetag] == scav_lose) || (((sizetab[widetag])(object_ptr)) > 1)) { fprintf(stderr,"warning: \ attempted to scavenge non-descriptor value %x at %p.\n\n\ If you can reproduce this warning, please send a bug report\n\ (see manual page for details).\n", object, object_ptr); } } #endif else if (fixnump(object)) { /* It's a fixnum: really easy.. */ n_words_scavenged = 1; } else { /* It's some sort of header object or another. */ n_words_scavenged = (scavtab[widetag_of(object)])(object_ptr, object); } } gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n", object_ptr, start, end); } static lispobj trans_fun_header(lispobj object); /* forward decls */ static lispobj trans_boxed(lispobj object); static long scav_fun_pointer(lispobj *where, lispobj object) { lispobj *first_pointer; lispobj copy; gc_assert(is_lisp_pointer(object)); /* Object is a pointer into from_space - not a FP. */ first_pointer = (lispobj *) native_pointer(object); /* must transport object -- object may point to either a function * header, a closure function header, or to a closure header. */ switch (widetag_of(*first_pointer)) { case SIMPLE_FUN_HEADER_WIDETAG: copy = trans_fun_header(object); break; default: copy = trans_boxed(object); break; } if (copy != object) { /* Set forwarding pointer */ set_forwarding_pointer(first_pointer,copy); } gc_assert(is_lisp_pointer(copy)); gc_assert(!from_space_p(copy)); *where = copy; return 1; } static struct code * trans_code(struct code *code) { struct code *new_code; lispobj first, l_code, l_new_code; long nheader_words, ncode_words, nwords; unsigned long displacement; lispobj fheaderl, *prev_pointer; /* if object has already been transported, just return pointer */ first = code->header; if (forwarding_pointer_p((lispobj *)code)) { #ifdef DEBUG_CODE_GC printf("Was already transported\n"); #endif return (struct code *) forwarding_pointer_value ((lispobj *)((pointer_sized_uint_t) code)); } gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG); /* prepare to transport the code vector */ l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; ncode_words = fixnum_value(code->code_size); nheader_words = HeaderValue(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); l_new_code = copy_object(l_code, nwords); new_code = (struct code *) native_pointer(l_new_code); #if defined(DEBUG_CODE_GC) printf("Old code object at 0x%08x, new code object at 0x%08x.\n", (unsigned long) code, (unsigned long) new_code); printf("Code object is %d words long.\n", nwords); #endif #ifdef LISP_FEATURE_GENCGC if (new_code == code) return new_code; #endif displacement = l_new_code - l_code; set_forwarding_pointer((lispobj *)code, l_new_code); /* set forwarding pointers for all the function headers in the */ /* code object. also fix all self pointers */ fheaderl = code->entry_points; prev_pointer = &new_code->entry_points; while (fheaderl != NIL) { struct simple_fun *fheaderp, *nfheaderp; lispobj nfheaderl; fheaderp = (struct simple_fun *) native_pointer(fheaderl); gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); /* Calculate the new function pointer and the new */ /* function header. */ nfheaderl = fheaderl + displacement; nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); #ifdef DEBUG_CODE_GC printf("fheaderp->header (at %x) <- %x\n", &(fheaderp->header) , nfheaderl); #endif set_forwarding_pointer((lispobj *)fheaderp, nfheaderl); /* fix self pointer. */ nfheaderp->self = #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) FUN_RAW_ADDR_OFFSET + #endif nfheaderl; *prev_pointer = nfheaderl; fheaderl = fheaderp->next; prev_pointer = &nfheaderp->next; } #ifdef LISP_FEATURE_GENCGC /* Cheneygc doesn't need this os_flush_icache, it flushes the whole spaces once when all copying is done. */ os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words), ncode_words * sizeof(long)); #endif #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) gencgc_apply_code_fixups(code, new_code); #endif return new_code; } static long scav_code_header(lispobj *where, lispobj object) { struct code *code; long n_header_words, n_code_words, n_words; lispobj entry_point; /* tagged pointer to entry point */ struct simple_fun *function_ptr; /* untagged pointer to entry point */ code = (struct code *) where; n_code_words = fixnum_value(code->code_size); n_header_words = HeaderValue(object); n_words = n_code_words + n_header_words; n_words = CEILING(n_words, 2); /* Scavenge the boxed section of the code data block. */ scavenge(where + 1, n_header_words - 1); /* Scavenge the boxed section of each function object in the * code data block. */ for (entry_point = code->entry_points; entry_point != NIL; entry_point = function_ptr->next) { gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n is not a lisp pointer.", (long)entry_point); function_ptr = (struct simple_fun *) native_pointer(entry_point); gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); scavenge(&function_ptr->name, 1); scavenge(&function_ptr->arglist, 1); scavenge(&function_ptr->type, 1); scavenge(&function_ptr->xrefs, 1); } return n_words; } static lispobj trans_code_header(lispobj object) { struct code *ncode; ncode = trans_code((struct code *) native_pointer(object)); return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG; } static long size_code_header(lispobj *where) { struct code *code; long nheader_words, ncode_words, nwords; code = (struct code *) where; ncode_words = fixnum_value(code->code_size); nheader_words = HeaderValue(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); return nwords; } #if !defined(LISP_FEATURE_X86) && ! defined(LISP_FEATURE_X86_64) static long scav_return_pc_header(lispobj *where, lispobj object) { lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n", (unsigned long) where, (unsigned long) object); return 0; /* bogus return value to satisfy static type checking */ } #endif /* LISP_FEATURE_X86 */ static lispobj trans_return_pc_header(lispobj object) { struct simple_fun *return_pc; unsigned long offset; struct code *code, *ncode; return_pc = (struct simple_fun *) native_pointer(object); /* FIXME: was times 4, should it really be N_WORD_BYTES? */ offset = HeaderValue(return_pc->header) * N_WORD_BYTES; /* Transport the whole code object */ code = (struct code *) ((unsigned long) return_pc - offset); ncode = trans_code(code); return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG; } /* On the 386, closures hold a pointer to the raw address instead of the * function object, so we can use CALL [$FDEFN+const] to invoke * the function without loading it into a register. Given that code * objects don't move, we don't need to update anything, but we do * have to figure out that the function is still live. */ #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) static long scav_closure_header(lispobj *where, lispobj object) { struct closure *closure; lispobj fun; closure = (struct closure *)where; fun = closure->fun - FUN_RAW_ADDR_OFFSET; scavenge(&fun, 1); #ifdef LISP_FEATURE_GENCGC /* The function may have moved so update the raw address. But * don't write unnecessarily. */ if (closure->fun != fun + FUN_RAW_ADDR_OFFSET) closure->fun = fun + FUN_RAW_ADDR_OFFSET; #endif return 2; } #endif #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) static long scav_fun_header(lispobj *where, lispobj object) { lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n", (unsigned long) where, (unsigned long) object); return 0; /* bogus return value to satisfy static type checking */ } #endif /* LISP_FEATURE_X86 */ static lispobj trans_fun_header(lispobj object) { struct simple_fun *fheader; unsigned long offset; struct code *code, *ncode; fheader = (struct simple_fun *) native_pointer(object); /* FIXME: was times 4, should it really be N_WORD_BYTES? */ offset = HeaderValue(fheader->header) * N_WORD_BYTES; /* Transport the whole code object */ code = (struct code *) ((unsigned long) fheader - offset); ncode = trans_code(code); return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG; } /* * instances */ static long scav_instance_pointer(lispobj *where, lispobj object) { lispobj copy, *first_pointer; /* Object is a pointer into from space - not a FP. */ copy = trans_boxed(object); #ifdef LISP_FEATURE_GENCGC gc_assert(copy != object); #endif first_pointer = (lispobj *) native_pointer(object); set_forwarding_pointer(first_pointer,copy); *where = copy; return 1; } /* * lists and conses */ static lispobj trans_list(lispobj object); static long scav_list_pointer(lispobj *where, lispobj object) { lispobj first, *first_pointer; gc_assert(is_lisp_pointer(object)); /* Object is a pointer into from space - not FP. */ first_pointer = (lispobj *) native_pointer(object); first = trans_list(object); gc_assert(first != object); /* Set forwarding pointer */ set_forwarding_pointer(first_pointer, first); gc_assert(is_lisp_pointer(first)); gc_assert(!from_space_p(first)); *where = first; return 1; } static lispobj trans_list(lispobj object) { lispobj new_list_pointer; struct cons *cons, *new_cons; lispobj cdr; cons = (struct cons *) native_pointer(object); /* Copy 'object'. */ new_cons = (struct cons *) gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); new_cons->car = cons->car; new_cons->cdr = cons->cdr; /* updated later */ new_list_pointer = make_lispobj(new_cons,lowtag_of(object)); /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */ cdr = cons->cdr; set_forwarding_pointer((lispobj *)cons, new_list_pointer); /* Try to linearize the list in the cdr direction to help reduce * paging. */ while (1) { lispobj new_cdr; struct cons *cdr_cons, *new_cdr_cons; if(lowtag_of(cdr) != LIST_POINTER_LOWTAG || !from_space_p(cdr) || forwarding_pointer_p((lispobj *)native_pointer(cdr))) break; cdr_cons = (struct cons *) native_pointer(cdr); /* Copy 'cdr'. */ new_cdr_cons = (struct cons*) gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); new_cdr_cons->car = cdr_cons->car; new_cdr_cons->cdr = cdr_cons->cdr; new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr)); /* Grab the cdr before it is clobbered. */ cdr = cdr_cons->cdr; set_forwarding_pointer((lispobj *)cdr_cons, new_cdr); /* Update the cdr of the last cons copied into new space to * keep the newspace scavenge from having to do it. */ new_cons->cdr = new_cdr; new_cons = new_cdr_cons; } return new_list_pointer; } /* * scavenging and transporting other pointers */ static long scav_other_pointer(lispobj *where, lispobj object) { lispobj first, *first_pointer; gc_assert(is_lisp_pointer(object)); /* Object is a pointer into from space - not FP. */ first_pointer = (lispobj *) native_pointer(object); first = (transother[widetag_of(*first_pointer)])(object); if (first != object) { set_forwarding_pointer(first_pointer, first); #ifdef LISP_FEATURE_GENCGC *where = first; #endif } #ifndef LISP_FEATURE_GENCGC *where = first; #endif gc_assert(is_lisp_pointer(first)); gc_assert(!from_space_p(first)); return 1; } /* * immediate, boxed, and unboxed objects */ static long size_pointer(lispobj *where) { return 1; } static long scav_immediate(lispobj *where, lispobj object) { return 1; } static lispobj trans_immediate(lispobj object) { lose("trying to transport an immediate\n"); return NIL; /* bogus return value to satisfy static type checking */ } static long size_immediate(lispobj *where) { return 1; } static long scav_boxed(lispobj *where, lispobj object) { return 1; } static long scav_instance(lispobj *where, lispobj object) { lispobj nuntagged; long ntotal = HeaderValue(object); lispobj layout = ((struct instance *)where)->slots[0]; if (!layout) return 1; if (forwarding_pointer_p(native_pointer(layout))) layout = (lispobj) forwarding_pointer_value(native_pointer(layout)); nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots; scavenge(where + 1, ntotal - fixnum_value(nuntagged)); return ntotal + 1; } static lispobj trans_boxed(lispobj object) { lispobj header; unsigned long length; gc_assert(is_lisp_pointer(object)); header = *((lispobj *) native_pointer(object)); length = HeaderValue(header) + 1; length = CEILING(length, 2); return copy_object(object, length); } static long size_boxed(lispobj *where) { lispobj header; unsigned long length; header = *where; length = HeaderValue(header) + 1; length = CEILING(length, 2); return length; } /* Note: on the sparc we don't have to do anything special for fdefns, */ /* 'cause the raw-addr has a function lowtag. */ #if !defined(LISP_FEATURE_SPARC) static long scav_fdefn(lispobj *where, lispobj object) { struct fdefn *fdefn; fdefn = (struct fdefn *)where; /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n", fdefn->fun, fdefn->raw_addr)); */ if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == (char *)((unsigned long)(fdefn->raw_addr))) { scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); /* Don't write unnecessarily. */ if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)) fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET); /* gc.c has more casts here, which may be relevant or alternatively may be compiler warning defeaters. try fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET; */ return sizeof(struct fdefn) / sizeof(lispobj); } else { return 1; } } #endif static long scav_unboxed(lispobj *where, lispobj object) { unsigned long length; length = HeaderValue(object) + 1; length = CEILING(length, 2); return length; } static lispobj trans_unboxed(lispobj object) { lispobj header; unsigned long length; gc_assert(is_lisp_pointer(object)); header = *((lispobj *) native_pointer(object)); length = HeaderValue(header) + 1; length = CEILING(length, 2); return copy_unboxed_object(object, length); } static long size_unboxed(lispobj *where) { lispobj header; unsigned long length; header = *where; length = HeaderValue(header) + 1; length = CEILING(length, 2); return length; } /* vector-like objects */ static long scav_base_string(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; /* NOTE: Strings contain one more byte of data than the length */ /* slot indicates. */ vector = (struct vector *) where; length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 8) + 2, 2); return nwords; } static lispobj trans_base_string(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); /* NOTE: A string contains one more byte of data (a terminating * '\0' to help when interfacing with C functions) than indicated * by the length slot. */ vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 8) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_base_string(lispobj *where) { struct vector *vector; long length, nwords; /* NOTE: A string contains one more byte of data (a terminating * '\0' to help when interfacing with C functions) than indicated * by the length slot. */ vector = (struct vector *) where; length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 8) + 2, 2); return nwords; } static long scav_character_string(lispobj *where, lispobj object) { struct vector *vector; int length, nwords; /* NOTE: Strings contain one more byte of data than the length */ /* slot indicates. */ vector = (struct vector *) where; length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } static lispobj trans_character_string(lispobj object) { struct vector *vector; int length, nwords; gc_assert(is_lisp_pointer(object)); /* NOTE: A string contains one more byte of data (a terminating * '\0' to help when interfacing with C functions) than indicated * by the length slot. */ vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 32) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_character_string(lispobj *where) { struct vector *vector; int length, nwords; /* NOTE: A string contains one more byte of data (a terminating * '\0' to help when interfacing with C functions) than indicated * by the length slot. */ vector = (struct vector *) where; length = fixnum_value(vector->length) + 1; nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } static lispobj trans_vector(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(length + 2, 2); return copy_large_object(object, nwords); } static long size_vector(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(length + 2, 2); return nwords; } static long scav_vector_nil(lispobj *where, lispobj object) { return 2; } static lispobj trans_vector_nil(lispobj object) { gc_assert(is_lisp_pointer(object)); return copy_unboxed_object(object, 2); } static long size_vector_nil(lispobj *where) { /* Just the header word and the length word */ return 2; } static long scav_vector_bit(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 1) + 2, 2); return nwords; } static lispobj trans_vector_bit(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 1) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_bit(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 1) + 2, 2); return nwords; } static long scav_vector_unsigned_byte_2(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 2) + 2, 2); return nwords; } static lispobj trans_vector_unsigned_byte_2(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 2) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_2(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 2) + 2, 2); return nwords; } static long scav_vector_unsigned_byte_4(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 4) + 2, 2); return nwords; } static lispobj trans_vector_unsigned_byte_4(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 4) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_4(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 4) + 2, 2); return nwords; } static long scav_vector_unsigned_byte_8(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 8) + 2, 2); return nwords; } /*********************/ static lispobj trans_vector_unsigned_byte_8(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 8) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_8(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 8) + 2, 2); return nwords; } static long scav_vector_unsigned_byte_16(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 16) + 2, 2); return nwords; } static lispobj trans_vector_unsigned_byte_16(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 16) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_16(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 16) + 2, 2); return nwords; } static long scav_vector_unsigned_byte_32(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } static lispobj trans_vector_unsigned_byte_32(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_32(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } #if N_WORD_BITS == 64 static long scav_vector_unsigned_byte_64(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } static lispobj trans_vector_unsigned_byte_64(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_unsigned_byte_64(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } #endif static long scav_vector_single_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } static lispobj trans_vector_single_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_single_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } static long scav_vector_double_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } static lispobj trans_vector_double_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_double_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG static long scav_vector_long_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2); return nwords; } static lispobj trans_vector_long_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_long_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2); return nwords; } #endif #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG static long scav_vector_complex_single_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } static lispobj trans_vector_complex_single_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_complex_single_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 64) + 2, 2); return nwords; } #endif #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG static long scav_vector_complex_double_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 128) + 2, 2); return nwords; } static lispobj trans_vector_complex_double_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 128) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_complex_double_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(NWORDS(length, 128) + 2, 2); return nwords; } #endif #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG static long scav_vector_complex_long_float(lispobj *where, lispobj object) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2); return nwords; } static lispobj trans_vector_complex_long_float(lispobj object) { struct vector *vector; long length, nwords; gc_assert(is_lisp_pointer(object)); vector = (struct vector *) native_pointer(object); length = fixnum_value(vector->length); nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2); return copy_large_unboxed_object(object, nwords); } static long size_vector_complex_long_float(lispobj *where) { struct vector *vector; long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2); return nwords; } #endif #define WEAK_POINTER_NWORDS \ CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) static lispobj trans_weak_pointer(lispobj object) { lispobj copy; #ifndef LISP_FEATURE_GENCGC struct weak_pointer *wp; #endif gc_assert(is_lisp_pointer(object)); #if defined(DEBUG_WEAK) printf("Transporting weak pointer from 0x%08x\n", object); #endif /* Need to remember where all the weak pointers are that have */ /* been transported so they can be fixed up in a post-GC pass. */ copy = copy_object(object, WEAK_POINTER_NWORDS); #ifndef LISP_FEATURE_GENCGC wp = (struct weak_pointer *) native_pointer(copy); gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); /* Push the weak pointer onto the list of weak pointers. */ wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers); weak_pointers = wp; #endif return copy; } static long size_weak_pointer(lispobj *where) { return WEAK_POINTER_NWORDS; } void scan_weak_pointers(void) { struct weak_pointer *wp, *next_wp; for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) { lispobj value = wp->value; lispobj *first_pointer; gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); next_wp = wp->next; wp->next = NULL; if (next_wp == wp) /* gencgc uses a ref to self for end of list */ next_wp = NULL; if (!(is_lisp_pointer(value) && from_space_p(value))) continue; /* Now, we need to check whether the object has been forwarded. If * it has been, the weak pointer is still good and needs to be * updated. Otherwise, the weak pointer needs to be nil'ed * out. */ first_pointer = (lispobj *)native_pointer(value); if (forwarding_pointer_p(first_pointer)) { wp->value= (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer)); } else { /* Break it. */ wp->value = NIL; wp->broken = T; } } } /* Hash tables */ #if N_WORD_BITS == 32 #define EQ_HASH_MASK 0x1fffffff #elif N_WORD_BITS == 64 #define EQ_HASH_MASK 0x1fffffffffffffff #endif /* Compute the EQ-hash of KEY. This must match POINTER-HASH in * target-hash-table.lisp. */ #define EQ_HASH(key) ((key) & EQ_HASH_MASK) /* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE * slot. Set to NULL at the end of a collection. * * This is not optimal because, when a table is tenured, it won't be * processed automatically; only the yougest generation is GC'd by * default. On the other hand, all applications will need an * occasional full GC anyway, so it's not that bad either. */ struct hash_table *weak_hash_tables = NULL; /* Return true if OBJ has already survived the current GC. */ static inline int survived_gc_yet (lispobj obj) { return (!is_lisp_pointer(obj) || !from_space_p(obj) || forwarding_pointer_p(native_pointer(obj))); } static inline int weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value) { switch (weakness) { case KEY: return survived_gc_yet(key); case VALUE: return survived_gc_yet(value); case KEY_OR_VALUE: return (survived_gc_yet(key) || survived_gc_yet(value)); case KEY_AND_VALUE: return (survived_gc_yet(key) && survived_gc_yet(value)); default: gc_assert(0); /* Shut compiler up. */ return 0; } } /* Return the beginning of data in ARRAY (skipping the header and the * length) or NULL if it isn't an array of the specified widetag after * all. */ static inline lispobj * get_array_data (lispobj array, int widetag, unsigned long *length) { if (is_lisp_pointer(array) && (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) { if (length != NULL) *length = fixnum_value(((lispobj *)native_pointer(array))[1]); return ((lispobj *)native_pointer(array)) + 2; } else { return NULL; } } /* Only need to worry about scavenging the _real_ entries in the * table. Phantom entries such as the hash table itself at index 0 and * the empty marker at index 1 were scavenged by scav_vector that * either called this function directly or arranged for it to be * called later by pushing the hash table onto weak_hash_tables. */ static void scav_hash_table_entries (struct hash_table *hash_table) { lispobj *kv_vector; unsigned long kv_length; lispobj *index_vector; unsigned long length; lispobj *next_vector; unsigned long next_vector_length; lispobj *hash_vector; unsigned long hash_vector_length; lispobj empty_symbol; lispobj weakness = hash_table->weakness; long i; kv_vector = get_array_data(hash_table->table, SIMPLE_VECTOR_WIDETAG, &kv_length); if (kv_vector == NULL) lose("invalid kv_vector %x\n", hash_table->table); index_vector = get_array_data(hash_table->index_vector, SIMPLE_ARRAY_WORD_WIDETAG, &length); if (index_vector == NULL) lose("invalid index_vector %x\n", hash_table->index_vector); next_vector = get_array_data(hash_table->next_vector, SIMPLE_ARRAY_WORD_WIDETAG, &next_vector_length); if (next_vector == NULL) lose("invalid next_vector %x\n", hash_table->next_vector); hash_vector = get_array_data(hash_table->hash_vector, SIMPLE_ARRAY_WORD_WIDETAG, &hash_vector_length); if (hash_vector != NULL) gc_assert(hash_vector_length == next_vector_length); /* These lengths could be different as the index_vector can be a * different length from the others, a larger index_vector could * help reduce collisions. */ gc_assert(next_vector_length*2 == kv_length); empty_symbol = kv_vector[1]; /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/ if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) != SYMBOL_HEADER_WIDETAG) { lose("not a symbol where empty-hash-table-slot symbol expected: %x\n", *(lispobj *)native_pointer(empty_symbol)); } /* Work through the KV vector. */ for (i = 1; i < next_vector_length; i++) { lispobj old_key = kv_vector[2*i]; lispobj value = kv_vector[2*i+1]; if ((weakness == NIL) || weak_hash_entry_alivep(weakness, old_key, value)) { /* Scavenge the key and value. */ scavenge(&kv_vector[2*i],2); /* If an EQ-based key has moved, mark the hash-table for * rehashing. */ if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) { lispobj new_key = kv_vector[2*i]; if (old_key != new_key && new_key != empty_symbol) { hash_table->needs_rehash_p = T; } } } } } long scav_vector (lispobj *where, lispobj object) { unsigned long kv_length; lispobj *kv_vector; struct hash_table *hash_table; /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak * hash tables in the Lisp HASH-TABLE code to indicate need for * special GC support. */ if (HeaderValue(object) == subtype_VectorNormal) return 1; kv_length = fixnum_value(where[1]); kv_vector = where + 2; /* Skip the header and length. */ /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/ /* Scavenge element 0, which may be a hash-table structure. */ scavenge(where+2, 1); if (!is_lisp_pointer(where[2])) { /* This'll happen when REHASH clears the header of old-kv-vector * and fills it with zero, but some other thread simulatenously * sets the header in %%PUTHASH. */ fprintf(stderr, "Warning: no pointer at %lx in hash table: this indicates " "non-fatal corruption caused by concurrent access to a " "hash-table from multiple threads. Any accesses to " "hash-tables shared between threads should be protected " "by locks.\n", (unsigned long)&where[2]); // We've scavenged three words. return 3; } hash_table = (struct hash_table *)native_pointer(where[2]); /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/ if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) { lose("hash table not instance (%x at %x)\n", hash_table->header, hash_table); } /* Scavenge element 1, which should be some internal symbol that * the hash table code reserves for marking empty slots. */ scavenge(where+3, 1); if (!is_lisp_pointer(where[3])) { lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]); } /* Scavenge hash table, which will fix the positions of the other * needed objects. */ scavenge((lispobj *)hash_table, sizeof(struct hash_table) / sizeof(lispobj)); /* Cross-check the kv_vector. */ if (where != (lispobj *)native_pointer(hash_table->table)) { lose("hash_table table!=this table %x\n", hash_table->table); } if (hash_table->weakness == NIL) { scav_hash_table_entries(hash_table); } else { /* Delay scavenging of this table by pushing it onto * weak_hash_tables (if it's not there already) for the weak * object phase. */ if (hash_table->next_weak_hash_table == NIL) { hash_table->next_weak_hash_table = (lispobj)weak_hash_tables; weak_hash_tables = hash_table; } } return (CEILING(kv_length + 2, 2)); } void scav_weak_hash_tables (void) { struct hash_table *table; /* Scavenge entries whose triggers are known to survive. */ for (table = weak_hash_tables; table != NULL; table = (struct hash_table *)table->next_weak_hash_table) { scav_hash_table_entries(table); } } /* Walk through the chain whose first element is *FIRST and remove * dead weak entries. */ static inline void scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev, lispobj *kv_vector, lispobj *index_vector, lispobj *next_vector, lispobj *hash_vector, lispobj empty_symbol, lispobj weakness) { unsigned index = *prev; while (index) { unsigned next = next_vector[index]; lispobj key = kv_vector[2 * index]; lispobj value = kv_vector[2 * index + 1]; gc_assert(key != empty_symbol); gc_assert(value != empty_symbol); if (!weak_hash_entry_alivep(weakness, key, value)) { unsigned count = fixnum_value(hash_table->number_entries); gc_assert(count > 0); *prev = next; hash_table->number_entries = make_fixnum(count - 1); next_vector[index] = fixnum_value(hash_table->next_free_kv); hash_table->next_free_kv = make_fixnum(index); kv_vector[2 * index] = empty_symbol; kv_vector[2 * index + 1] = empty_symbol; if (hash_vector) hash_vector[index] = MAGIC_HASH_VECTOR_VALUE; } else { prev = &next_vector[index]; } index = next; } } static void scan_weak_hash_table (struct hash_table *hash_table) { lispobj *kv_vector; lispobj *index_vector; unsigned long length = 0; /* prevent warning */ lispobj *next_vector; unsigned long next_vector_length = 0; /* prevent warning */ lispobj *hash_vector; lispobj empty_symbol; lispobj weakness = hash_table->weakness; long i; kv_vector = get_array_data(hash_table->table, SIMPLE_VECTOR_WIDETAG, NULL); index_vector = get_array_data(hash_table->index_vector, SIMPLE_ARRAY_WORD_WIDETAG, &length); next_vector = get_array_data(hash_table->next_vector, SIMPLE_ARRAY_WORD_WIDETAG, &next_vector_length); hash_vector = get_array_data(hash_table->hash_vector, SIMPLE_ARRAY_WORD_WIDETAG, NULL); empty_symbol = kv_vector[1]; for (i = 0; i < length; i++) { scan_weak_hash_table_chain(hash_table, &index_vector[i], kv_vector, index_vector, next_vector, hash_vector, empty_symbol, weakness); } } /* Remove dead entries from weak hash tables. */ void scan_weak_hash_tables (void) { struct hash_table *table, *next; for (table = weak_hash_tables; table != NULL; table = next) { next = (struct hash_table *)table->next_weak_hash_table; table->next_weak_hash_table = NIL; scan_weak_hash_table(table); } weak_hash_tables = NULL; } /* * initialization */ static long scav_lose(lispobj *where, lispobj object) { lose("no scavenge function for object 0x%08x (widetag 0x%x)\n", (unsigned long)object, widetag_of(*(lispobj*)native_pointer(object))); return 0; /* bogus return value to satisfy static type checking */ } static lispobj trans_lose(lispobj object) { lose("no transport function for object 0x%08x (widetag 0x%x)\n", (unsigned long)object, widetag_of(*(lispobj*)native_pointer(object))); return NIL; /* bogus return value to satisfy static type checking */ } static long size_lose(lispobj *where) { lose("no size function for object at 0x%08x (widetag 0x%x)\n", (unsigned long)where, widetag_of(LOW_WORD(where))); return 1; /* bogus return value to satisfy static type checking */ } /* * initialization */ void gc_init_tables(void) { long i; /* Set default value in all slots of scavenge table. FIXME * replace this gnarly sizeof with something based on * N_WIDETAG_BITS */ for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) { scavtab[i] = scav_lose; } /* For each type which can be selected by the lowtag alone, set * multiple entries in our widetag scavenge table (one for each * possible value of the high bits). */ for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) { scavtab[EVEN_FIXNUM_LOWTAG|(i< 0) { size_t count = 1; lispobj thing = *start; /* If thing is an immediate then this is a cons. */ if (is_lisp_pointer(thing) || (fixnump(thing)) || (widetag_of(thing) == CHARACTER_WIDETAG) #if N_WORD_BITS == 64 || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) #endif || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG)) count = 2; else count = (sizetab[widetag_of(thing)])(start); /* Check whether the pointer is within this object. */ if ((pointer >= start) && (pointer < (start+count))) { /* found it! */ /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/ return(start); } /* Round up the count. */ count = CEILING(count,2); start += count; words -= count; } return (NULL); } boolean maybe_gc(os_context_t *context) { #ifndef LISP_FEATURE_WIN32 struct thread *thread = arch_os_get_current_thread(); #endif fake_foreign_function_call(context); /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in * which case we will be running with no gc trigger barrier * thing for a while. But it shouldn't be long until the end * of WITHOUT-GCING. * * FIXME: It would be good to protect the end of dynamic space for * CheneyGC and signal a storage condition from there. */ /* Restore the signal mask from the interrupted context before * calling into Lisp if interrupts are enabled. Why not always? * * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an * interrupt hits while in SUB-GC, it is deferred and the * os_context_sigmask of that interrupt is set to block further * deferrable interrupts (until the first one is * handled). Unfortunately, that context refers to this place and * when we return from here the signals will not be blocked. * * A kludgy alternative is to propagate the sigmask change to the * outer context. */ #ifndef LISP_FEATURE_WIN32 if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) { sigset_t *context_sigmask = os_context_sigmask_addr(context); #ifdef LISP_FEATURE_SB_THREAD /* What if the context we'd like to restore has GC signals * blocked? Just skip the GC: we can't set GC_PENDING, because * that would block the next attempt, and we don't know when * we'd next check for it -- and it's hard to be sure that * unblocking would be safe. * * FIXME: This is not actually much better: we may already have * GC_PENDING set, and presumably our caller assumes that we will * clear it. Perhaps we should, even though we don't actually GC? */ if (sigismember(context_sigmask,SIG_STOP_FOR_GC)) { undo_fake_foreign_function_call(context); return 1; } #endif thread_sigmask(SIG_SETMASK, context_sigmask, 0); } else unblock_gc_signals(); #endif /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp: * otherwise two threads racing here may deadlock: the other will * wait on the GC lock, and the other cannot stop the first one... */ funcall0(StaticSymbolFunction(SUB_GC)); undo_fake_foreign_function_call(context); return 1; }