X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fgc-common.c;h=b76dc55161a72389a7eede4c9250d5d6d9dceabf;hb=7a79c7338b8c8fb6d84a275d7c0e51ce93150059;hp=251aa6a7b2394ec0b1b2324748c9882a0ad71176;hpb=be7adb92bf0012ab07adac2943e73772dfad7911;p=sbcl.git diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 251aa6a..b76dc55 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -42,6 +42,7 @@ #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 @@ -52,6 +53,8 @@ #endif #endif +size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE; + inline static boolean forwarding_pointer_p(lispobj *pointer) { lispobj first_word=*pointer; @@ -127,8 +130,8 @@ scavenge(lispobj *start, long n_words) lispobj *end = start + n_words; lispobj *object_ptr; long n_words_scavenged; - for (object_ptr = start; + for (object_ptr = start; object_ptr < end; object_ptr += n_words_scavenged) { @@ -156,25 +159,28 @@ scavenge(lispobj *start, long n_words) n_words_scavenged = 1; } } -#ifndef LISP_FEATURE_GENCGC - /* this workaround is probably not necessary for gencgc; at least, the - * behaviour it describes has never been reported */ - 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 +#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 type=widetag_of(object); - n_words_scavenged=1; - - if ((scavtab[type]==scav_lose) || - (((scavtab[type])(start,object))>1)) { - fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a bug report (see manual page for details)\n", - object,start); + 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 @@ -187,7 +193,8 @@ scavenge(lispobj *start, long n_words) (scavtab[widetag_of(object)])(object_ptr, object); } } - gc_assert(object_ptr == end); + 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 */ @@ -313,11 +320,18 @@ trans_code(struct code *code) 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)); -#ifdef LISP_FEATURE_GENCGC + +#endif + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) gencgc_apply_code_fixups(code, new_code); #endif + return new_code; } @@ -344,7 +358,9 @@ scav_code_header(lispobj *where, lispobj object) entry_point != NIL; entry_point = function_ptr->next) { - gc_assert(is_lisp_pointer(entry_point)); + 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); @@ -352,6 +368,7 @@ scav_code_header(lispobj *where, lispobj object) scavenge(&function_ptr->name, 1); scavenge(&function_ptr->arglist, 1); scavenge(&function_ptr->type, 1); + scavenge(&function_ptr->xrefs, 1); } return n_words; @@ -387,7 +404,7 @@ size_code_header(lispobj *where) static long scav_return_pc_header(lispobj *where, lispobj object) { - lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x", + 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 */ @@ -442,7 +459,7 @@ scav_closure_header(lispobj *where, lispobj object) static long scav_fun_header(lispobj *where, lispobj object) { - lose("attempted to scavenge a function header where=0x%08x object=0x%08x", + 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 */ @@ -627,7 +644,7 @@ scav_immediate(lispobj *where, lispobj object) static lispobj trans_immediate(lispobj object) { - lose("trying to transport an immediate"); + lose("trying to transport an immediate\n"); return NIL; /* bogus return value to satisfy static type checking */ } @@ -693,7 +710,7 @@ size_boxed(lispobj *where) /* Note: on the sparc we don't have to do anything special for fdefns, */ /* 'cause the raw-addr has a function lowtag. */ -#ifndef LISP_FEATURE_SPARC +#if !defined(LISP_FEATURE_SPARC) static long scav_fdefn(lispobj *where, lispobj object) { @@ -1506,11 +1523,17 @@ size_weak_pointer(lispobj *where) void scan_weak_pointers(void) { - struct weak_pointer *wp; - for (wp = weak_pointers; wp != NULL; wp=wp->next) { + 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; @@ -1532,6 +1555,312 @@ void scan_weak_pointers(void) } } + +/* 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; + unsigned 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; + unsigned 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; +} /* @@ -1541,7 +1870,7 @@ void scan_weak_pointers(void) static long scav_lose(lispobj *where, lispobj object) { - lose("no scavenge function for object 0x%08x (widetag 0x%x)", + lose("no scavenge function for object 0x%08x (widetag 0x%x)\n", (unsigned long)object, widetag_of(*(lispobj*)native_pointer(object))); @@ -1551,7 +1880,7 @@ scav_lose(lispobj *where, lispobj object) static lispobj trans_lose(lispobj object) { - lose("no transport function for object 0x%08x (widetag 0x%x)", + 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 */ @@ -1560,7 +1889,7 @@ trans_lose(lispobj object) static long size_lose(lispobj *where) { - lose("no size function for object at 0x%08x (widetag 0x%x)", + 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 */ @@ -1574,7 +1903,7 @@ size_lose(lispobj *where) void gc_init_tables(void) { - long i; + unsigned long i; /* Set default value in all slots of scavenge table. FIXME * replace this gnarly sizeof with something based on @@ -1710,16 +2039,15 @@ gc_init_tables(void) scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed; scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed; scavtab[CODE_HEADER_WIDETAG] = scav_code_header; -#ifndef LISP_FEATURE_GENCGC /* FIXME ..._X86 ? */ +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header; scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header; #endif + scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed; #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header; #else scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed; #endif scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed; scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed; @@ -1728,11 +2056,12 @@ gc_init_tables(void) scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate; scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance; -#ifdef LISP_FEATURE_SPARC +#if defined(LISP_FEATURE_SPARC) scavtab[FDEFN_WIDETAG] = scav_boxed; #else scavtab[FDEFN_WIDETAG] = scav_fdefn; #endif + scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector; /* transport other table, initialized same way as scavtab */ for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++) @@ -2065,3 +2394,64 @@ gc_search_space(lispobj *start, size_t words, lispobj *pointer) } 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; +}