Ticket #1173: okay-working-symbol-gc.patch

NEWS

@@ -23 +23 @@
     which is faster because it is inlined (#1260, thanks to Kooda).
   - The default error handler now truncates very long condition
     messages (thanks to Lemonboy).
+  - Weak symbol GC (-:w) no longer drops random symbols (#1173).
 
 - Syntax expander
   - DSSSL lambda lists have improved hygiene, so they don't need

chicken.h

@@ -1951 +1951 @@
 C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
 C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
 C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n) 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_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_get_keyword(C_word key, C_word args, C_word def) C_regparm;
@@ -2652 +2653 @@
 {
   C_word *p = *ptr, *p0 = p;
 
-  *(p++) = C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1);
+  if (C_enable_gcweak)
+    *(p++) = C_BUCKET_TYPE | C_SPECIALBLOCK_BIT | (C_SIZEOF_BUCKET - 1);
+  else
+    *(p++) = C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1);
   *(p++) = head;
   *(p++) = tail;
   *ptr = p;

eval.scm

@@ -381 +381 @@
                                              (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

library.scm

@@ -204 +204 @@
 (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"))
@@ -4971 +4972 @@
 
 (define get (getter-with-setter ##sys#get put! "(get sym prop . default)"))
 
+;; TODO: "Unpersist" symbol if this drops the last property
 (define (remprop! sym prop)
   (##sys#check-symbol sym 'remprop!)
   (let loop ((plist (##sys#slot sym 2)) (ptl #f))

runtime.c

@@ -156 +156 @@
 
 #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
@@ -285 +279 @@
   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
@@ -438 +426 @@
   gc_count_1,
   gc_count_1_total,
   gc_count_2,
-  weak_table_randomization,
   stack_size_changed,
   dlopen_flags,
   heap_size_changed,
@@ -474 +461 @@
   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,
@@ -501 +487 @@
 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);
 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 void C_fcall persist(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_word C_fcall maybe_inexact_to_exact(C_word n) C_regparm;
@@ -515 +501 @@
 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();
@@ -687 +674 @@
   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;
@@ -2257 +2236 @@
   return C_SCHEME_FALSE;
 }
 
+C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
+{
+  C_i_check_symbol(sym);
+  persist(sym, NULL);
+  return C_SCHEME_UNDEFINED;
+}
+
+/* Mark a symbol as "persistent", to prevent it from being GC'ed */
+C_regparm void C_fcall persist(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) {
+      /* Change weak to strong ref to ensure overall 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;
+    }
+  }
+}
+
 
 double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
 {
@@ -2834 +2842 @@
   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;
@@ -2874 +2880 @@
   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) {
@@ -3092 +3095 @@
 
   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;
-        }
-      }
-    }
   }
 
+  update_symbol_tables(gc_mode);
+
   if(gc_mode == GC_MAJOR) {
     tgc = C_cpu_milliseconds() - tgc;
     gc_ms += tgc;
@@ -3169 +3135 @@
           (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);
   }
 
@@ -3200 +3163 @@
 
 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;
 
@@ -3227 +3189 @@
       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);
 
@@ -3257 +3220 @@
     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);
 
@@ -3299 +3255 @@
     }
 #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);
 
@@ -3348 +3294 @@
   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;
@@ -3445 +3389 @@
   /* Mark symbol table: */
   for(stp = symbol_table_list; stp != NULL; stp = stp->next)
     for(i = 0; i < stp->size; ++i)
-      remark(&stp->table[i]);
+      remark(&stp->table[i]); /* Ensure buckets survive */
 
   /* Mark collectibles: */
   for(msp = collectibles; msp < collectibles_top; ++msp)
@@ -3473 +3417 @@
     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);
@@ -3515 +3451 @@
     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);
   
@@ -3560 +3498 @@
   C_uword n, bytes;
   C_header h;
   C_SCHEME_BLOCK *p, *p2;
-  WEAK_TABLE_ENTRY *wep;
 
   val = *x;
 
@@ -3734 +3671 @@
   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;
-
-  for(n = 0; n < WEAK_HASH_ITERATIONS; ++n) {
-    key = (key + disp + weak_table_randomization) % WEAK_TABLE_SIZE;
-    wep = &weak_item_table[ key ];
+  int weakn = 0, i;
+  C_word bucket, last, sym, h;
+  C_SYMBOL_TABLE *stp;
 
-    if(wep->item == 0) {
-      if(container != 0) {
-        /* Add fresh entry: */
-        wep->item = item;
-        wep->container = container;
-        return wep;
+  if(C_enable_gcweak) {
+    /* Fixup 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)) {
+
+          sym = C_block_item(bucket, 0);
+          h = C_block_header(sym);
+
+          /* 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_block_item(sym, 0) == C_SCHEME_UNBOUND ||
+                   C_block_item(sym, 0) == sym); /* kw */
+            assert(C_block_item(sym, 2) == C_SCHEME_END_OF_LIST);
+            ++weakn;
+          } else {
+            C_set_block_item(bucket,0,sym); /* Might have moved */
+            last = bucket;
+          }
+        }
       }
-
-      return NULL;
     }
-    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;
 }
 
 
@@ -9404 +9374 @@
 {
   C_word pl = C_block_item(sym, 2);
 
+  /* Newly added plist?  Ensure the symbol stays! */
+  if (C_enable_gcweak && pl == C_SCHEME_END_OF_LIST) persist(sym, NULL);
+
   while(pl != C_SCHEME_END_OF_LIST) {
     if(C_block_item(pl, 0) == prop) {
       C_mutate2(&C_u_i_car(C_u_i_cdr(pl)), val);