From 7dbad6b6e02443ea3a214ba56b82f2920d519519 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 3 Sep 2016 17:00:41 +0200 Subject: [PATCH 1/3] Simplify and improve reclaimability of symbol GC Instead of using a secondary symbol table ("weak table") for tracking unreferenced symbols, we change the symbol's buckets to either hold the symbol strongly or weakly. This allows us to rely on the GC's normal function to copy or discard unused symbols. On minor GC, we *always* copy the symbols, ignoring its bucket's weak/strong status. This is for performance reasons. After a major or reallocating GC, we traverse the symbol table and update the pointers in weak buckets: if the new location of the symbol is in the tospace/new heap, it must be live, so we keep it and update the bucket's pointer. Otherwise, we can drop the bucket. This requires one change to how symbols are managed: when a bucket is allocated, it is weak by default. When a symbol becomes globally bound or gains a plist, we change the bucket type from weak to strong. If the plist is emptied, the bucket type is changed to weak again (but only if it isn't also globally bound). Currently we don't support unbinding a symbol, but if we ever do we'll need to call unpersist on the symbol as well. There are several advantages to this: 1) It is simpler than the tricky weak table code (see also #1173). 2) Now, all symbols can be collected instead of an upper limit of 997. 3) It is much faster when a lot of discardable symbols are generated. 4) Memory usage is no longer unbounded when many symbols are generated. Points 3 and 4 are related to point 2. See the knucleotide benchmark for an extreme example of this: it uses about half as much memory and is twice as fast under the new implementation. --- NEWS | 2 + chicken.h | 15 ++- eval.scm | 1 + library.scm | 11 +- runtime.c | 279 ++++++++++++++++++++++------------------------- tests/runtests.bat | 3 +- tests/runtests.sh | 3 +- tests/symbolgc-tests.scm | 39 ++++--- 8 files changed, 179 insertions(+), 174 deletions(-) diff --git a/NEWS b/NEWS index ec0dd93..34ec4bc 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ provide the desired performance. - Port directionality has been generalized from a simple input/output flag to a bitmap, to allow for multidirectional ports. + - Weak symbol GC is faster, simpler, and can now collect all + unreferenced symbols instead of a maximum of 997 per major GC. - Compiler - Fixed an off by one allocation problem in generated C code for (list ...). diff --git a/chicken.h b/chicken.h index 3ecdd39..2cd705b 100644 --- a/chicken.h +++ b/chicken.h @@ -537,6 +537,8 @@ static inline int isinf_ld (long double x) /* Fixed size types have pre-computed header tags */ #define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1)) #define C_POINTER_TAG (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1)) +#define C_BUCKET_TAG (C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1)) +#define C_WEAK_BUCKET_TAG (C_BUCKET_TAG | C_SPECIALBLOCK_BIT) #define C_LOCATIVE_TAG (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1)) #define C_TAGGED_POINTER_TAG (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1)) #define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1)) @@ -1052,6 +1054,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_bignum_size(b) (C_bytestowords(C_header_size(C_internal_bignum_vector(b)))-1) #define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK))) #define C_symbol_value(x) (C_block_item(x, 0)) +#define C_symbol_plist(x) (C_block_item(x, 2)) #define C_save(x) (*(--C_temporary_stack) = (C_word)(x)) #define C_rescue(x, i) (C_temporary_stack[ i ] = (x)) #define C_restore (*(C_temporary_stack++)) @@ -2136,6 +2139,8 @@ C_fctexport C_word C_fcall C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_wo C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm; C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm; +C_fctexport C_word C_fcall C_i_persist_symbol(C_word sym) C_regparm; +C_fctexport C_word C_fcall C_i_unpersist_symbol(C_word sym) C_regparm; C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm; C_fctexport C_u64 C_fcall C_milliseconds(void) C_regparm; C_fctexport C_u64 C_fcall C_cpu_milliseconds(void) C_regparm; @@ -2772,6 +2777,14 @@ C_inline C_word C_i_symbolp(C_word x) return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG); } +C_inline int C_persistable_symbol(C_word x) +{ + C_word val = C_symbol_value(x); + /* Symbol is bound (and not a keyword), or has a non-empty plist */ + return (!C_enable_gcweak || /* Overrides to always true */ + (val != C_SCHEME_UNBOUND && val != x) || + C_symbol_plist(x) != C_SCHEME_END_OF_LIST); +} C_inline C_word C_i_pairp(C_word x) { @@ -3409,7 +3422,7 @@ C_inline C_word C_fcall C_a_bucket(C_word **ptr, C_word head, C_word tail) { C_word *p = *ptr, *p0 = p; - *(p++) = C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1); + *(p++) = C_enable_gcweak ? C_WEAK_BUCKET_TAG : C_BUCKET_TAG; *(p++) = head; *(p++) = tail; *ptr = p; diff --git a/eval.scm b/eval.scm index 7ee369a..61d7f48 100644 --- a/eval.scm +++ b/eval.scm @@ -389,6 +389,7 @@ (lambda (v) (##sys#error 'eval "environment is not mutable" evalenv var)) ;XXX var? (lambda (v) + (##sys#persist-symbol var) (##sys#setslot var 0 (##core#app val v))) ) ) ] [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))] [else diff --git a/library.scm b/library.scm index 246f70f..5c9387f 100644 --- a/library.scm +++ b/library.scm @@ -250,6 +250,7 @@ EOF (define ##sys#gc (##core#primitive "C_gc")) (define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y)) (define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y)) +(define (##sys#persist-symbol s) (##core#inline "C_i_persist_symbol" s)) (define ##sys#allocate-vector (##core#primitive "C_allocate_vector")) (define (argc+argv) (##sys#values main_argc main_argv)) (define ##sys#make-structure (##core#primitive "C_make_structure")) @@ -5704,7 +5705,10 @@ EOF (##sys#setslot ptl 1 nxt) (##sys#setslot sym 2 nxt) ) #t ) ) - (loop nxt tl) ) ) ) ) ) + (loop nxt tl) ) ) ) ) + (when (null? (##sys#slot sym 2)) + ;; This will only unpersist if symbol is also unbound + (##core#inline "C_i_unpersist_symbol" sym) ) ) (define symbol-plist (getter-with-setter @@ -5718,7 +5722,10 @@ EOF (##sys#setslot sym 2 lst) (##sys#signal-hook #:type-error "property-list must be of even length" - lst sym))) + lst sym)) + (if (null? lst) + (##core#inline "C_i_unpersist_symbol" sym) + (##core#inline "C_i_persist_symbol" sym))) "(symbol-plist sym)")) (define (get-properties sym props) diff --git a/runtime.c b/runtime.c index 6a50c06..14732bf 100644 --- a/runtime.c +++ b/runtime.c @@ -167,12 +167,6 @@ static C_TLS int timezone; #define MAX_HASH_PREFIX 64 -#define WEAK_TABLE_SIZE 997 -#define WEAK_HASH_ITERATIONS 4 -#define WEAK_HASH_DISPLACEMENT 7 -#define WEAK_COUNTER_MASK 3 -#define WEAK_COUNTER_MAX 2 - #define TEMPORARY_STACK_SIZE 4096 #define STRING_BUFFER_SIZE 4096 #define DEFAULT_MUTATION_STACK_SIZE 1024 @@ -302,12 +296,6 @@ typedef struct lf_list_struct char *module_name; } LF_LIST; -typedef struct weak_table_entry_struct -{ - C_word item, /* item weakly held (symbol) */ - container; /* object holding reference to symbol, lowest 3 bits are */ -} WEAK_TABLE_ENTRY; /* also used as a counter, saturated at 2 or more */ - typedef struct finalizer_node_struct { struct finalizer_node_struct @@ -467,7 +455,6 @@ static C_TLS int gc_count_1, gc_count_1_total, gc_count_2, - weak_table_randomization, stack_size_changed, dlopen_flags, heap_size_changed, @@ -503,7 +490,6 @@ static C_TLS int allocated_finalizer_count, pending_finalizer_count, callback_returned_flag; -static C_TLS WEAK_TABLE_ENTRY *weak_item_table; static C_TLS C_GC_ROOT *gc_root_list = NULL; static C_TLS FINALIZER_NODE *finalizer_list, @@ -531,7 +517,6 @@ static void panic(C_char *msg) C_noret; static void usual_panic(C_char *msg) C_noret; static void horror(C_char *msg) C_noret; static void C_fcall really_mark(C_word *x) C_regparm; -static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm; static C_cpsproc(values_continuation) C_noret; static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable); static C_regparm int C_fcall C_in_new_heapp(C_word x); @@ -563,6 +548,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp); static int bignum_cmp_unsigned(C_word x, C_word y); static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm; static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm; +static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm; static double compute_symbol_table_load(double *avg_bucket_len, int *total); static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm; static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix); @@ -573,6 +559,7 @@ static void C_fcall remark_system_globals(void) C_regparm; static void C_fcall really_remark(C_word *x) C_regparm; static C_word C_fcall intern0(C_char *name) C_regparm; static void C_fcall update_locative_table(int mode) C_regparm; +static void C_fcall update_symbol_tables(int mode) C_regparm; static LF_LIST *find_module_handle(C_char *name); static void set_profile_timer(C_uword freq); static void take_profile_sample(); @@ -758,14 +745,6 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel) C_gc_mutation_hook = NULL; C_gc_trace_hook = NULL; - /* Allocate weak item table: */ - if(C_enable_gcweak) { - weak_item_table = (WEAK_TABLE_ENTRY *)C_calloc(WEAK_TABLE_SIZE, sizeof(WEAK_TABLE_ENTRY)); - - if(weak_item_table == NULL) - return 0; - } - /* Initialize finalizer lists: */ finalizer_list = NULL; finalizer_free_list = NULL; @@ -2420,6 +2399,59 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE return C_SCHEME_FALSE; } +/* Mark a symbol as "persistent", to prevent it from being GC'ed */ +C_regparm C_word C_fcall C_i_persist_symbol(C_word sym) +{ + C_word bucket; + + C_i_check_symbol(sym); + + bucket = lookup_bucket(sym, NULL); + if (C_truep(bucket)) { /* It could be an uninterned symbol(?) */ + /* Change weak to strong ref to ensure long-term survival */ + C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT; + /* Ensure survival on next minor GC */ + if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym); + } + return C_SCHEME_UNDEFINED; +} + +/* Possibly remove "persistence" of symbol, to allowed it to be GC'ed. + * This is only done if the symbol is unbound and has an empty plist. + */ +C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym) +{ + C_word bucket; + + C_i_check_symbol(sym); + + if (C_persistable_symbol(sym)) return C_SCHEME_FALSE; + + bucket = lookup_bucket(sym, NULL); + if (C_truep(bucket)) { /* It could be an uninterned symbol(?) */ + /* Turn it into a weak ref */ + C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT; + return C_SCHEME_TRUE; + } + return C_SCHEME_FALSE; +} + +C_regparm C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) +{ + C_word bucket, str = C_block_item(sym, 1); + int key, len = C_header_size(str); + + if (stable == NULL) stable = symbol_table; + + key = hash_string(len, C_c_string(str), stable->size, stable->rand, 0); + + for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; + bucket = C_block_item(bucket,1)) { + if (C_block_item(bucket,0) == sym) return bucket; + } + return C_SCHEME_FALSE; +} + double compute_symbol_table_load(double *avg_bucket_len, int *total_n) { @@ -3242,18 +3274,16 @@ static void mark(C_word *x) { \ C_cblockend #endif - C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) { - int i, j, n, fcount, weakn = 0; + int i, j, n, fcount; C_uword count, bytes; - C_word *p, **msp, bucket, last, item, container; + C_word *p, **msp, bucket, last; C_header h; C_byte *tmp, *start; LF_LIST *lfn; C_SCHEME_BLOCK *bp; C_GC_ROOT *gcrp; - WEAK_TABLE_ENTRY *wep; double tgc = 0; C_SYMBOL_TABLE *stp; volatile int finalizers_checked; @@ -3282,9 +3312,6 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) gc_mode = GC_MINOR; start = C_fromspace_top; - if(C_enable_gcweak) - weak_table_randomization = rand(); - /* Entry point for second-level GC (on explicit request or because of full fromspace): */ #ifdef HAVE_SIGSETJMP if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) { @@ -3377,8 +3404,11 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) { if(h & C_SPECIALBLOCK_BIT) { - --n; - ++p; + /* Minor GC needs to be fast; always mark weakly held symbols */ + if (gc_mode != GC_MINOR || h != C_WEAK_BUCKET_TAG) { + --n; + ++p; + } } while(n--) mark(p++); @@ -3500,48 +3530,11 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) i_like_spaghetti: ++gc_count_2; - - if(C_enable_gcweak) { - /* Check entries in weak item table and recover items ref'd only - once, which are unbound symbols and have empty property-lists: */ - weakn = 0; - wep = weak_item_table; - - for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep) - if(wep->item != 0) { - if((wep->container & WEAK_COUNTER_MAX) == 0 && /* counter saturated? (more than 1) */ - is_fptr((item = C_block_header(wep->item)))) { /* and forwarded/collected */ - item = fptr_to_ptr(item); /* recover obj from forwarding ptr */ - container = wep->container & ~WEAK_COUNTER_MASK; - - if(C_header_bits(item) == C_SYMBOL_TYPE && - C_block_item(item, 0) == C_SCHEME_UNBOUND && - C_block_item(item, 2) == C_SCHEME_END_OF_LIST) { - ++weakn; - C_set_block_item(container, 0, C_SCHEME_UNDEFINED); /* clear reference to item */ - } - } - - wep->item = wep->container = 0; - } - - /* Remove empty buckets in symbol table: */ - for(stp = symbol_table_list; stp != NULL; stp = stp->next) { - for(i = 0; i < stp->size; ++i) { - last = 0; - - for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1)) - if(C_block_item(bucket,0) == C_SCHEME_UNDEFINED) { - if(last) C_set_block_item(last, 1, C_block_item(bucket,1)); - else stp->table[ i ] = C_block_item(bucket,1); - } - else last = bucket; - } - } - } } if(gc_mode == GC_MAJOR) { + update_symbol_tables(gc_mode); + tgc = C_cpu_milliseconds() - tgc; gc_ms += tgc; timer_accumulated_gc_ms += tgc; @@ -3577,9 +3570,6 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) (C_uword)tospace_start, (C_uword)tospace_top, (C_uword)tospace_limit); - if(gc_mode == GC_MAJOR && C_enable_gcweak && weakn) - C_dbg("GC", C_text("%d recoverable weakly held items found\n"), weakn); - C_dbg("GC", C_text("%d locatives (from %d)\n"), locative_table_count, locative_table_size); } @@ -3622,11 +3612,10 @@ C_regparm void C_fcall mark_system_globals(void) C_regparm void C_fcall really_mark(C_word *x) { - C_word val, item; + C_word val; C_uword n, bytes; C_header h; C_SCHEME_BLOCK *p, *p2; - WEAK_TABLE_ENTRY *wep; val = *x; @@ -3649,7 +3638,8 @@ C_regparm void C_fcall really_mark(C_word *x) return; } - if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return; + if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) + return; p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top); @@ -3679,25 +3669,9 @@ C_regparm void C_fcall really_mark(C_word *x) C_memcpy(p2->data, p->data, bytes); } else { /* (major GC) */ - /* Increase counter (saturated at 2) if weakly held item (someone pointed to this object): */ - if(C_enable_gcweak && - (h & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE && - (wep = lookup_weak_table_entry(val, 0)) != NULL) { - if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container; - } - if(is_fptr(h)) { val = fptr_to_ptr(h); - /* When we marked the bucket, it may have already referred to - * the moved symbol instead of its original location. Re-check: - */ - if(C_enable_gcweak && - (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE && - (wep = lookup_weak_table_entry(*x, 0)) != NULL) { - if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container; - } - if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) { *x = val; return; @@ -3711,15 +3685,6 @@ C_regparm void C_fcall really_mark(C_word *x) /* Link points into fromspace and into a link which points into from- or tospace: */ val = fptr_to_ptr(h); - /* See above: might happen twice */ - if(C_enable_gcweak && - (C_block_header(val) & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE && - /* Check both the original and intermediate location: */ - ((wep = lookup_weak_table_entry((C_word)p, 0)) != NULL || - (wep = lookup_weak_table_entry(*x, 0)) != NULL)) { - if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container; - } - if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) { *x = val; return; @@ -3739,16 +3704,6 @@ C_regparm void C_fcall really_mark(C_word *x) } #endif - if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) { - item = C_block_item(val,0); - - /* Lookup item in weak item table or add entry: */ - if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) { - /* If item is already forwarded, then set count to 2: */ - if(is_fptr(C_block_header(item))) wep->container |= 2; - } - } - n = C_header_size(p); bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word); @@ -3788,19 +3743,17 @@ static void remark(C_word *x) { \ C_cblockend #endif - /* Do a major GC into a freshly allocated heap: */ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize) { int i, j; C_uword count, n, bytes; - C_word *p, **msp, item, last; + C_word *p, **msp, bucket, last; C_header h; C_byte *tmp, *start; LF_LIST *lfn; C_SCHEME_BLOCK *bp; - WEAK_TABLE_ENTRY *wep; C_GC_ROOT *gcrp; C_SYMBOL_TABLE *stp; FINALIZER_NODE *flist; @@ -3913,14 +3866,6 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize) remark(&flist->finalizer); } - /* Clear weakly held items: */ - if(C_enable_gcweak) { - wep = weak_item_table; - - for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep) - wep->item = wep->container = 0; - } - /* Mark trace-buffer: */ for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) { remark(&tinfo->cooked1); @@ -3955,6 +3900,8 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize) heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word); } + update_symbol_tables(GC_REALLOC); + heap_free (heapspace1, heapspace1_size); heap_free (heapspace2, heapspace2_size); @@ -4004,7 +3951,6 @@ C_regparm void C_fcall really_remark(C_word *x) C_uword n, bytes; C_header h; C_SCHEME_BLOCK *p, *p2; - WEAK_TABLE_ENTRY *wep; val = *x; @@ -4179,34 +4125,66 @@ C_regparm void C_fcall update_locative_table(int mode) if(mode != GC_REALLOC) locative_table_count = hi; } - -C_regparm WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) +C_regparm void C_fcall update_symbol_tables(int mode) { - C_uword - key = (C_uword)item >> 2, - disp = 0, - n; - WEAK_TABLE_ENTRY *wep; + int weakn = 0, i; + C_word bucket, last, sym, h; + C_SYMBOL_TABLE *stp; - for(n = 0; n < WEAK_HASH_ITERATIONS; ++n) { - key = (key + disp + weak_table_randomization) % WEAK_TABLE_SIZE; - wep = &weak_item_table[ key ]; + assert(mode != GC_MINOR); /* Call only in major or realloc mode */ + if(C_enable_gcweak) { + /* Update symbol locations through fptrs or drop if unreferenced */ + for(stp = symbol_table_list; stp != NULL; stp = stp->next) { + for(i = 0; i < stp->size; ++i) { + last = 0; - if(wep->item == 0) { - if(container != 0) { - /* Add fresh entry: */ - wep->item = item; - wep->container = container; - return wep; - } + for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1)) { + + sym = C_block_item(bucket, 0); + h = C_block_header(sym); - return NULL; + /* Resolve any forwarding pointers */ + while(is_fptr(h)) { + sym = fptr_to_ptr(h); + h = C_block_header(sym); + } + + assert((h & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE); + + /* If the symbol is unreferenced, drop it: */ + if(!C_truep(C_permanentp(sym)) && (mode == GC_REALLOC ? + !C_in_new_heapp(sym) : + !C_in_fromspacep(sym))) { + + if(last) C_set_block_item(last, 1, C_block_item(bucket,1)); + else stp->table[ i ] = C_block_item(bucket,1); + + assert(!C_persistable_symbol(sym)); + ++weakn; + } else { + C_set_block_item(bucket,0,sym); /* Might have moved */ + last = bucket; + } + } + } } - else if(wep->item == item) return wep; - else disp += WEAK_HASH_DISPLACEMENT; + if(gc_report_flag && weakn) + C_dbg("GC", C_text("%d recoverable weakly held items found\n"), weakn); + } else { +#ifdef DEBUGBUILD + /* Sanity check: all symbols should've been marked */ + for(stp = symbol_table_list; stp != NULL; stp = stp->next) + for(i = 0; i < stp->size; ++i) + for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1)) { + sym = C_block_item(bucket, 0); + assert(!is_fptr(C_block_header(sym)) && + (C_truep(C_permanentp(sym)) || + (mode == GC_REALLOC ? + C_in_new_heapp(sym) : + C_in_fromspacep(sym)))); + } +#endif } - - return NULL; } @@ -13193,7 +13171,10 @@ C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm C_word C_fcall C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val) { - C_word pl = C_block_item(sym, 2); + C_word pl = C_symbol_plist(sym); + + /* Newly added plist? Ensure the symbol stays! */ + if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym); while(pl != C_SCHEME_END_OF_LIST) { if(C_block_item(pl, 0) == prop) { @@ -13203,9 +13184,9 @@ C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val) else pl = C_u_i_cdr(C_u_i_cdr(pl)); } - pl = C_a_pair(ptr, val, C_block_item(sym, 2)); + pl = C_a_pair(ptr, val, C_symbol_plist(sym)); pl = C_a_pair(ptr, prop, pl); - C_mutate_slot(&C_block_item(sym, 2), pl); + C_mutate_slot(&C_symbol_plist(sym), pl); return val; } diff --git a/tests/runtests.bat b/tests/runtests.bat index 8e488d0..00f7687 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -481,8 +481,7 @@ echo ======================================== symbol-GC tests ... %compile% symbolgc-tests.scm if errorlevel 1 exit /b 1 a.out -:w -rem Currently disabled, because this may leave 1 symbol unreclaimed. -rem if errorlevel 1 exit /b 1 +if errorlevel 1 exit /b 1 echo ======================================== finalizer tests ... %interpret% -s test-finalizers.scm diff --git a/tests/runtests.sh b/tests/runtests.sh index 279f70f..13f4405 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -415,8 +415,7 @@ done echo "======================================== symbol-GC tests ..." $compile symbolgc-tests.scm -# Currently disabled, because this may leave 1 symbol unreclaimed. -./a.out -:w || echo "*** FAILED ***" +./a.out -:w echo "======================================== finalizer tests ..." $interpret -s test-finalizers.scm diff --git a/tests/symbolgc-tests.scm b/tests/symbolgc-tests.scm index 30b32a4..0b45859 100644 --- a/tests/symbolgc-tests.scm +++ b/tests/symbolgc-tests.scm @@ -2,18 +2,23 @@ ; ; - run this with the "-:w" option -(use gc) +(use gc (chicken format)) (assert (##sys#fudge 15) "please run this test with the `-:w' runtime option") -(define (gcsome #!optional (n 100)) - (do ((i n (sub1 i))) ((zero? i)) (gc #t))) +;; Ensure counts are defined before creating the disposable symbols. +;; This way, this program can also be run in interpreted mode. +(define *count-before* #f) +(define *count-after* #f) -(gcsome) +;; Force major GC to ensure there are no collectible symbols left +;; before we start, otherwise the GC might clean these up and we'd end +;; up with less symbols than we started with! +(gc #t) -(define *count1* (vector-ref (##sys#symbol-table-info) 2)) +(set! *count-before* (vector-ref (##sys#symbol-table-info) 2)) -(print "starting with " *count1* " symbols") +(print "starting with " *count-before* " symbols") (print "interning 10000 symbols ...") @@ -23,17 +28,15 @@ (print "recovering ...") -(let loop ((i 0)) - (let ((n (vector-ref (##sys#symbol-table-info) 2))) - (print* (- n *count1*) " ") - (cond ((> i 100) - (unless (<= n *count1*) - (error "unable to reclaim all symbols"))) - ((< (- n *count1*) 100) ; allow some - (gc #t) - (loop (+ i 1))) - (else - (gc #t) - (loop 0))))) +;; Force major GC, which should reclaim every last symbol we just +;; created, as well as "i", the loop counter. +(gc #t) + +;; Don't use LET, which would introduce a fresh identifier, which is a +;; new symbol (at least, in interpreted mode) +(set! *count-after* (vector-ref (##sys#symbol-table-info) 2)) +(print* (- *count-after* *count-before*) " newly interned symbols left") +(unless (= *count-after* *count-before*) + (error "unable to reclaim all symbols")) (print "\ndone.") -- 2.1.4