Merge pull request #22 from bobot/feature/ephemerons

GPR#22: Add Ephemerons to OCaml

Changes

@@ -236,11 +236,14 @@ Standard library:
   * Sys.time (and [@@noalloc])
   * Pervasives.ldexp (and [@@noalloc])
   * Pervasives.compare for float, nativeint, int32, int64.
-  (Bobot François)
+  (François Bobot)
 - GPR#329: Add exists, for_all,  mem and memq functions in Array
   (Bernhard Schommer)
 - GPR#337: Add [Hashtbl.filter_map_inplace] (Alain Frisch)
 - GPR#356: Add [Format.kasprintf] (Jérémie Dimino, Mark Shinwell)
+- GPR#22: Add the Ephemeron module that implements ephemerons and weak
+  hash table (François Bobot, review by Damien Doligez, Daniel Bünzli,
+  Alain Frisch, Pierre Chambart)
 
 Type system:
 - PR#5545: Type annotations on methods cannot control the choice of abbreviation
@@ -450,6 +453,12 @@ Bug fixes:
   Mark Shinwell)
 - GPR#283: Fix memory leaks in intern.c when OOM is raised
   (Marc Lasson, review by Alain Frisch)
+- GPR#22: Fix the cleaning of weak pointers. In very rare cases
+  accessing a value during the cleaning of the weak pointers could
+  result in the value being removed from one weak arrays and kept in
+  another one. That breaks the property that a value is removed from a
+  weak pointer only when it is dead and garbage collected. (François
+  Bobot, review by Damien Doligez)
 - GPR#313: Prevent quadratic cases in CSE
   (Pierre Chambart, review by Xavier Leroy)
 - PR#6795, PR#6996: Make ocamldep report errors passed in

byterun/caml/major_gc.h

@@ -38,13 +38,23 @@ extern uintnat caml_dependent_size, caml_dependent_allocated;
 extern uintnat caml_fl_wsz_at_phase_change;
 
 #define Phase_mark 0
-#define Phase_sweep 1
-#define Phase_idle 2
-#define Subphase_roots 10
-#define Subphase_main 11
-#define Subphase_weak1 12
-#define Subphase_weak2 13
-#define Subphase_final 14
+#define Phase_clean 1
+#define Phase_sweep 2
+#define Phase_idle 3
+
+/* Subphase of mark */
+#define Subphase_mark_roots 10
+/* Subphase_mark_roots: At the end of this subphase all the global
+   roots are marked. */
+#define Subphase_mark_main 11
+/* Subphase_mark_main: At the end of this subphase all the value alive at
+   the start of this subphase and created during it are marked. */
+#define Subphase_mark_final 12
+/* Subphase_mark_final: At the start of this subphase register which
+   value with an ocaml finalizer are not marked, the associated
+   finalizer will be run later. So we mark now these value as alive,
+   since they must be available for their finalizer.
+  */
 
 CAMLextern char *caml_heap_start;
 extern uintnat total_heap_size;

byterun/caml/minor_gc.h

@@ -25,17 +25,26 @@ CAMLextern value *caml_young_trigger;
 extern asize_t caml_minor_heap_wsz;
 extern int caml_in_minor_collection;
 
-struct caml_ref_table {
-  value **base;
-  value **end;
-  value **threshold;
-  value **ptr;
-  value **limit;
-  asize_t size;
-  asize_t reserve;
+#define CAML_TABLE_STRUCT(t) { \
+  t *base;                     \
+  t *end;                      \
+  t *threshold;                \
+  t *ptr;                      \
+  t *limit;                    \
+  asize_t size;                \
+  asize_t reserve;             \
+}
+
+struct caml_ref_table CAML_TABLE_STRUCT(value *);
+CAMLextern struct caml_ref_table caml_ref_table, caml_finalize_table;
+
+struct caml_ephe_ref_elt {
+  value ephe;      /* an ephemeron in major heap */
+  mlsize_t offset; /* the offset that points in the minor heap  */
 };
-CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table,
-                                 caml_finalize_table;
+
+struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt);
+CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table;
 
 extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
 extern void caml_empty_minor_heap (void);
@@ -43,6 +52,9 @@ CAMLextern void caml_gc_dispatch (void);
 CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */
 extern void caml_realloc_ref_table (struct caml_ref_table *);
 extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
+extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *);
+extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *,
+                                   asize_t, asize_t);
 extern void caml_oldify_one (value, value *);
 extern void caml_oldify_mopup (void);
 
@@ -62,4 +74,16 @@ static inline void add_to_ref_table (struct caml_ref_table *tbl, value *p)
   *tbl->ptr++ = p;
 }
 
+static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl,
+                                          value ar, mlsize_t offset)
+{
+  if (tbl->ptr >= tbl->limit){
+    CAMLassert (tbl->ptr == tbl->limit);
+    caml_realloc_ephe_ref_table (tbl);
+  }
+  struct caml_ephe_ref_elt *ephe_ref = tbl->ptr++;
+  ephe_ref->ephe = ar;
+  ephe_ref->offset = offset;
+}
+
 #endif /* CAML_MINOR_GC_H */

byterun/caml/weak.h

@@ -18,7 +18,69 @@
 
 #include "mlvalues.h"
 
-extern value caml_weak_list_head;
-extern value caml_weak_none;
+extern value caml_ephe_list_head;
+extern value caml_ephe_none;
+
+
+/** The first field 0:  weak list;
+       second field 1:  data;
+       others       2..:  keys;
+
+    A weak pointer is an ephemeron with the data at caml_ephe_none
+ */
+
+#define CAML_EPHE_LINK_OFFSET 0
+#define CAML_EPHE_DATA_OFFSET 1
+#define CAML_EPHE_FIRST_KEY 2
+
+
+/* In the header, in order to let major_gc.c
+   and weak.c see the body of the function */
+static inline void caml_ephe_clean (value v){
+  value child;
+  int release_data = 0;
+  mlsize_t size, i;
+  header_t hd;
+                                    Assert(caml_gc_phase == Phase_clean);
+
+  hd = Hd_val (v);
+  size = Wosize_hd (hd);
+  for (i = 2; i < size; i++){
+    child = Field (v, i);
+  ephemeron_again:
+    if (child != caml_ephe_none
+        && Is_block (child) && Is_in_heap_or_young (child)){
+      if (Tag_val (child) == Forward_tag){
+        value f = Forward_val (child);
+        if (Is_block (f)) {
+          if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
+              || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
+            /* Do not short-circuit the pointer. */
+          }else{
+            Field (v, i) = child = f;
+            if (Is_block (f) && Is_young (f))
+              add_to_ephe_ref_table(&caml_ephe_ref_table, v, i);
+            goto ephemeron_again;
+          }
+        }
+      }
+      if (Is_white_val (child) && !Is_young (child)){
+        release_data = 1;
+        Field (v, i) = caml_ephe_none;
+      }
+    }
+  }
+
+  child = Field (v, 1);
+  if(child != caml_ephe_none){
+      if (release_data){
+        Field (v, 1) = caml_ephe_none;
+      } else {
+        /* The mark phase must have marked it */
+        Assert( !(Is_block (child) && Is_in_heap (child)
+                  && Is_white_val (child)) );
+      }
+  }
+}
 
 #endif /* CAML_WEAK_H */

byterun/compact.c

@@ -221,7 +221,7 @@ static void do_compaction (void)
     }
     /* Invert weak pointers. */
     {
-      value *pp = &caml_weak_list_head;
+      value *pp = &caml_ephe_list_head;
       value p;
       word q;
       size_t sz, i;
@@ -233,7 +233,7 @@ static void do_compaction (void)
         while (Ecolor (q) == 0) q = * (word *) q;
         sz = Wosize_ehd (q);
         for (i = 1; i < sz; i++){
-          if (Field (p,i) != caml_weak_none){
+          if (Field (p,i) != caml_ephe_none){
             invert_pointer_at ((word *) &(Field (p,i)));
           }
         }
@@ -402,7 +402,7 @@ void caml_compact_heap (void)
 
   CAMLassert (caml_young_ptr == caml_young_alloc_end);
   CAMLassert (caml_ref_table.ptr == caml_ref_table.base);
-  CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.base);
+  CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base);
 
   do_compaction ();
   CAML_INSTR_TIME (tmr, "compact/main");

byterun/major_gc.c

@@ -44,7 +44,8 @@ uintnat caml_percent_free;
 uintnat caml_major_heap_increment;
 CAMLexport char *caml_heap_start;
 char *caml_gc_sweep_hp;
-int caml_gc_phase;        /* always Phase_mark, Phase_sweep, or Phase_idle */
+int caml_gc_phase;        /* always Phase_mark, Pase_clean,
+                             Phase_sweep, or Phase_idle */
 static value *gray_vals;
 static value *gray_vals_cur, *gray_vals_end;
 static asize_t gray_vals_size;
@@ -59,8 +60,47 @@ extern char *caml_fl_merge;  /* Defined in freelist.c. */
 
 static char *markhp, *chunk, *limit;
 
-int caml_gc_subphase;     /* Subphase_{main,weak1,weak2,final} */
-static value *weak_prev;
+int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final} */
+
+/**
+   Ephemerons:
+   During mark phase the list caml_ephe_list_head of ephemerons
+   is iterated by different pointers that follow the invariants:
+   caml_ephe_list_head ->* ephes_checked_if_pure ->* ephes_to_check ->* null
+                        |                         |                  |
+                       (1)                       (2)                (3)
+
+    At the start of mark phase, (1) and (2) are empty.
+
+    In mark phase:
+      - the ephemerons in (1) have a data alive or none
+        (nb: new ephemerons are added in this part by weak.c)
+      - the ephemerons in (2) have at least a white key or are white
+        if ephe_list_pure is true, otherwise they are in an unknown state and
+        must be checked again.
+      - the ephemerons in (3) are in an unknown state and must be checked
+
+    At the end of mark phase, (3) is empty and ephe_list_pure is true.
+    The ephemeron in (1) and (2) will be cleaned (white keys and datas
+    replaced by none or the ephemeron is removed from the list if it is white)
+    in clean phase.
+
+    In clean phase:
+    caml_ephe_list_head ->*                           ephes_to_check ->* null
+                         |                                            |
+                        (1)                                          (3)
+
+    In clean phase, (2) is not used, ephes_to_check is initialized at
+    caml_ephe_list_head:
+    - the ephemerons in (1) are clean.
+    - the ephemerons in (3) should be cleaned or removed if white.
+
+ */
+static int ephe_list_pure;
+/** The ephemerons is pure if since the start of its iteration
+    no value have been darken. */
+static value *ephes_checked_if_pure;
+static value *ephes_to_check;
 
 int caml_major_window = 1;
 double caml_major_ring[Max_major_window] = { 0. };
@@ -126,6 +166,7 @@ void caml_darken (value v, value *p /* not used */)
 #endif
     CAMLassert (!Is_blue_hd (h));
     if (Is_white_hd (h)){
+      ephe_list_pure = 0;
       if (t < No_scan_tag){
         Hd_val (v) = Grayhd_hd (h);
         *gray_vals_cur++ = v;
@@ -144,8 +185,11 @@ static void start_cycle (void)
   caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
   caml_darken_all_roots_start ();
   caml_gc_phase = Phase_mark;
-  caml_gc_subphase = Subphase_roots;
+  caml_gc_subphase = Subphase_mark_roots;
   markhp = NULL;
+  ephe_list_pure = 1;
+  ephes_checked_if_pure = &caml_ephe_list_head;
+  ephes_to_check = &caml_ephe_list_head;
 #ifdef DEBUG
   ++ major_gc_counter;
   caml_heap_check ();
@@ -159,25 +203,179 @@ static void start_cycle (void)
 static value current_value = 0;
 static mlsize_t current_index = 0;
 
+/* For instrumentation */
 #ifdef CAML_INSTR
 #define INSTR(x) x
 #else
 #define INSTR(x) /**/
 #endif
 
+static void init_sweep_phase(void)
+{
+  /* Phase_clean is done. */
+  /* Initialise the sweep phase. */
+  caml_gc_sweep_hp = caml_heap_start;
+  caml_fl_init_merge ();
+  caml_gc_phase = Phase_sweep;
+  chunk = caml_heap_start;
+  caml_gc_sweep_hp = chunk;
+  limit = chunk + Chunk_size (chunk);
+  caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
+  if (caml_major_gc_hook) (*caml_major_gc_hook)();
+}
+
+/* auxillary function of mark_slice */
+static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
+                                       int in_ephemeron, int *slice_pointers)
+{
+  value child;
+  header_t chd;
+
+  child = Field (v, i);
+
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+  if (Is_block (child)
+        && ! Is_young (child)
+        && Wosize_val (child) > 0  /* Atoms never need to be marked. */
+        /* Closure blocks contain code pointers at offsets that cannot
+           be reliably determined, so we always use the page table when
+           marking such values. */
+        && (!(Tag_val (v) == Closure_tag || Tag_val (v) == Infix_tag) ||
+            Is_in_heap (child))) {
+#else
+  if (Is_block (child) && Is_in_heap (child)) {
+#endif
+    INSTR (++ *slice_pointers;)
+    chd = Hd_val (child);
+    if (Tag_hd (chd) == Forward_tag){
+      value f = Forward_val (child);
+      if ((in_ephemeron && Is_long(f)) ||
+          (Is_block (f)
+           && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
+               || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
+        /* Do not short-circuit the pointer. */
+      }else{
+        /* The variable child is not changed because it must be mark alive */
+        Field (v, i) = f;
+        if (Is_block (f) && Is_young (f) && !Is_young (child)){
+          if(in_ephemeron){
+            add_to_ephe_ref_table (&caml_ephe_ref_table, v, i);
+          }else{
+            add_to_ref_table (&caml_ref_table, &Field (v, i));
+          }
+        }
+      }
+    }
+    else if (Tag_hd(chd) == Infix_tag) {
+      child -= Infix_offset_val(child);
+      chd = Hd_val(child);
+    }
+#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
+    /* See [caml_darken] for a description of this assertion. */
+    CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
+#endif
+    if (Is_white_hd (chd)){
+      ephe_list_pure = 0;
+      Hd_val (child) = Grayhd_hd (chd);
+      *gray_vals_ptr++ = child;
+      if (gray_vals_ptr >= gray_vals_end) {
+        gray_vals_cur = gray_vals_ptr;
+        realloc_gray_vals ();
+        gray_vals_ptr = gray_vals_cur;
+      }
+    }
+  }
+
+  return gray_vals_ptr;
+}
+
+static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
+                             int *slice_pointers)
+{
+  value v, data, key;
+  header_t hd;
+  mlsize_t size, i;
+
+  v = *ephes_to_check;
+  hd = Hd_val(v);
+  Assert(Tag_val (v) == Abstract_tag);
+  data = Field(v,CAML_EPHE_DATA_OFFSET);
+  if ( data != caml_ephe_none &&
+       Is_block (data) && Is_in_heap (data) && Is_white_val (data)){
+
+    int alive_data = 1;
+
+    /* The liveness of the ephemeron is one of the condition */
+    if (Is_white_hd (hd)) alive_data = 0;
+
+    /* The liveness of the keys not caml_ephe_none is the other condition */
+    size = Wosize_hd (hd);
+    for (i = CAML_EPHE_FIRST_KEY; alive_data && i < size; i++){
+      key = Field (v, i);
+    ephemeron_again:
+      if (key != caml_ephe_none &&
+          Is_block (key) && Is_in_heap (key)){
+        if (Tag_val (key) == Forward_tag){
+          value f = Forward_val (key);
+          if (Is_long (f) ||
+              (Is_block (f) &&
+               (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
+                || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
+            /* Do not short-circuit the pointer. */
+          }else{
+            Field (v, i) = key = f;
+            goto ephemeron_again;
+          }
+        }
+        if (Is_white_val (key)){
+          alive_data = 0;
+        }
+      }
+    }
+    *work -= Whsize_wosize(i);
+
+    if (alive_data){
+      gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,
+                                        CAML_EPHE_DATA_OFFSET,
+                                        /*in_ephemeron=*/1,
+                                        slice_pointers);
+    } else { /* not triggered move to the next one */
+      ephes_to_check = &Field(v,CAML_EPHE_LINK_OFFSET);
+      return gray_vals_ptr;
+    }
+  } else {  /* a simily weak pointer or an already alive data */
+    *work -= 1;
+  }
+
+  /* all keys black or data none or black
+     move the ephemerons from (3) to the end of (1) */
+  if ( ephes_checked_if_pure == ephes_to_check ) {
+    /* corner case and optim */
+    ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET);
+    ephes_to_check = ephes_checked_if_pure;
+  } else {
+    /*  - remove v from the list (3) */
+    *ephes_to_check = Field(v,CAML_EPHE_LINK_OFFSET);
+    /*  - insert it at the end of (1) */
+    Field(v,CAML_EPHE_LINK_OFFSET) = *ephes_checked_if_pure;
+    *ephes_checked_if_pure = v;
+    ephes_checked_if_pure = &Field(v,CAML_EPHE_LINK_OFFSET);
+  }
+  return gray_vals_ptr;
+}
+
+
+
 static void mark_slice (intnat work)
 {
   value *gray_vals_ptr;  /* Local copy of [gray_vals_cur] */
-  value v, child;
-  header_t hd, chd;
+  value v;
+  header_t hd;
   mlsize_t size, i, start, end; /* [start] is a local copy of [current_index] */
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
-  int marking_closure = 0;
-#endif
 #ifdef CAML_INSTR
   int slice_fields = 0;
-  int slice_pointers = 0;
 #endif
+  int slice_pointers = 0; /** gcc removes it when not in CAML_INSTR */
 
   caml_gc_message (0x40, "Marking %ld words\n", work);
   caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
@@ -192,10 +390,6 @@ static void mark_slice (intnat work)
     }
     if (v != 0){
       hd = Hd_val(v);
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
-      marking_closure =
-        (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag);
-#endif
       Assert (Is_gray_hd (hd));
       size = Wosize_hd (hd);
       end = start + work;
@@ -207,49 +401,9 @@ static void mark_slice (intnat work)
         INSTR (if (size > end)
                  CAML_INSTR_INT ("major/mark/slice/remain", size - end);)
         for (i = start; i < end; i++){
-          child = Field (v, i);
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
-          if (Is_block (child)
-                && ! Is_young (child)
-                && Wosize_val (child) > 0  /* Atoms never need to be marked. */
-                /* Closure blocks contain code pointers at offsets that cannot
-                   be reliably determined, so we always use the page table when
-                   marking such values. */
-                && (!marking_closure || Is_in_heap (child))) {
-#else
-          if (Is_block (child) && Is_in_heap (child)) {
-#endif
-            INSTR (++ slice_pointers;)
-            chd = Hd_val (child);
-            if (Tag_hd (chd) == Forward_tag){
-              value f = Forward_val (child);
-              if (Is_block (f)
-                  && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-                      || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
-                /* Do not short-circuit the pointer. */
-              }else{
-                Field (v, i) = f;
-                if (Is_block (f) && Is_young (f) && !Is_young (child))
-                  add_to_ref_table (&caml_ref_table, &Field (v, i));
-              }
-            }else if (Tag_hd(chd) == Infix_tag) {
-              child -= Infix_offset_val(child);
-              chd = Hd_val(child);
-            }
-#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
-            /* See [caml_darken] for a description of this assertion. */
-            CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
-#endif
-            if (Is_white_hd (chd)){
-              Hd_val (child) = Grayhd_hd (chd);
-              *gray_vals_ptr++ = child;
-              if (gray_vals_ptr >= gray_vals_end) {
-                gray_vals_cur = gray_vals_ptr;
-                realloc_gray_vals ();
-                gray_vals_ptr = gray_vals_cur;
-              }
-            }
-          }
+          gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i,
+                                            /*in_ephemeron=*/ 0,
+                                            &slice_pointers);
         }
         if (end < size){
           work = 0;
@@ -292,62 +446,25 @@ static void mark_slice (intnat work)
       chunk = caml_heap_start;
       markhp = chunk;
       limit = chunk + Chunk_size (chunk);
+    } else if (caml_gc_subphase == Subphase_mark_roots) {
+      gray_vals_cur = gray_vals_ptr;
+      work = caml_darken_all_roots_slice (work);
+      gray_vals_ptr = gray_vals_cur;
+      if (work > 0){
+        caml_gc_subphase = Subphase_mark_main;
+      }
+    } else if (*ephes_to_check != (value) NULL) {
+      /* Continue to scan the list of ephe */
+      gray_vals_ptr = mark_ephe_aux(gray_vals_ptr,&work,&slice_pointers);
+    } else if (!ephe_list_pure){
+      /* We must scan again the list because some value have been darken */
+      ephe_list_pure = 1;
+      ephes_to_check = ephes_checked_if_pure;
     }else{
       switch (caml_gc_subphase){
-      case Subphase_roots: {
-        gray_vals_cur = gray_vals_ptr;
-        work = caml_darken_all_roots_slice (work);
-        gray_vals_ptr = gray_vals_cur;
-        if (work > 0){
-          caml_gc_subphase = Subphase_main;
-        }
-      }
-        break;
-      case Subphase_main: {
-        /* The main marking phase is over.  Start removing weak pointers to
-           dead values. */
-        caml_gc_subphase = Subphase_weak1;
-        weak_prev = &caml_weak_list_head;
-      }
-        break;
-      case Subphase_weak1: {
-        value cur, curfield;
-        mlsize_t sz, i;
-        header_t hd;
-
-        cur = *weak_prev;
-        if (cur != (value) NULL){
-          hd = Hd_val (cur);
-          sz = Wosize_hd (hd);
-          for (i = 1; i < sz; i++){
-            curfield = Field (cur, i);
-          weak_again:
-            if (curfield != caml_weak_none
-                && Is_block (curfield) && Is_in_heap_or_young (curfield)){
-              if (Tag_val (curfield) == Forward_tag){
-                value f = Forward_val (curfield);
-                if (Is_block (f)) {
-                  if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-                      || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
-                    /* Do not short-circuit the pointer. */
-                  }else{
-                    Field (cur, i) = curfield = f;
-                    if (Is_block (f) && Is_young (f))
-                      add_to_ref_table (&caml_weak_ref_table, &Field (cur, i));
-                    goto weak_again;
-                  }
-                }
-              }
-              if (Is_white_val (curfield) && !Is_young (curfield)){
-                Field (cur, i) = caml_weak_none;
-              }
-            }
-          }
-          weak_prev = &Field (cur, 0);
-          work -= Whsize_hd (hd);
-        }else{
-          /* Subphase_weak1 is done.
-             Handle finalised values and start removing dead weak arrays. */
+      case Subphase_mark_main: {
+          /* Subphase_mark_main is done.
+             Mark finalised values. */
           gray_vals_cur = gray_vals_ptr;
           caml_final_update ();
           gray_vals_ptr = gray_vals_cur;
@@ -355,44 +472,25 @@ static void mark_slice (intnat work)
             v = *--gray_vals_ptr;
             CAMLassert (start == 0);
           }
-          caml_gc_subphase = Subphase_weak2;
-          weak_prev = &caml_weak_list_head;
-        }
+          /* Complete the marking */
+          ephes_to_check = ephes_checked_if_pure;
+          caml_gc_subphase = Subphase_mark_final;
       }
         break;
-      case Subphase_weak2: {
-        value cur;
-        header_t hd;
-
-        cur = *weak_prev;
-        if (cur != (value) NULL){
-          hd = Hd_val (cur);
-          if (Color_hd (hd) == Caml_white){
-            /* The whole array is dead, remove it from the list. */
-            *weak_prev = Field (cur, 0);
-          }else{
-            weak_prev = &Field (cur, 0);
-          }
-          work -= 1;
-        }else{
-          /* Subphase_weak2 is done.  Go to Subphase_final. */
-          caml_gc_subphase = Subphase_final;
+      case Subphase_mark_final: {
+        if (caml_ephe_list_head != (value) NULL){
+          /* Initialise the clean phase. */
+          caml_gc_phase = Phase_clean;
+          ephes_to_check = &caml_ephe_list_head;
+          work = 0;
+        } else {
+          /* Initialise the sweep phase,
+           shortcut the unneeded clean phase. */
+          init_sweep_phase();
+          work = 0;
         }
       }
         break;
-      case Subphase_final: {
-        /* Initialise the sweep phase. */
-        caml_gc_sweep_hp = caml_heap_start;
-        caml_fl_init_merge ();
-        caml_gc_phase = Phase_sweep;
-        chunk = caml_heap_start;
-        caml_gc_sweep_hp = chunk;
-        limit = chunk + Chunk_size (chunk);
-        work = 0;
-        caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
-        if (caml_major_gc_hook) (*caml_major_gc_hook)();
-      }
-        break;
       default: Assert (0);
       }
     }
@@ -404,6 +502,33 @@ static void mark_slice (intnat work)
   INSTR (CAML_INSTR_INT ("major/mark/slice/pointers#", slice_pointers);)
 }
 
+/* Clean ephemerons */
+static void clean_slice (intnat work)
+{
+  value v;
+
+  caml_gc_message (0x40, "Cleaning %ld words\n", work);
+  while (work > 0){
+    v = *ephes_to_check;
+    if (v != (value) NULL){
+      if (Is_white_val (v)){
+        /* The whole array is dead, remove it from the list. */
+        *ephes_to_check = Field (v, CAML_EPHE_LINK_OFFSET);
+        work -= 1;
+      }else{
+        caml_ephe_clean(v);
+        ephes_to_check = &Field (v, CAML_EPHE_LINK_OFFSET);
+        work -= Whsize_val (v);
+      }
+    }else{ /* End of list reached */
+      /* Phase_clean is done. */
+      /* Initialise the sweep phase. */
+      init_sweep_phase();
+      work = 0;
+    }
+  }
+}
+
 static void sweep_slice (intnat work)
 {
   char *hp;
@@ -625,7 +750,7 @@ void caml_major_collection_slice (intnat howmuch)
     goto finished;
   }
 
-  if (caml_gc_phase == Phase_mark){
+  if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){
     computed_work = (intnat) (p * (caml_stat_heap_wsz * 250
                                    / (100 + caml_percent_free)
                                    + caml_incremental_roots_count));
@@ -638,6 +763,9 @@ void caml_major_collection_slice (intnat howmuch)
     mark_slice (computed_work);
     CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]);
     caml_gc_message (0x02, "!", 0);
+  }else if (caml_gc_phase == Phase_clean){
+    clean_slice (computed_work);
+    caml_gc_message (0x02, "%%", 0);
   }else{
     Assert (caml_gc_phase == Phase_sweep);
     CAML_INSTR_INT ("major/work/sweep#", computed_work);
@@ -682,6 +810,7 @@ void caml_finish_major_cycle (void)
 {
   if (caml_gc_phase == Phase_idle) start_cycle ();
   while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX);
+  while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX);
   Assert (caml_gc_phase == Phase_sweep);
   while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
   Assert (caml_gc_phase == Phase_idle);

byterun/memory.c

@@ -445,7 +445,7 @@ void caml_shrink_heap (char *chunk)
 
 color_t caml_allocation_color (void *hp)
 {
-  if (caml_gc_phase == Phase_mark
+  if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
       || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
     return Caml_black;
   }else{
@@ -486,7 +486,7 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
   Assert (Is_in_heap (Val_hp (hp)));
 
   /* Inline expansion of caml_allocation_color. */
-  if (caml_gc_phase == Phase_mark
+  if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
       || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
     Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
   }else{

byterun/minor_gc.c

@@ -49,6 +49,8 @@
          native code, or [caml_young_trigger].
 */
 
+struct generic_table CAML_TABLE_STRUCT(void);
+
 asize_t caml_minor_heap_wsz;
 static void *caml_young_base = NULL;
 CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL;
@@ -60,21 +62,24 @@ CAMLexport value *caml_young_trigger = NULL;
 
 CAMLexport struct caml_ref_table
   caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
-  caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
   caml_finalize_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
 /* table of custom blocks containing finalizers in the minor heap */
 
+CAMLexport struct caml_ephe_ref_table
+  caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
+
 int caml_in_minor_collection = 0;
 
 /* [sz] and [rsv] are numbers of entries */
-void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
+static void alloc_generic_table (struct generic_table *tbl, asize_t sz,
+                                 asize_t rsv, asize_t element_size)
 {
-  value **new_table;
+  void *new_table;
 
   tbl->size = sz;
   tbl->reserve = rsv;
-  new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve)
-                                          * sizeof (value *));
+  new_table = (void *) caml_stat_alloc ((tbl->size + tbl->reserve)
+                                        * element_size);
   if (tbl->base != NULL) caml_stat_free (tbl->base);
   tbl->base = new_table;
   tbl->ptr = tbl->base;
@@ -83,7 +88,19 @@ void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
   tbl->end = tbl->base + tbl->size + tbl->reserve;
 }
 
-static void reset_table (struct caml_ref_table *tbl)
+void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
+{
+  alloc_generic_table ((struct generic_table *) tbl, sz, rsv, sizeof (value *));
+}
+
+void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz,
+                            asize_t rsv)
+{
+  alloc_generic_table ((struct generic_table *) tbl, sz, rsv,
+                       sizeof (struct caml_ephe_ref_elt));
+}
+
+static void reset_table (struct generic_table *tbl)
 {
   tbl->size = 0;
   tbl->reserve = 0;
@@ -91,7 +108,7 @@ static void reset_table (struct caml_ref_table *tbl)
   tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL;
 }
 
-static void clear_table (struct caml_ref_table *tbl)
+static void clear_table (struct generic_table *tbl)
 {
     tbl->ptr = tbl->base;
     tbl->limit = tbl->threshold;
@@ -165,8 +182,8 @@ void caml_set_minor_heap_size (asize_t bsz)
   caml_young_ptr = caml_young_alloc_end;
   caml_minor_heap_wsz = Wsize_bsize (bsz);
 
-  reset_table (&caml_ref_table);
-  reset_table (&caml_weak_ref_table);
+  reset_table ((struct generic_table *) &caml_ref_table);
+  reset_table ((struct generic_table *) &caml_ephe_ref_table);
 }
 
 static value oldify_todo_list = 0;
@@ -257,6 +274,21 @@ void caml_oldify_one (value v, value *p)
   }
 }
 
+/* Test if the ephemeron is alive, everything outside minor heap is alive */
+static inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){
+  mlsize_t i;
+  value child;
+  for (i = 2; i < Wosize_val(re->ephe); i++){
+    child = Field (re->ephe, i);
+    if(child != caml_ephe_none
+       && Is_block (child) && Is_young (child)
+       && Hd_val (child) != 0){ /* Value not copied to major heap */
+      return 0;
+    }
+  }
+  return 1;
+}
+
 /* Finish the work that was put off by [caml_oldify_one].
    Note that [caml_oldify_one] itself is called by oldify_mopup, so we
    have to be careful to remove the first entry from the list before
@@ -265,6 +297,8 @@ void caml_oldify_mopup (void)
 {
   value v, new_v, f;
   mlsize_t i;
+  struct caml_ephe_ref_elt *re;
+  int redo = 0;
 
   while (oldify_todo_list != 0){
     v = oldify_todo_list;                /* Get the head. */
@@ -285,6 +319,28 @@ void caml_oldify_mopup (void)
       }
     }
   }
+
+  /* Oldify the data in the minor heap of alive ephemeron
+     During minor collection keys outside the minor heap are considered alive */
+  for (re = caml_ephe_ref_table.base;
+       re < caml_ephe_ref_table.ptr; re++){
+    /* look only at ephemeron with data in the minor heap */
+    if (re->offset == 1){
+      value *data = &Field(re->ephe,1);
+      if (*data != caml_ephe_none && Is_block (*data) && Is_young (*data)){
+        if (Hd_val (*data) == 0){ /* Value copied to major heap */
+          *data = Field (*data, 0);
+        } else {
+          if (ephe_check_alive_data(re)){
+            caml_oldify_one(*data,data);
+            redo = 1; /* oldify_todo_list can still be 0 */
+          }
+        }
+      }
+    }
+  }
+
+  if (redo) caml_oldify_mopup ();
 }
 
 /* Make sure the minor heap is empty by performing a minor collection
@@ -294,6 +350,7 @@ void caml_empty_minor_heap (void)
 {
   value **r;
   uintnat prev_alloc_words;
+  struct caml_ephe_ref_elt *re;
 
   if (caml_young_ptr != caml_young_alloc_end){
     if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) ();
@@ -309,15 +366,21 @@ void caml_empty_minor_heap (void)
     CAML_INSTR_TIME (tmr, "minor/ref_table");
     caml_oldify_mopup ();
     CAML_INSTR_TIME (tmr, "minor/copy");
-    for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
-      if (Is_block (**r) && Is_young (**r)){
-        if (Hd_val (**r) == 0){
-          **r = Field (**r, 0);
-        }else{
-          **r = caml_weak_none;
+    /* Update the ephemerons */
+    for (re = caml_ephe_ref_table.base;
+         re < caml_ephe_ref_table.ptr; re++){
+      value *key = &Field(re->ephe,re->offset);
+      if (*key != caml_ephe_none && Is_block (*key) && Is_young (*key)){
+        if (Hd_val (*key) == 0){ /* Value copied to major heap */
+          *key = Field (*key, 0);
+        }else{ /* Value not copied so it's dead */
+          Assert(!ephe_check_alive_data(re));
+          *key = caml_ephe_none;
+          Field(re->ephe,1) = caml_ephe_none;
         }
       }
     }
+    /* Run custom block finalisation of dead minor value */
     for (r = caml_finalize_table.base; r < caml_finalize_table.ptr; r++){
       int hd = Hd_val ((value)*r);
       if (hd != 0){         /* If not oldified the finalizer must be called */
@@ -330,9 +393,9 @@ void caml_empty_minor_heap (void)
     caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr)
                      / caml_minor_heap_wsz;
     caml_young_ptr = caml_young_alloc_end;
-    clear_table (&caml_ref_table);
-    clear_table (&caml_weak_ref_table);
-    clear_table (&caml_finalize_table);
+    clear_table ((struct generic_table *) &caml_ref_table);
+    clear_table ((struct generic_table *) &caml_ephe_ref_table);
+    clear_table ((struct generic_table *) &caml_finalize_table);
     caml_gc_message (0x02, ">", 0);
     caml_in_minor_collection = 0;
     caml_final_empty_young ();
@@ -427,16 +490,20 @@ CAMLexport value caml_check_urgent_gc (value extra_root)
   CAMLreturn (extra_root);
 }
 
-void caml_realloc_ref_table (struct caml_ref_table *tbl)
-{                                           Assert (tbl->ptr == tbl->limit);
+static void realloc_generic_table
+(struct generic_table *tbl, asize_t element_size,
+ char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error)
+{
+                                            Assert (tbl->ptr == tbl->limit);
                                             Assert (tbl->limit <= tbl->end);
                                       Assert (tbl->limit >= tbl->threshold);
 
   if (tbl->base == NULL){
-    caml_alloc_table (tbl, caml_minor_heap_wsz / 8, 256);
+    alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256,
+                         element_size);
   }else if (tbl->limit == tbl->threshold){
-    CAML_INSTR_INT ("request_minor/realloc_ref_table@", 1);
-    caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
+    CAML_INSTR_INT (msg_intr_int, 1);
+    caml_gc_message (0x08, msg_threshold, 0);
     tbl->limit = tbl->end;
     caml_request_minor_gc ();
   }else{
@@ -445,13 +512,11 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
     CAMLassert (caml_requested_minor_gc);
 
     tbl->size *= 2;
-    sz = (tbl->size + tbl->reserve) * sizeof (value *);
-    caml_gc_message (0x08, "Growing ref_table to %"
-                           ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
-                     (intnat) sz/1024);
-    tbl->base = (value **) realloc ((char *) tbl->base, sz);
+    sz = (tbl->size + tbl->reserve) * element_size;
+    caml_gc_message (0x08, msg_growing, (intnat) sz/1024);
+    tbl->base = (void *) realloc ((char *) tbl->base, sz);
     if (tbl->base == NULL){
-      caml_fatal_error ("Fatal error: ref_table overflow\n");
+      caml_fatal_error (msg_error);
     }
     tbl->end = tbl->base + tbl->size + tbl->reserve;
     tbl->threshold = tbl->base + tbl->size;
@@ -459,3 +524,23 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
     tbl->limit = tbl->end;
   }
 }
+
+void caml_realloc_ref_table (struct caml_ref_table *tbl)
+{
+  realloc_generic_table
+    ((struct generic_table *) tbl, sizeof (value *),
+     "request_minor/realloc_ref_table@",
+     "ref_table threshold crossed\n",
+     "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
+     "Fatal error: ref_table overflow\n");
+}
+
+void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl)
+{
+  realloc_generic_table
+    ((struct generic_table *) tbl, sizeof (struct caml_ephe_ref_elt),
+     "request_minor/realloc_ephe_ref_table@",
+     "ephe_ref_table threshold crossed\n",
+     "Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
+     "Fatal error: ephe_ref_table overflow\n");
+}

byterun/weak.c

@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Operations on weak arrays */
+/* Operations on weak arrays and ephemerons (named ephe here)*/
 
 #include <string.h>
 
@@ -20,30 +20,123 @@
 #include "caml/major_gc.h"
 #include "caml/memory.h"
 #include "caml/mlvalues.h"
+#include "caml/weak.h"
 
-value caml_weak_list_head = 0;
+value caml_ephe_list_head = 0;
+
+static value ephe_dummy = 0;
+value caml_ephe_none = (value) &ephe_dummy;
+
+#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
+/** The minor heap is considered alive.
+    Outside minor and major heap, x must be black.
+*/
+static inline int Is_Dead_during_clean(value x){
+  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
+  return Is_block (x) && !Is_young (x) && Is_white_val(x);
+}
+/** The minor heap doesn't have to be marked, outside they should
+    already be black
+*/
+static inline int Must_be_Marked_during_mark(value x){
+  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
+  return Is_block (x) && !Is_young (x);
+}
+#else
+static inline int Is_Dead_during_clean(value x){
+  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
+  return Is_block (x) && Is_in_heap (x) && Is_white_val(x);
+}
+static inline int Must_be_Marked_during_mark(value x){
+  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
+  return Is_block (x) && Is_in_heap (x);
+}
+#endif
 
-static value weak_dummy = 0;
-value caml_weak_none = (value) &weak_dummy;
 
 /* [len] is a value that represents a number of words (fields) */
-CAMLprim value caml_weak_create (value len)
+CAMLprim value caml_ephe_create (value len)
 {
   mlsize_t size, i;
   value res;
 
-  size = Long_val (len) + 1;
+  size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */;
   if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
   res = caml_alloc_shr (size, Abstract_tag);
-  for (i = 1; i < size; i++) Field (res, i) = caml_weak_none;
-  Field (res, 0) = caml_weak_list_head;
-  caml_weak_list_head = res;
+  for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none;
+  Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head;
+  caml_ephe_list_head = res;
   return res;
 }
 
+CAMLprim value caml_weak_create (value len)
+{
+  return caml_ephe_create(len);
+}
+
+/**
+   Specificity of the cleaning phase (Phase_clean):
+
+   The dead keys must be removed from the ephemerons and data removed
+   when one the keys is dead. Here we call it cleaning the ephemerons.
+   A specific phase of the GC is dedicated to this, Phase_clean. This
+   phase is just after the mark phase, so the white values are dead
+   values. It iterates the function caml_ephe_clean through all the
+   ephemerons.
+
+   However the GC is incremental and ocaml code can run on the middle
+   of this cleaning phase. In order to respect the semantic of the
+   ephemerons concerning dead values, the getter and setter must work
+   as if the cleaning of all the ephemerons have been done at once.
+
+   - key getter: Even if a dead key have not yet been replaced by
+     caml_ephe_none, getting it should return none.
+   - key setter: If we replace a dead key we need to set the data to
+     caml_ephe_none and clean the ephemeron.
+
+     This two cases are dealt by a call to do_check_key_clean that
+     trigger the cleaning of the ephemerons when the accessed key is
+     dead. This test is fast.
+
+     In the case of value getter and value setter, there is no fast
+     test because the removing of the data depend of the deadliness of the keys.
+     We must always try to clean the ephemerons.
+
+ */
+
 #define None_val (Val_int(0))
 #define Some_tag 0
 
+/* If we are in Phase_clean we need to check if the key
+   that is going to disappear is dead and so should trigger a cleaning
+ */
+static void do_check_key_clean(value ar, mlsize_t offset){
+                                   Assert ( offset >= 2);
+  if (caml_gc_phase == Phase_clean){
+    value elt = Field (ar, offset);
+    if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
+      Field(ar,offset) = caml_ephe_none;
+      Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
+    };
+  };
+}
+
+/* If we are in Phase_clean we need to do as if the key is empty when
+   it will be cleaned during this phase */
+static inline int is_ephe_key_none(value ar, mlsize_t offset){
+  value elt = Field (ar, offset);
+  if (elt == caml_ephe_none){
+    return 1;
+  }else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){
+    Field(ar,offset) = caml_ephe_none;
+    Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
+    return 1;
+  } else {
+    return 0;
+  }
+}
+
+
 static void do_set (value ar, mlsize_t offset, value v)
 {
   if (Is_block (v) && Is_young (v)){
@@ -51,46 +144,119 @@ static void do_set (value ar, mlsize_t offset, value v)
     value old = Field (ar, offset);
     Field (ar, offset) = v;
     if (!(Is_block (old) && Is_young (old))){
-      add_to_ref_table (&caml_weak_ref_table, &Field (ar, offset));
+      add_to_ephe_ref_table (&caml_ephe_ref_table, ar, offset);
     }
   }else{
     Field (ar, offset) = v;
   }
 }
 
-CAMLprim value caml_weak_set (value ar, value n, value el)
+CAMLprim value caml_ephe_set_key (value ar, value n, value el)
 {
-  mlsize_t offset = Long_val (n) + 1;
+  mlsize_t offset = Long_val (n) + 2;
                                                    Assert (Is_in_heap (ar));
-  if (offset < 1 || offset >= Wosize_val (ar)){
+  if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.set");
   }
+  do_check_key_clean(ar,offset);
+  do_set (ar, offset, el);
+  return Val_unit;
+}
+
+CAMLprim value caml_ephe_unset_key (value ar, value n)
+{
+  mlsize_t offset = Long_val (n) + 2;
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 2 || offset >= Wosize_val (ar)){
+    caml_invalid_argument ("Weak.set");
+  }
+  do_check_key_clean(ar,offset);
+  Field (ar, offset) = caml_ephe_none;
+  return Val_unit;
+}
+
+value caml_ephe_set_key_option (value ar, value n, value el)
+{
+  mlsize_t offset = Long_val (n) + 2;
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 2 || offset >= Wosize_val (ar)){
+    caml_invalid_argument ("Weak.set");
+  }
+  do_check_key_clean(ar,offset);
   if (el != None_val && Is_block (el)){
                                               Assert (Wosize_val (el) == 1);
     do_set (ar, offset, Field (el, 0));
   }else{
-    Field (ar, offset) = caml_weak_none;
+    Field (ar, offset) = caml_ephe_none;
   }
   return Val_unit;
 }
 
+CAMLprim value caml_weak_set (value ar, value n, value el){
+  return caml_ephe_set_key_option(ar,n,el);
+}
+
+CAMLprim value caml_ephe_set_data (value ar, value el)
+{
+                                                   Assert (Is_in_heap (ar));
+  if (caml_gc_phase == Phase_clean){
+    /* During this phase since we don't know which ephemeron have been
+       cleaned we always need to check it. */
+    caml_ephe_clean(ar);
+  };
+  do_set (ar, 1, el);
+  return Val_unit;
+}
+
+CAMLprim value caml_ephe_unset_data (value ar)
+{
+                                                   Assert (Is_in_heap (ar));
+  Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
+  return Val_unit;
+}
+
+
 #define Setup_for_gc
 #define Restore_after_gc
 
-CAMLprim value caml_weak_get (value ar, value n)
+CAMLprim value caml_ephe_get_key (value ar, value n)
 {
   CAMLparam2 (ar, n);
-  mlsize_t offset = Long_val (n) + 1;
+  mlsize_t offset = Long_val (n) + 2;
   CAMLlocal2 (res, elt);
                                                    Assert (Is_in_heap (ar));
-  if (offset < 1 || offset >= Wosize_val (ar)){
-    caml_invalid_argument ("Weak.get");
+  if (offset < 2 || offset >= Wosize_val (ar)){
+    caml_invalid_argument ("Weak.get_key");
   }
-  if (Field (ar, offset) == caml_weak_none){
+  if (is_ephe_key_none(ar, offset)){
     res = None_val;
   }else{
     elt = Field (ar, offset);
-    if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
+    if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
+      caml_darken (elt, NULL);
+    }
+    res = caml_alloc_small (1, Some_tag);
+    Field (res, 0) = elt;
+  }
+  CAMLreturn (res);
+}
+
+CAMLprim value caml_weak_get (value ar, value n){
+  return caml_ephe_get_key(ar, n);
+}
+
+CAMLprim value caml_ephe_get_data (value ar)
+{
+  CAMLparam1 (ar);
+  mlsize_t offset = 1;
+  CAMLlocal2 (res, elt);
+                                                   Assert (Is_in_heap (ar));
+  elt = Field (ar, offset);
+  if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
+  if (elt == caml_ephe_none){
+    res = None_val;
+  }else{
+    if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
       caml_darken (elt, NULL);
     }
     res = caml_alloc_small (1, Some_tag);
@@ -102,29 +268,29 @@ CAMLprim value caml_weak_get (value ar, value n)
 #undef Setup_for_gc
 #undef Restore_after_gc
 
-CAMLprim value caml_weak_get_copy (value ar, value n)
+CAMLprim value caml_ephe_get_key_copy (value ar, value n)
 {
   CAMLparam2 (ar, n);
-  mlsize_t offset = Long_val (n) + 1;
+  mlsize_t offset = Long_val (n) + 2;
   CAMLlocal2 (res, elt);
   value v;  /* Caution: this is NOT a local root. */
                                                    Assert (Is_in_heap (ar));
   if (offset < 1 || offset >= Wosize_val (ar)){
-    caml_invalid_argument ("Weak.get");
+    caml_invalid_argument ("Weak.get_copy");
   }
 
+  if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
   v = Field (ar, offset);
-  if (v == caml_weak_none) CAMLreturn (None_val);
   if (Is_block (v) && Is_in_heap_or_young(v)) {
     elt = caml_alloc (Wosize_val (v), Tag_val (v));
           /* The GC may erase or move v during this call to caml_alloc. */
     v = Field (ar, offset);
-    if (v == caml_weak_none) CAMLreturn (None_val);
+    if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
     if (Tag_val (v) < No_scan_tag){
       mlsize_t i;
       for (i = 0; i < Wosize_val (v); i++){
         value f = Field (v, i);
-        if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
+        if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
           caml_darken (f, NULL);
         }
         Modify (&Field (elt, i), f);
@@ -141,21 +307,74 @@ CAMLprim value caml_weak_get_copy (value ar, value n)
   CAMLreturn (res);
 }
 
-CAMLprim value caml_weak_check (value ar, value n)
-{
-  mlsize_t offset = Long_val (n) + 1;
-                                                   Assert (Is_in_heap (ar));
-  if (offset < 1 || offset >= Wosize_val (ar)){
-    caml_invalid_argument ("Weak.get");
-  }
-  return Val_bool (Field (ar, offset) != caml_weak_none);
+CAMLprim value caml_weak_get_copy (value ar, value n){
+  return caml_ephe_get_key_copy(ar,n);
 }
 
-CAMLprim value caml_weak_blit (value ars, value ofs,
+CAMLprim value caml_ephe_get_data_copy (value ar)
+{
+  CAMLparam1 (ar);
+  mlsize_t offset = 1;
+  CAMLlocal2 (res, elt);
+  value v;  /* Caution: this is NOT a local root. */
+                                                   Assert (Is_in_heap (ar));
+
+  v = Field (ar, offset);
+  if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
+  if (v == caml_ephe_none) CAMLreturn (None_val);
+  if (Is_block (v) && Is_in_heap_or_young(v)) {
+    elt = caml_alloc (Wosize_val (v), Tag_val (v));
+          /* The GC may erase or move v during this call to caml_alloc. */
+    v = Field (ar, offset);
+    if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
+    if (v == caml_ephe_none) CAMLreturn (None_val);
+    if (Tag_val (v) < No_scan_tag){
+      mlsize_t i;
+      for (i = 0; i < Wosize_val (v); i++){
+        value f = Field (v, i);
+        if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
+          caml_darken (f, NULL);
+        }
+        Modify (&Field (elt, i), f);
+      }
+    }else{
+      memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
+    }
+  }else{
+    elt = v;
+  }
+  res = caml_alloc_small (1, Some_tag);
+  Field (res, 0) = elt;
+
+  CAMLreturn (res);
+}
+
+CAMLprim value caml_ephe_check_key (value ar, value n)
+{
+  mlsize_t offset = Long_val (n) + 2;
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 2 || offset >= Wosize_val (ar)){
+    caml_invalid_argument ("Weak.check");
+  }
+  return Val_bool (!is_ephe_key_none(ar, offset));
+}
+
+CAMLprim value caml_weak_check (value ar, value n)
+{
+  return caml_ephe_check_key(ar,n);
+}
+
+CAMLprim value caml_ephe_check_data (value ar)
+{
+  if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
+  return Val_bool (Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none);
+}
+
+CAMLprim value caml_ephe_blit_key (value ars, value ofs,
                                value ard, value ofd, value len)
 {
-  mlsize_t offset_s = Long_val (ofs) + 1;
-  mlsize_t offset_d = Long_val (ofd) + 1;
+  mlsize_t offset_s = Long_val (ofs) + 2;
+  mlsize_t offset_d = Long_val (ofd) + 2;
   mlsize_t length = Long_val (len);
   long i;
                                                    Assert (Is_in_heap (ars));
@@ -166,14 +385,9 @@ CAMLprim value caml_weak_blit (value ars, value ofs,
   if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
     caml_invalid_argument ("Weak.blit");
   }
-  if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
-    for (i = 0; i < length; i++){
-      value v = Field (ars, offset_s + i);
-      if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
-          && Is_white_val (v)){
-        Field (ars, offset_s + i) = caml_weak_none;
-      }
-    }
+  if (caml_gc_phase == Phase_clean){
+    caml_ephe_clean(ars);
+    caml_ephe_clean(ard);
   }
   if (offset_d < offset_s){
     for (i = 0; i < length; i++){
@@ -186,3 +400,19 @@ CAMLprim value caml_weak_blit (value ars, value ofs,
   }
   return Val_unit;
 }
+
+CAMLprim value caml_ephe_blit_data (value ars, value ard)
+{
+  if(caml_gc_phase == Phase_clean) {
+    caml_ephe_clean(ars);
+    caml_ephe_clean(ard);
+  };
+  do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET));
+  return Val_unit;
+}
+
+CAMLprim value caml_weak_blit (value ars, value ofs,
+                      value ard, value ofd, value len)
+{
+  return caml_ephe_blit_key (ars, ofs, ard, ofd, len);
+}

otherlibs/threads/Makefile

@@ -33,7 +33,7 @@ LIB=../../stdlib
 
 LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo		\
   $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo	\
-  $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo	        \
+  $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo		\
   $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo			\
   $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo		\
   $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo	\
@@ -43,9 +43,10 @@ LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo		\
   $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo		\
   $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo	\
   $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo		\
-  $(LIB)/weak.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo		\
-  $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/bytesLabels.cmo	\
-  $(LIB)/stringLabels.cmo $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo
+  $(LIB)/weak.cmo $(LIB)/ephemeron.cmo $(LIB)/filename.cmo		\
+  $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo	\
+  $(LIB)/bytesLabels.cmo $(LIB)/stringLabels.cmo			\
+  $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo
 
 UNIXLIB=../unix
 

stdlib/.depend

@@ -48,6 +48,7 @@ stringLabels.cmi :
 sys.cmi :
 uchar.cmi : format.cmi
 weak.cmi : hashtbl.cmi
+ephemeron.cmi : hashtbl.cmi obj.cmi
 arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
     arg.cmi
 arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
@@ -176,6 +177,8 @@ uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi
 uchar.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi
 weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
 weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+ephemeron.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi obj.cmi ephemeron.cmi
+ephemeron.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx obj.cmx ephemeron.cmi
 arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
     arg.cmi
 arg.p.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
@@ -304,3 +307,5 @@ uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi
 uchar.p.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi
 weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
 weak.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+ephemeron.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi obj.cmi ephemeron.cmi
+ephemeron.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx obj.cmx ephemeron.cmi

stdlib/Makefile.shared

@@ -36,7 +36,7 @@ OTHERS=list.cmo char.cmo bytes.cmo string.cmo sys.cmo \
   digest.cmo random.cmo hashtbl.cmo weak.cmo \
   format.cmo uchar.cmo scanf.cmo callback.cmo \
   camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
-  genlex.cmo \
+  genlex.cmo ephemeron.cmo \
   filename.cmo complex.cmo \
   arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
   stringLabels.cmo moreLabels.cmo stdLabels.cmo

stdlib/ephemeron.ml

@@ -0,0 +1,614 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+module type SeededS = sig
+  include Hashtbl.SeededS
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module type S = sig
+  include Hashtbl.S
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module GenHashTable = struct
+
+  type equal =
+  | ETrue | EFalse
+  | EDead (** the garbage collector reclaimed the data *)
+
+  module MakeSeeded(H: sig
+    type t
+    type 'a container
+    val create: t -> 'a -> 'a container
+    val hash: int -> t -> int
+    val equal: 'a container -> t -> equal
+    val get_data: 'a container -> 'a option
+    val get_key: 'a container -> t option
+    val set_key_data: 'a container -> t -> 'a -> unit
+    val check_key: 'a container -> bool
+  end) : SeededS with type key = H.t
+  = struct
+
+    type 'a t =
+      { mutable size: int;                        (* number of entries *)
+        mutable data: 'a bucketlist array;  (* the buckets *)
+        mutable seed: int;                        (* for randomization *)
+        initial_size: int;                        (* initial array size *)
+      }
+
+    and 'a bucketlist =
+    | Empty
+    | Cons of int (** hash of the key *) * 'a H.container * 'a bucketlist
+
+    (** the hash of the key is kept in order to test the equality of the hash
+      before the key. Same reason than for Weak.Make *)
+
+    type key = H.t
+
+    let rec power_2_above x n =
+      if x >= n then x
+      else if x * 2 > Sys.max_array_length then x
+      else power_2_above (x * 2) n
+
+    let prng = lazy (Random.State.make_self_init())
+
+    let create ?(random = (Hashtbl.is_randomized ())) initial_size =
+      let s = power_2_above 16 initial_size in
+      let seed = if random then Random.State.bits (Lazy.force prng) else 0 in
+      { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
+
+    let clear h =
+      h.size <- 0;
+      let len = Array.length h.data in
+      for i = 0 to len - 1 do
+        h.data.(i) <- Empty
+      done
+
+    let reset h =
+      let len = Array.length h.data in
+      if len = h.initial_size then
+        clear h
+      else begin
+        h.size <- 0;
+        h.data <- Array.make h.initial_size Empty
+      end
+
+    let copy h = { h with data = Array.copy h.data }
+
+    let key_index h hkey =
+      hkey land (Array.length h.data - 1)
+
+    let clean h =
+      let rec do_bucket = function
+        | Empty ->
+            Empty
+        | Cons(_, c, rest) when not (H.check_key c) ->
+            h.size <- h.size - 1;
+            do_bucket rest
+        | Cons(hkey, c, rest) ->
+            Cons(hkey, c, do_bucket rest)
+      in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        d.(i) <- do_bucket d.(i)
+      done
+
+    (** resize is the only function to do the actual cleaning of dead keys
+        (remove does it just because it could).
+
+        The goal is to:
+
+        - not resize infinitely when the actual number of alive keys is
+        bounded but keys are continuously added. That would happen if
+        this function always resize.
+        - not call this function after each addition, that would happen if this
+        function don't resize even when only one key is dead.
+
+        So the algorithm:
+        - clean the keys before resizing
+        - if the number of remaining key is less than half the size of the
+        array, don't resize.
+        - if it is more, resize.
+
+        The second problem remains if the table reaches {!Sys.max_array_length}.
+
+    *)
+    let resize h =
+      let odata = h.data in
+      let osize = Array.length odata in
+      let nsize = osize * 2 in
+      clean h;
+      if nsize < Sys.max_array_length && h.size >= osize lsr 1 then begin
+        let ndata = Array.make nsize Empty in
+        h.data <- ndata;       (* so that key_index sees the new bucket count *)
+        let rec insert_bucket = function
+            Empty -> ()
+          | Cons(hkey, data, rest) ->
+              insert_bucket rest; (* preserve original order of elements *)
+              let nidx = key_index h hkey in
+              ndata.(nidx) <- Cons(hkey, data, ndata.(nidx)) in
+        for i = 0 to osize - 1 do
+          insert_bucket odata.(i)
+        done
+      end
+
+    let add h key info =
+      let hkey = H.hash h.seed key in
+      let i = key_index h hkey in
+      let container = H.create key info in
+      let bucket = Cons(hkey, container, h.data.(i)) in
+      h.data.(i) <- bucket;
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize h
+
+    let remove h key =
+      let hkey = H.hash h.seed key in
+      let rec remove_bucket = function
+        | Empty -> Empty
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> h.size <- h.size - 1; next
+            | EFalse -> Cons(hk, c, remove_bucket next)
+            | EDead ->
+                (** The dead key is automatically removed. It is acceptable
+                    for this function since it already remove a binding *)
+                h.size <- h.size - 1;
+                remove_bucket next
+            end
+        | Cons(hk,c,next) -> Cons(hk, c, remove_bucket next) in
+      let i = key_index h hkey in
+      h.data.(i) <- remove_bucket h.data.(i)
+
+    (** {!find} don't remove dead keys because it would be surprising for
+        the user that a read-only function mutate the state (eg. concurrent
+        access). Same for {!iter}, {!fold}, {!mem}.
+    *)
+    let rec find_rec key hkey = function
+      | Empty ->
+          raise Not_found
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue ->
+              begin match H.get_data c with
+              | None ->
+                  (** This case is not impossible because the gc can run between
+                      H.equal and H.get_data *)
+                  find_rec key hkey rest
+              | Some d -> d
+              end
+          | EFalse -> find_rec key hkey rest
+          | EDead ->
+              find_rec key hkey rest
+          end
+      | Cons(_, _, rest) ->
+          find_rec key hkey rest
+
+    let find h key =
+      let hkey = H.hash h.seed key in
+      (** TODO inline 3 iteration *)
+      find_rec key hkey (h.data.(key_index h hkey))
+
+    let find_all h key =
+      let hkey = H.hash h.seed key in
+      let rec find_in_bucket = function
+      | Empty -> []
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue -> begin match H.get_data c with
+              | None ->
+                  find_in_bucket rest
+              | Some d -> d::find_in_bucket rest
+            end
+          | EFalse -> find_in_bucket rest
+          | EDead ->
+              find_in_bucket rest
+          end
+      | Cons(_, _, rest) ->
+          find_in_bucket rest in
+      find_in_bucket h.data.(key_index h hkey)
+
+
+    let replace h key info =
+      let hkey = H.hash h.seed key in
+      let rec replace_bucket = function
+        | Empty -> raise Not_found
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> H.set_key_data c key info
+            | EFalse | EDead -> replace_bucket next
+            end
+        | Cons(_,_,next) -> replace_bucket next
+      in
+      let i = key_index h hkey in
+      let l = h.data.(i) in
+      try
+        replace_bucket l
+      with Not_found ->
+        let container = H.create key info in
+        h.data.(i) <- Cons(hkey, container, l);
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize h
+
+    let mem h key =
+      let hkey = H.hash h.seed key in
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons(hk, c, rest) when hk = hkey ->
+          begin match H.equal c key with
+          | ETrue -> true
+          | EFalse | EDead -> mem_in_bucket rest
+          end
+      | Cons(hk, c, rest) -> mem_in_bucket rest in
+      mem_in_bucket h.data.(key_index h hkey)
+
+    let iter f h =
+      let rec do_bucket = function
+        | Empty ->
+            ()
+        | Cons(_, c, rest) ->
+            begin match H.get_key c, H.get_data c with
+            | None, _ | _, None -> ()
+            | Some k, Some d -> f k d
+            end; do_bucket rest in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        do_bucket d.(i)
+      done
+
+    let fold f h init =
+      let rec do_bucket b accu =
+        match b with
+          Empty ->
+            accu
+        | Cons(_, c, rest) ->
+            let accu = begin match H.get_key c, H.get_data c with
+              | None, _ | _, None -> accu
+              | Some k, Some d -> f k d accu
+            end in
+            do_bucket rest accu  in
+      let d = h.data in
+      let accu = ref init in
+      for i = 0 to Array.length d - 1 do
+        accu := do_bucket d.(i) !accu
+      done;
+      !accu
+
+    let filter_map_inplace f h =
+      let rec do_bucket = function
+        | Empty ->
+            Empty
+        | Cons(hk, c, rest) ->
+            match H.get_key c, H.get_data c with
+            | None, _ | _, None ->
+                do_bucket rest
+            | Some k, Some d ->
+                match f k d with
+                | None ->
+                    do_bucket rest
+                | Some new_d ->
+                    H.set_key_data c k new_d;
+                    Cons(hk, c, do_bucket rest)
+      in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        d.(i) <- do_bucket d.(i)
+      done
+
+    let length h = h.size
+
+    let rec bucket_length accu = function
+      | Empty -> accu
+      | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+
+    let stats h =
+      let mbl =
+        Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length 0 b in
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = h.size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+    let rec bucket_length_alive accu = function
+      | Empty -> accu
+      | Cons(_, c, rest) when H.check_key c ->
+          bucket_length_alive (accu + 1) rest
+      | Cons(_, _, rest) -> bucket_length_alive accu rest
+
+    let stats_alive h =
+      let size = ref 0 in
+      let mbl =
+        Array.fold_left (fun m b -> max m (bucket_length_alive 0 b)) 0 h.data in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length_alive 0 b in
+           size := !size + l;
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = !size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+
+  end
+end
+
+module ObjEph = Obj.Ephemeron
+
+let _obj_opt : Obj.t option -> 'a option = fun x ->
+  match x with
+  | None -> x
+  | Some v -> Some (Obj.obj v)
+
+(** The previous function is typed so this one is also correct *)
+let obj_opt : Obj.t option -> 'a option = fun x -> Obj.magic x
+
+
+module K1 = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create () : ('k,'d) t = ObjEph.create 1
+
+  let get_key (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key t 0)
+  let get_key_copy (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key_copy t 0)
+  let set_key (t:('k,'d) t) (k:'k) : unit = ObjEph.set_key t 0 (Obj.repr k)
+  let unset_key (t:('k,'d) t) : unit = ObjEph.unset_key t 0
+  let check_key (t:('k,'d) t) : bool = ObjEph.check_key t 0
+
+  let blit_key (t1:('k,'d) t) (t2:('k,'d) t): unit =
+    ObjEph.blit_key t1 0 t2 0 1
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t
+      let create k d =
+        let c = create () in
+        set_data c d;
+        set_key c k;
+        c
+      let hash = H.hash
+      let equal c k =
+        (** {!get_key_copy} is not used because the equality of the user can be
+            the physical equality *)
+        match get_key c with
+        | None -> GenHashTable.EDead
+        | Some k' ->
+            if H.equal k k' then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let get_key = get_key
+      let set_key_data c k d =
+        unset_data c;
+        set_key c k;
+        set_data c d
+      let check_key = check_key
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+  end
+
+end
+
+module K2 = struct
+  type ('k1, 'k2, 'd) t = ObjEph.t
+
+  let create () : ('k1,'k2,'d) t = ObjEph.create 2
+
+  let get_key1 (t:('k1,'k2,'d) t) : 'k1 option = obj_opt (ObjEph.get_key t 0)
+  let get_key1_copy (t:('k1,'k2,'d) t) : 'k1 option =
+    obj_opt (ObjEph.get_key_copy t 0)
+  let set_key1 (t:('k1,'k2,'d) t) (k:'k1) : unit =
+    ObjEph.set_key t 0 (Obj.repr k)
+  let unset_key1 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 0
+  let check_key1 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 0
+
+  let get_key2 (t:('k1,'k2,'d) t) : 'k2 option = obj_opt (ObjEph.get_key t 1)
+  let get_key2_copy (t:('k1,'k2,'d) t) : 'k2 option =
+    obj_opt (ObjEph.get_key_copy t 1)
+  let set_key2 (t:('k1,'k2,'d) t) (k:'k2) : unit =
+    ObjEph.set_key t 1 (Obj.repr k)
+  let unset_key2 (t:('k1,'k2,'d) t) : unit = ObjEph.unset_key t 1
+  let check_key2 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 1
+
+
+  let blit_key1 (t1:('k1,_,_) t) (t2:('k1,_,_) t) : unit =
+    ObjEph.blit_key t1 0 t2 0 1
+  let blit_key2 (t1:(_,'k2,_) t) (t2:(_,'k2,_) t) : unit =
+    ObjEph.blit_key t1 1 t2 1 1
+  let blit_key12 (t1:('k1,'k2,_) t) (t2:('k1,'k2,_) t) : unit =
+    ObjEph.blit_key t1 0 t2 0 2
+
+  let get_data (t:('k1,'k2,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k1,'k2,'d) t) : 'd option =
+    obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k1,'k2,'d) t) (d:'d) : unit =
+    ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k1,'k2,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k1,'k2,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,_,'d) t) (t2:(_,_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded
+      (H1:Hashtbl.SeededHashedType)
+      (H2:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H1.t,H2.t,'a) t
+      type t = H1.t * H2.t
+      let create (k1,k2) d =
+        let c = create () in
+        set_data c d;
+        set_key1 c k1; set_key2 c k2;
+        c
+      let hash seed (k1,k2) =
+        H1.hash seed k1 + H2.hash seed k2 * 65599
+      let equal c (k1,k2) =
+        match get_key1 c, get_key2 c with
+        | None, _ | _ , None -> GenHashTable.EDead
+        | Some k1', Some k2' ->
+            if H1.equal k1 k1' && H2.equal k2 k2'
+            then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let get_key c =
+        match get_key1 c, get_key2 c with
+        | None, _ | _ , None -> None
+        | Some k1', Some k2' -> Some (k1', k2')
+      let set_key_data c (k1,k2) d =
+        unset_data c;
+        set_key1 c k1; set_key2 c k2;
+        set_data c d
+      let check_key c = check_key1 c && check_key2 c
+    end)
+
+  module Make(H1: Hashtbl.HashedType)(H2: Hashtbl.HashedType):
+    (S with type key = H1.t * H2.t) =
+  struct
+    include MakeSeeded
+        (struct
+          type t = H1.t
+          let equal = H1.equal
+          let hash (seed: int) x = H1.hash x
+        end)
+        (struct
+          type t = H2.t
+          let equal = H2.equal
+          let hash (seed: int) x = H2.hash x
+        end)
+    let create sz = create ~random:false sz
+  end
+
+end
+
+module Kn = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create n : ('k,'d) t = ObjEph.create n
+  let length (k:('k,'d) t) : int = ObjEph.length k
+
+  let get_key (t:('k,'d) t) (n:int) : 'k option = obj_opt (ObjEph.get_key t n)
+  let get_key_copy (t:('k,'d) t) (n:int) : 'k option =
+    obj_opt (ObjEph.get_key_copy t n)
+  let set_key (t:('k,'d) t) (n:int) (k:'k) : unit =
+    ObjEph.set_key t n (Obj.repr k)
+  let unset_key (t:('k,'d) t) (n:int) : unit = ObjEph.unset_key t n
+  let check_key (t:('k,'d) t) (n:int) : bool = ObjEph.check_key t n
+
+  let blit_key (t1:('k,'d) t) (o1:int) (t2:('k,'d) t) (o2:int) (l:int) : unit =
+    ObjEph.blit_key t1 o1 t2 o2 l
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let get_data_copy (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data_copy t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+  let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
+  let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t array
+      let create k d =
+        let c = create (Array.length k) in
+        set_data c d;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        c
+      let hash seed k =
+        let h = ref 0 in
+        for i=0 to Array.length k -1 do
+          h := H.hash seed k.(i) * 65599 + !h;
+        done;
+        !h
+      let equal c k =
+        let len  = Array.length k in
+        let len' = length c in
+        if len != len' then GenHashTable.EFalse
+        else
+          let rec equal_array k c i =
+            if i < 0 then GenHashTable.ETrue
+            else
+              match get_key c i with
+              | None -> GenHashTable.EDead
+              | Some ki ->
+                  if H.equal k.(i) ki
+                  then equal_array k c (i-1)
+                  else GenHashTable.EFalse
+          in
+          equal_array k c (len-1)
+      let get_data = get_data
+      let get_key c =
+        let len = length c in
+        if len = 0 then Some [||]
+        else
+          match get_key c 0 with
+          | None -> None
+          | Some k0 ->
+              let rec fill a i =
+                if i < 1 then Some a
+                else
+                  match get_key c i with
+                  | None -> None
+                  | Some ki ->
+                      a.(i) <- ki;
+                      fill a (i-1)
+              in
+              let a = Array.make len k0 in
+              fill a (len-1)
+      let set_key_data c k d =
+        unset_data c;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        set_data c d
+      let check_key c =
+        let rec check c i =
+          i < 0 || (check_key c i && check c (i-1)) in
+        check c (length c - 1)
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t array) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+  end
+end

stdlib/ephemeron.mli

@@ -0,0 +1,334 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** Ephemerons and weak hash table *)
+
+(** Ephemerons and weak hash table
+
+    Ephemerons and weak hashtable are useful when one wants to cache
+    or memorize the computation of a function, as long as the
+    arguments and the function are used, without creating memory leaks
+    by continuously keeping old computation results that are not
+    useful anymore because one argument or the function is freed. An
+    implementation using {Hashtbl.t} is not suitable, because all
+    associations would keep in memory the arguments and the result.
+
+    Ephemerons can also be used for "adding" a field to an arbitrary
+    boxed ocaml value: you can attach an information to a value
+    created by an external library without memory leaks.
+
+    Ephemerons hold some keys and one or no data. They are all boxed
+    ocaml values. The keys of an ephemerons have the same behavior
+    than weak pointers according to the garbage collector. In fact
+    ocaml weak pointers are implemented as ephemerons without data.
+
+    The keys and data of an ephemeron are said to be full if they
+    point to a value, empty if the value have never been set, have
+    been unset, or was erased by the GC. In the function that access
+    the keys or data these two states are represented by the [option]
+    type.
+
+    The data is considered by the garbage collector alive if all the
+    full keys are alive and if the ephemeron is alive. When one of the
+    keys is not considered alive anymore by the GC, the data is
+    emptied from the ephemeron. The data could be alive for another
+    reason and in that case the GC will free it, but the ephemerons
+    will not hold the data anymore.
+
+    The ephemerons complicate the notion of liveness of values, because
+    it is not anymore an equivalence with the reachability from root
+    value by usual pointers (not weak and not ephemerons). With ephemerons
+    the notion of liveness is constructed by the least fixpoint of:
+       A value is alive if:
+        - it is a root value
+        - it is reachable from alive value by usual pointers
+        - it is the data of an alive ephemeron with all its full keys alive
+
+    Notes:
+    - All the types defined in this module cannot be marshaled
+    using {!Pervasives.output_value} nor the functions of the
+    {!Marshal} module.
+
+    Ephemerons are defined in a language agnostic way in this paper:
+    B. Hayes, Ephemerons: a New Finalization Mechanism, OOPSLA'9
+
+*)
+
+module type S = sig
+  (** Propose the same interface than usual hash table. However since
+      the bindings are weak, [mem h k] is true doesn't mean that a
+      just following [find h k] will not raise the exception
+      [Not_found] since the garbage collector can run between the two.
+
+      Secondly during an iteration the table shouldn't be modified use
+      instead {!filter_map_inplace} for that purpose.
+  *)
+
+  include Hashtbl.S
+
+  val clean: 'a t -> unit
+  (** remove all dead bindings. Done automatically during automatic resizing. *)
+  val stats_alive: 'a t -> Hashtbl.statistics
+  (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *)
+end
+(** The output signature of the functor {!K1.Make} and {!K2.Make}.
+    These hash tables are weak in the keys. If all the keys of a binding are
+    alive the binding is kept, but if one of the keys of the binding
+    is dead then the binding is removed.
+*)
+
+module type SeededS = sig
+  include Hashtbl.SeededS
+  val clean: 'a t -> unit
+  (** remove all dead bindings. Done automatically during automatic resizing. *)
+  val stats_alive: 'a t -> Hashtbl.statistics
+  (** same as {!Hashtbl.SeededS.stats} but only count the alive bindings *)
+end
+(** The output signature of the functor {!K1.MakeSeeded} and {!K2.MakeSeeded}.
+*)
+
+module K1 : sig
+  type ('k,'d) t (** an ephemeron with one key *)
+
+  val create: unit -> ('k,'d) t
+  (** [Ephemeron.K1.create ()] creates an ephemeron with one key. The
+      data and key are empty *)
+
+  val get_key: ('k,'d) t -> 'k option
+  (** [Ephemeron.K1.get_key eph] returns [None] if the key of [eph] is
+      empty, [Some x] (where [x] is the key) if it is full. *)
+
+  val get_key_copy: ('k,'d) t -> 'k option
+  (** [Ephemeron.K1.get_key_copy eph] returns [None] if the key of [eph] is
+      empty, [Some x] (where [x] is a (shallow) copy of the key) if
+      it is full. This function has the same GC friendliness as {!Weak.get_copy}
+  *)
+
+  val set_key: ('k,'d) t -> 'k -> unit
+  (** [Ephemeron.K1.set_key eph el] sets the key of [eph] to be a
+      (full) key to [el]
+  *)
+
+  val unset_key: ('k,'d) t -> unit
+  (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an
+      empty key. Since there is only one key, the ephemeron start
+      behaving like a references on the data. *)
+
+  val check_key: ('k,'d) t -> bool
+  (** [Ephemeron.K1.check_key eph] returns [true] if the key of the [eph]
+      is full, [false] if it is empty. Note that even if
+      [Ephemeron.K1.check_key eph] returns [true], a subsequent
+      {!Ephemeron.K1.get_key}[eph] can return [None].
+  *)
+
+
+  val blit_key : ('k,_) t -> ('k,_) t -> unit
+  (** [Ephemeron.K1.blit_key eph1 eph2] sets the key of [eph2] with
+      the key of [eph1]. Contrary to using [Ephemeron.K1.get_key]
+      followed by [Ephemeron.K1.set_key] or [Ephemeon.K1.unset_key]
+      this function does not prevent the incremental GC from erasing
+      the value in its current cycle. *)
+
+  val get_data: ('k,'d) t -> 'd option
+  (** [Ephemeron.K1.get_data eph] returns [None] if the data of [eph] is
+      empty, [Some x] (where [x] is the data) if it is full. *)
+
+  val get_data_copy: ('k,'d) t -> 'd option
+  (** [Ephemeron.K1.get_data_copy eph] returns [None] if the data of [eph] is
+      empty, [Some x] (where [x] is a (shallow) copy of the data) if
+      it is full. This function has the same GC friendliness as {!Weak.get_copy}
+  *)
+
+  val set_data: ('k,'d) t -> 'd -> unit
+  (** [Ephemeron.K1.set_data eph el] sets the data of [eph] to be a
+      (full) data to [el]
+  *)
+
+  val unset_data: ('k,'d) t -> unit
+  (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an
+      empty key. The ephemeron start behaving like a weak pointer.
+  *)
+
+  val check_data: ('k,'d) t -> bool
+  (** [Ephemeron.K1.check_data eph] returns [true] if the data of the [eph]
+      is full, [false] if it is empty. Note that even if
+      [Ephemeron.K1.check_data eph] returns [true], a subsequent
+      {!Ephemeron.K1.get_data}[eph] can return [None].
+  *)
+
+  val blit_data : (_,'d) t -> (_,'d) t -> unit
+  (** [Ephemeron.K1.blit_data eph1 eph2] sets the data of [eph2] with
+      the data of [eph1]. Contrary to using [Ephemeron.K1.get_data]
+      followed by [Ephemeron.K1.set_data] or [Ephemeon.K1.unset_data]
+      this function does not prevent the incremental GC from erasing
+      the value in its current cycle. *)
+
+  module Make (H:Hashtbl.HashedType) : S with type key = H.t
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) : SeededS with type key = H.t
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module K2 : sig
+  type ('k1,'k2,'d) t (** an ephemeron with two keys *)
+
+  val create: unit -> ('k1,'k2,'d) t
+  (** Same as {!Ephemeron.K1.create} *)
+
+  val get_key1: ('k1,'k2,'d) t -> 'k1 option
+  (** Same as {!Ephemeron.K1.get_key} *)
+  val get_key1_copy: ('k1,'k2,'d) t -> 'k1 option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+  val set_key1: ('k1,'k2,'d) t -> 'k1 -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+  val unset_key1: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+  val check_key1: ('k1,'k2,'d) t ->  bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val get_key2: ('k1,'k2,'d) t -> 'k2 option
+  (** Same as {!Ephemeron.K1.get_key} *)
+  val get_key2_copy: ('k1,'k2,'d) t -> 'k2 option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+  val set_key2: ('k1,'k2,'d) t -> 'k2 -> unit
+  (** Same as {!Ephemeron.K1.get_key} *)
+  val unset_key2: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+  val check_key2: ('k1,'k2,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val blit_key1  : ('k1,_,_) t -> ('k1,_,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+  val blit_key2  : (_,'k2,_) t -> (_,'k2,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+  val blit_key12 : ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: ('k1,'k2,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data} *)
+  val get_data_copy: ('k1,'k2,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+  val set_data: ('k1,'k2,'d) t -> 'd -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+  val unset_data: ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+  val check_data: ('k1,'k2,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+  val blit_data: ('k1,'k2,'d) t -> ('k1,'k2,'d) t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+
+  module Make
+      (H1:Hashtbl.HashedType)
+      (H2:Hashtbl.HashedType) :
+    S with type key = H1.t * H2.t
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded
+      (H1:Hashtbl.SeededHashedType)
+      (H2:Hashtbl.SeededHashedType) :
+    SeededS with type key = H1.t * H2.t
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module Kn : sig
+  type ('k,'d) t (** an ephemeron with an arbitrary number of keys
+                      of the same types *)
+
+  val create: int -> ('k,'d) t
+  (** Same as {!Ephemeron.K1.create} *)
+
+  val get_key: ('k,'d) t -> int -> 'k option
+  (** Same as {!Ephemeron.K1.get_key} *)
+  val get_key_copy: ('k,'d) t -> int -> 'k option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+  val set_key: ('k,'d) t -> int -> 'k -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+  val unset_key: ('k,'d) t -> int -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+  val check_key: ('k,'d) t -> int ->  bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+
+  val blit_key  : ('k,_) t -> int -> ('k,_) t -> int -> int -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: ('k,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data} *)
+  val get_data_copy: ('k,'d) t -> 'd option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+  val set_data: ('k,'d) t -> 'd -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+  val unset_data: ('k,'d) t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+  val check_data: ('k,'d) t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+  val blit_data: ('k,'d) t -> ('k,'d) t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+
+  module Make
+      (H:Hashtbl.HashedType) :
+    S with type key = H.t array
+  (** Functor building an implementation of a weak hash table *)
+
+  module MakeSeeded
+      (H:Hashtbl.SeededHashedType) :
+    SeededS with type key = H.t array
+  (** Functor building an implementation of a weak hash table.
+      The seed is similar to the one of {!Hashtbl.MakeSeeded}. *)
+
+end
+
+module GenHashTable: sig
+  (** Define hash table on generic containers which have a notion of
+      "death" and aliveness. If a binding is dead the hash table can
+      automatically remove it. *)
+
+  type equal =
+  | ETrue | EFalse
+  | EDead (** the container is dead *)
+
+  module MakeSeeded(H:
+  sig
+    type t
+    (** keys *)
+    type 'a container
+    (** contains keys and the associated data *)
+
+    val hash: int -> t -> int
+    (** same as {!Hashtbl.SeededHashedType} *)
+    val equal: 'a container -> t -> equal
+    (** equality predicate used to compare a key with the one in a
+        container. Can return [EDead] if the keys in the container are
+        dead *)
+
+    val create: t -> 'a -> 'a container
+    (** [create key data] creates a container from
+        some initials keys and one data *)
+    val get_key: 'a container -> t option
+    (** [get_key cont] returns the keys if they are all alive *)
+    val get_data: 'a container -> 'a option
+    (** [get_data cont] return the data if it is alive *)
+    val set_key_data: 'a container -> t -> 'a -> unit
+    (** [set_key_data cont] modify the key and data *)
+    val check_key: 'a container -> bool
+    (** [check_key cont] checks if all the keys contained in the data
+        are alive *)
+  end) : SeededS with type key = H.t
+  (** Functor building an implementation of an hash table that use the container
+      for keeping the information given *)
+
+end

stdlib/hashtbl.ml

@@ -47,6 +47,7 @@ let randomized_default =
 let randomized = ref randomized_default
 
 let randomize () = randomized := true
+let is_randomized () = !randomized
 
 let prng = lazy (Random.State.make_self_init())
 

stdlib/hashtbl.mli

@@ -182,6 +182,11 @@ val randomize : unit -> unit
 
     @since 4.00.0 *)
 
+val is_randomized : unit -> bool
+(** return if the tables are currently created in randomized mode by default
+
+    @since 4.02.0 *)
+
 type statistics = {
   num_bindings: int;
     (** Number of bindings present in the table.

stdlib/obj.ml

@@ -80,3 +80,30 @@ let extension_name (slot : extension_constructor) =
 
 let extension_id (slot : extension_constructor) =
   (obj (field (repr slot) 1) : int)
+
+module Ephemeron = struct
+  type obj_t = t
+
+  type t (** ephemeron *)
+
+  external create: int -> t = "caml_ephe_create"
+
+  let length x = size(repr x) - 2
+
+  external get_key: t -> int -> obj_t option = "caml_ephe_get_key"
+  external get_key_copy: t -> int -> obj_t option = "caml_ephe_get_key_copy"
+  external set_key: t -> int -> obj_t -> unit = "caml_ephe_set_key"
+  external unset_key: t -> int -> unit = "caml_ephe_unset_key"
+  external check_key: t -> int -> bool = "caml_ephe_check_key"
+  external blit_key : t -> int -> t -> int -> int -> unit
+    = "caml_ephe_blit_key"
+
+  external get_data: t -> obj_t option = "caml_ephe_get_data"
+  external get_data_copy: t -> obj_t option = "caml_ephe_get_data_copy"
+  external set_data: t -> obj_t -> unit = "caml_ephe_set_data"
+  external unset_data: t -> unit = "caml_ephe_unset_data"
+  external check_data: t -> bool = "caml_ephe_check_data"
+  external blit_data : t -> t -> unit = "caml_ephe_blit_data"
+
+
+end

stdlib/obj.mli

@@ -85,3 +85,45 @@ val marshal : t -> bytes
   [@@ocaml.deprecated "Use Marshal.to_bytes instead."]
 val unmarshal : bytes -> int -> t * int
   [@@ocaml.deprecated "Use Marshal.from_bytes and Marshal.total_size instead."]
+
+module Ephemeron: sig
+  (** Ephemeron with arbitrary arity and untyped *)
+
+  type obj_t = t
+  (** alias for {!Obj.t} *)
+
+  type t
+  (** an ephemeron cf {!Ephemeron} *)
+
+  val create: int -> t
+  (** [create n] returns an ephemeron with [n] keys.
+      All the keys and the data are initially empty *)
+  val length: t -> int
+  (** return the number of keys *)
+
+  val get_key: t -> int -> obj_t option
+  (** Same as {!Ephemeron.K1.get_key} *)
+  val get_key_copy: t -> int -> obj_t option
+  (** Same as {!Ephemeron.K1.get_key_copy} *)
+  val set_key: t -> int -> obj_t -> unit
+  (** Same as {!Ephemeron.K1.set_key} *)
+  val unset_key: t -> int -> unit
+  (** Same as {!Ephemeron.K1.unset_key} *)
+  val check_key: t -> int -> bool
+  (** Same as {!Ephemeron.K1.check_key} *)
+  val blit_key : t -> int -> t -> int -> int -> unit
+  (** Same as {!Ephemeron.K1.blit_key} *)
+
+  val get_data: t -> obj_t option
+  (** Same as {!Ephemeron.K1.get_data} *)
+  val get_data_copy: t -> obj_t option
+  (** Same as {!Ephemeron.K1.get_data_copy} *)
+  val set_data: t -> obj_t -> unit
+  (** Same as {!Ephemeron.K1.set_data} *)
+  val unset_data: t -> unit
+  (** Same as {!Ephemeron.K1.unset_data} *)
+  val check_data: t -> bool
+  (** Same as {!Ephemeron.K1.check_data} *)
+  val blit_data : t -> t -> unit
+  (** Same as {!Ephemeron.K1.blit_data} *)
+end

stdlib/stdlib.mllib

@@ -39,6 +39,7 @@ Oo
 CamlinternalMod
 Genlex
 Weak
+Ephemeron
 Filename
 Complex
 ArrayLabels

stdlib/weak.ml

@@ -17,7 +17,7 @@ type 'a t;;
 
 external create : int -> 'a t = "caml_weak_create";;
 
-let length x = Obj.size(Obj.repr x) - 1;;
+let length x = Obj.size(Obj.repr x) - 2;;
 
 external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";;
 external get : 'a t -> int -> 'a option = "caml_weak_get";;

stdlib/weak.mli

@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(** Arrays of weak pointers and hash tables of weak pointers. *)
+(** Arrays of weak pointers and hash sets of weak pointers. *)
 
 
 (** {6 Low-level functions} *)
@@ -86,13 +86,13 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit
    do not designate a valid subarray of [ar2].*)
 
 
-(** {6 Weak hash tables} *)
+(** {6 Weak hash sets} *)
 
-(** A weak hash table is a hashed set of values.  Each value may
+(** A weak hash set is a hashed set of values.  Each value may
     magically disappear from the set when it is not used by the
     rest of the program any more.  This is normally used to share
     data structures without inducing memory leaks.
-    Weak hash tables are defined on values from a {!Hashtbl.HashedType}
+    Weak hash sets are defined on values from a {!Hashtbl.HashedType}
     module; the [equal] relation and [hash] function are taken from that
     module.  We will say that [v] is an instance of [x] if [equal x v]
     is [true].
@@ -106,11 +106,11 @@ module type S = sig
     (** The type of the elements stored in the table. *)
   type t
     (** The type of tables that contain elements of type [data].
-        Note that weak hash tables cannot be marshaled using
+        Note that weak hash sets cannot be marshaled using
         {!Pervasives.output_value} or the functions of the {!Marshal}
         module. *)
   val create : int -> t
-    (** [create n] creates a new empty weak hash table, of initial
+    (** [create n] creates a new empty weak hash set, of initial
         size [n].  The table will grow as needed. *)
   val clear : t -> unit
     (** Remove all elements from the table. *)
@@ -154,4 +154,7 @@ end;;
 (** The output signature of the functor {!Weak.Make}. *)
 
 module Make (H : Hashtbl.HashedType) : S with type data = H.t;;
-(** Functor building an implementation of the weak hash table structure. *)
+(** Functor building an implementation of the weak hash set structure.
+    [H.equal] can't be the physical equality, since only shallow
+    copies of the elements in the set are given to it.
+ *)

testsuite/tests/lib-hashtbl/htbl.ml

@@ -67,20 +67,43 @@ module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct
 
 end
 
-module MS = Map.Make(struct type t = string
-                            let compare (x:t) (y:t) = Pervasives.compare x y
-                     end)
-module MI = Map.Make(struct type t = int
-                            let compare (x:t) (y:t) = Pervasives.compare x y
-                     end)
+module SS = struct
+  type t = string
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SI = struct
+  type t = int
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSP = struct
+  type t = string*string
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSL = struct
+  type t = string list
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
+module SSA = struct
+  type t = string array
+  let compare (x:t) (y:t) = Pervasives.compare x y
+  let equal (x:t) (y:t) = x=y
+  let hash = Hashtbl.hash
+end
 
-module MSP = Map.Make(struct type t = string*string
-                            let compare (x:t) (y:t) = Pervasives.compare x y
-                     end)
+module MS = Map.Make(SS)
+module MI = Map.Make(SI)
+module MSP = Map.Make(SSP)
+module MSL = Map.Make(SSL)
+module MSA = Map.Make(SSA)
 
-module MSL = Map.Make(struct type t = string list
-                            let compare (x:t) (y:t) = Pervasives.compare x y
-                     end)
 
 (* Generic hash wrapped as a functorial hash *)
 
@@ -112,13 +135,16 @@ module HSL = HofM(MSL)
 
 (* Specific functorial hashes *)
 
-module HS2 = Hashtbl.Make(struct type t = string
-                                 let equal (x:t) (y:t) = x=y
-                                 let hash = Hashtbl.hash end)
+module HS2 = Hashtbl.Make(SS)
+module HI2 = Hashtbl.Make(SI)
+
+(* Specific weak functorial hashes *)
+module WS = Ephemeron.K1.Make(SS)
+module WSP1 = Ephemeron.K1.Make(SSP)
+module WSP2 = Ephemeron.K2.Make(SS)(SS)
+module WSL = Ephemeron.K1.Make(SSL)
+module WSA = Ephemeron.Kn.Make(SS)
 
-module HI2 = Hashtbl.Make(struct type t = int
-                                 let equal (x:t) (y:t) = x=y
-                                 let hash = Hashtbl.hash end)
 (* Instantiating the test *)
 
 module TS1 = Test(HS1)(MS)
@@ -127,6 +153,11 @@ module TI1 = Test(HI1)(MI)
 module TI2 = Test(HI2)(MI)
 module TSP = Test(HSP)(MSP)
 module TSL = Test(HSL)(MSL)
+module TWS  = Test(WS)(MS)
+module TWSP1 = Test(WSP1)(MSP)
+module TWSP2 = Test(WSP2)(MSP)
+module TWSL = Test(WSL)(MSL)
+module TWSA = Test(WSA)(MSA)
 
 (* Data set: strings from a file, associated with their line number *)
 
@@ -172,7 +203,7 @@ let pair_data data =
 (* Data set: lists *)
 
 let list_data data =
-  let d = Array.make (Array.length data / 10) ([], 0) in
+  let d = Array.make (Array.length data / 10) ([], "0") in
   let j = ref 0 in
   let rec mklist n =
     if n <= 0 || !j >= Array.length data then [] else begin
@@ -182,7 +213,7 @@ let list_data data =
       hd :: tl
     end in
   for i = 0 to Array.length d - 1 do
-    d.(i) <- (mklist (Random.int 16), i)
+    d.(i) <- (mklist (Random.int 16), string_of_int i)
   done;
   d
 
@@ -202,4 +233,17 @@ let _ =
   printf "-- Pairs of strings\n%!";
   TSP.test (pair_data d);
   printf "-- Lists of strings\n%!";
-  TSL.test (list_data d)
+  TSL.test (list_data d);
+  (* weak *)
+  let d =
+    try file_data "../../LICENSE" with Sys_error _ -> string_data in
+  printf "-- Weak K1 -- Strings, functorial interface\n%!";
+  TWS.test d;
+  printf "-- Weak K1 -- Pairs of strings\n%!";
+  TWSP1.test (pair_data d);
+  printf "-- Weak K2 -- Pairs of strings\n%!";
+  TWSP2.test (pair_data d);
+  printf "-- Weak K1 -- Lists of strings\n%!";
+  TWSL.test (list_data d);
+  printf "-- Weak Kn -- Arrays of strings\n%!";
+  TWSA.test (Array.map (fun (l,i) -> (Array.of_list l,i)) (list_data d))

testsuite/tests/lib-hashtbl/htbl.reference

@@ -22,3 +22,23 @@ Removal: passed
 Insertion: passed
 Insertion: passed
 Removal: passed
+-- Weak K1 -- Strings, functorial interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K1 -- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K2 -- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak K1 -- Lists of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Weak Kn -- Arrays of strings
+Insertion: passed
+Insertion: passed
+Removal: passed

testsuite/tests/misc/ephetest.ml

@@ -0,0 +1,172 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+let debug = false
+
+open Printf
+open Ephemeron
+
+let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL")
+let is_false test s b = is_true test s (not b)
+
+let is_data_value test eph (v:int) =
+  match K1.get_data_copy eph with
+  | Some x ->
+      if !x = v
+      then printf "%s data set: OK\n" test
+      else printf "%s data set: FAIL(bad value %i)\n" test (!x)
+  | None -> printf "%s data set: FAIL\n" test
+
+let is_key_value test eph (v:int) =
+  match K1.get_key_copy eph with
+  | Some x ->
+      if !x = v
+      then printf "%s key set: OK\n" test
+      else printf "%s key set: FAIL(bad value %i)\n" test (!x)
+  | None -> printf "%s key unset: FAIL\n" test
+
+let is_key_unset test eph =
+  is_false test "key unset" (K1.check_key eph)
+
+let is_data_unset test eph =
+  is_false test "data unset" (K1.check_data eph)
+
+let ra = ref (ref 1)
+let rb = ref (ref (ref 2))
+
+(** test: key alive data dangling *)
+let () =
+  let test = "test1" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (!ra);
+  K1.set_data eph (ref 42);
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  Gc.minor ();
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  Gc.full_major ();
+  is_key_value test eph 1;
+  is_data_value test eph 42;
+  ra := ref 12;
+  Gc.full_major ();
+  is_key_unset test eph;
+  is_data_unset test eph
+
+(** test: key dangling data dangling *)
+let () =
+  let test = "test2" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (ref 125);
+  K1.set_data eph (ref 42);
+  is_key_value test eph 125;
+  is_data_value test eph 42;
+  ra := ref 13;
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+
+
+(** test: key dangling data alive *)
+let () =
+  let test = "test3" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  K1.set_key eph (ref 125);
+  K1.set_data eph (!ra);
+  is_key_value test eph 125;
+  is_data_value test eph 13;
+  ra := ref 14;
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+
+(** test: key alive but one away, data dangling *)
+let () =
+  let test = "test4" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref 43);
+  is_key_value test eph 3;
+  is_data_value test eph 43;
+  Gc.minor ();
+  Gc.minor ();
+  is_key_value test eph 3;
+  is_data_value test eph 43
+
+(** test: key dangling but one away, data dangling *)
+let () =
+  let test = "test5" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref 43);
+  is_key_value test eph 3;
+  is_data_value test eph 43;
+  !rb := ref 4;
+  Gc.minor ();
+  Gc.minor ();
+  is_key_unset test eph;
+  is_data_unset test eph
+
+(** test: key accessible from data but all dangling *)
+let () =
+  let test = "test6" in
+  Gc.minor ();
+  Gc.full_major ();
+  let eph : (int ref, int ref ref) K1.t = K1.create () in
+  rb := ref (ref 3);
+  K1.set_key eph (!(!rb));
+  K1.set_data eph (ref (!(!rb)));
+  Gc.minor ();
+  is_key_value test eph 3;
+  !rb := ref 4;
+  Gc.full_major ();
+  is_key_unset test eph;
+  is_data_unset test eph
+
+(** test: ephemeron accessible from data but they are dangling *)
+type t =
+  | No
+  | Ephe of (int ref, t) K1.t
+
+let rc = ref No
+
+let () =
+  let test = "test7" in
+  Gc.minor ();
+  Gc.full_major ();
+  ra := ref 42;
+  let weak : t Weak.t = Weak.create 1 in
+  let eph : (int ref, t) K1.t ref = ref (K1.create ()) in
+  rc := Ephe !eph;
+  Weak.set weak 0 (Some !rc);
+  K1.set_key !eph !ra;
+  K1.set_data !eph !rc;
+  Gc.minor ();
+  is_true test "before" (Weak.check weak 0);
+  eph := K1.create ();
+  rc := No;
+  Gc.full_major ();
+  Gc.full_major ();
+  Gc.full_major ();
+  is_false test "after" (Weak.check weak 0)

testsuite/tests/misc/ephetest.reference

@@ -0,0 +1,29 @@
+test1 key set: OK
+test1 data set: OK
+test1 key set: OK
+test1 data set: OK
+test1 key set: OK
+test1 data set: OK
+test1 key unset: OK
+test1 data unset: OK
+test2 key set: OK
+test2 data set: OK
+test2 key unset: OK
+test2 data unset: OK
+test3 key set: OK
+test3 data set: OK
+test3 key unset: OK
+test3 data unset: OK
+test4 key set: OK
+test4 data set: OK
+test4 key set: OK
+test4 data set: OK
+test5 key set: OK
+test5 data set: OK
+test5 key unset: OK
+test5 data unset: OK
+test6 key set: OK
+test6 key unset: OK
+test6 data unset: OK
+test7 before: OK
+test7 after: OK

testsuite/tests/misc/ephetest2.ml

@@ -0,0 +1,161 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+(***
+   This test evaluate boolean formula composed by conjunction and
+     disjunction using ephemeron:
+   - true == alive, false == garbage collected
+   - and == an n-ephemeron, or == many 1-ephemeron
+
+*)
+
+let nb_test = 4
+let max_level = 10
+ (** probability that a branch is not linked to a previous one *)
+let proba_no_shared = 0.2
+let arity_max = 4
+
+let proba_new = proba_no_shared ** (1./.(float_of_int max_level))
+
+open Format
+open Ephemeron
+
+let is_true test s b = printf "%s %s: %s\n" test s (if b then "OK" else "FAIL")
+let is_false test s b = is_true test s (not b)
+
+type varephe = int ref
+type ephe = (varephe,varephe) Kn.t
+
+type formula =
+  | Constant of bool
+  | And of var array
+  | Or of var array
+
+and var = {
+  form: formula;
+  value: bool;
+  ephe: varephe Weak.t;
+}
+
+let print_short_bool fmt b =
+  if b
+  then pp_print_string fmt "t"
+  else pp_print_string fmt "f"
+
+let rec pp_form fmt = function
+  | Constant b ->
+      fprintf fmt "%b" b
+  | And a      ->
+      fprintf fmt "And[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a
+  | Or a       ->
+      fprintf fmt  "Or[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a
+
+and pp_var fmt v =
+  fprintf fmt "%a%a:%a;@ "
+    print_short_bool v.value
+    print_short_bool (Weak.check v.ephe 0)
+    pp_form v.form
+
+type env = {
+  (** resizeable array for cheap *)
+  vars : (int,var) Hashtbl.t;
+  (** the ephemerons must be alive *)
+  ephes : ephe Stack.t;
+  (** keep alive the true constant *)
+  varephe_true : varephe Stack.t;
+(** keep temporarily alive the false constant *)
+  varephe_false : varephe Stack.t;
+}
+
+let new_env () = {
+  vars = Hashtbl.create 100;
+  ephes = Stack.create ();
+  varephe_true = Stack.create ();
+  varephe_false = Stack.create ();
+}
+
+let evaluate = function
+  | Constant b -> b
+  | And a -> Array.fold_left (fun acc e -> acc && e.value) true  a
+  | Or a  -> Array.fold_left (fun acc e -> acc || e.value) false a
+
+let get_ephe v =
+  match Weak.get v.ephe 0 with
+  | None ->
+      invalid_arg "Error: weak dead but nothing have been released"
+  | Some r -> r
+
+(** create a variable and its definition in the boolean world and
+    ephemerons world *)
+let rec create env rem_level (** remaining level *) =
+  let varephe = ref 1 in
+  let form =
+    if rem_level = 0 then (** Constant *)
+      if Random.bool ()
+      then (Stack.push varephe env.varephe_true ; Constant true )
+      else (Stack.push varephe env.varephe_false; Constant false)
+    else
+      let size = (Random.int (arity_max - 1)) + 2 in
+      let new_link _ =
+        if (Hashtbl.length env.vars) = 0 || Random.float 1. < proba_new
+        then create env (rem_level -1)
+        else Hashtbl.find env.vars (Random.int (Hashtbl.length env.vars))
+      in
+      let args = Array.init size new_link in
+      if Random.bool ()
+      then begin (** Or *)
+        Array.iter (fun v ->
+            let r = get_ephe v in
+            let e = Kn.create 1 in
+            Kn.set_key e 0 r;
+            Kn.set_data e varephe;
+            Stack.push e env.ephes
+          ) args; Or args
+      end
+      else begin (** And *)
+        let e = Kn.create (Array.length args) in
+        for i=0 to Array.length args - 1 do
+          Kn.set_key e i (get_ephe args.(i));
+        done;
+        Kn.set_data e varephe;
+        Stack.push e env.ephes;
+        And args
+      end
+  in
+  let create_weak e =
+    let w = Weak.create 1 in
+    Weak.set w 0 (Some e);
+    w
+  in
+  let v = {form; value = evaluate form;
+           ephe = create_weak varephe;
+          } in
+  Hashtbl.add env.vars (Hashtbl.length env.vars) v;
+  v
+
+
+let check_var v = v.value = Weak.check v.ephe 0
+
+let run test init =
+  Random.init init;
+  let env = new_env () in
+  let _top = create env max_level in
+  (** release false ref *)
+  Stack.clear env.varephe_false;
+  Gc.full_major ();
+  let res = Hashtbl.fold (fun _ v acc -> acc && check_var v) env.vars true in
+  is_true test "check" res
+
+let () =
+  for i = 0 to nb_test do
+    run ("test"^(string_of_int i)) i;
+  done

testsuite/tests/misc/ephetest2.reference

@@ -0,0 +1,5 @@
+test0 check: OK
+test1 check: OK
+test2 check: OK
+test3 check: OK
+test4 check: OK

testsuite/tests/misc/ephetest3.ml

@@ -0,0 +1,133 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+(** This test weak table by application to the memoization of collatz
+    (also known as syracuse) algorithm suite computation *)
+
+(** We use Int64 because they are boxed *)
+
+(** number of element of the suite to compute (more are computed) *)
+let n = 1000
+
+let two = Int64.of_int 2
+let three = Int64.of_int 3
+
+let collatz x =
+  if Int64.equal (Int64.rem x two) Int64.zero
+  then Int64.div x two
+  else Int64.succ (Int64.mul x three)
+
+module S = struct
+  include Int64
+  let hash (x:t) = Hashtbl.hash x
+end
+
+let pp = Int64.to_string
+
+module HW = Ephemeron.K1.Make(S)
+module SW = Weak.Make(S)
+
+
+let sw = SW.create n
+let hashcons x = SW.merge sw x
+
+let hw = HW.create n
+
+let rec fill_hw x =
+  if not (HW.mem hw x) then begin
+    let y = hashcons (collatz x) in
+    HW.add hw x y;
+    fill_hw y
+  end
+
+exception InvariantBroken of string
+let test b = Printf.ksprintf (fun s -> if not b then raise (InvariantBroken s))
+
+let rec check_hw_aux cache x =
+  (** We use int so that the cache doesn't make x alive *)
+  if not (Hashtbl.mem cache (Int64.to_int x)) then begin
+    test (HW.mem hw x) "missing %s%!" (pp x);
+    let y =
+      try HW.find hw x
+      with Not_found ->
+        test (not (HW.mem hw x)) "key in the table but data missing %s!%!"
+          (pp x);
+        test false "missing %s%!" (pp x);
+        assert false
+    in
+    let y' = collatz x in
+    test (Int64.equal y y') "bad result for %s: %s instead of %s%!"
+      (pp x) (pp y) (pp y');
+    let y'' = hashcons y' in
+    test (y == y'') "bad result for %s: not physically equal%!" (pp x);
+    Hashtbl.add cache (Int64.to_int x) ();
+    check_hw_aux cache y
+  end
+
+let check_hw iter =
+  let cache = Hashtbl.create n in
+  iter (fun x -> check_hw_aux cache x)
+
+(** tests *)
+
+let run ~next ~check =
+  HW.reset hw;
+  SW.clear sw;
+  (* Gc.full_major (); *)
+  for x=0 to n do
+    let x' = next x in
+    fill_hw x';
+    check x;
+  done;
+  Gc.full_major ();
+  HW.clean hw;
+  Printf.printf "length: %i\n%!" (HW.length hw)
+
+let print_stats () =
+  let print_stats name stats =
+    Printf.printf "%s (%3i,%3i,%3i): %!"
+      name
+      stats.Hashtbl.num_bindings
+      stats.Hashtbl.num_buckets
+      stats.Hashtbl.max_bucket_length;
+    Array.iteri (fun i n -> Printf.printf "%i: %i, %!" i n)
+      stats.Hashtbl.bucket_histogram;
+    Printf.printf "\n%!";
+  in
+  print_stats "stats      : " (HW.stats hw);
+  print_stats "stats_alive: " (HW.stats_alive hw)
+
+let test_keep_last d d' =
+  Printf.printf "## Keep last %i alive, check each %i ##\n%!" (n/d) (n/d');
+  let keep_alive = Array.create (n/d) Int64.zero in
+  let next x =
+    let x' = hashcons (Int64.of_int x) in
+    Array.set keep_alive (x mod (n/d)) x';
+    x'
+  in
+  let check x =
+    if x mod (n/d') = 0 || x = n then begin
+      check_hw (fun f -> Array.iter f keep_alive)
+    end
+  in
+  run ~next ~check;
+  (** keep the array alive until the end *)
+  let s =
+    Array.fold_left (fun acc x -> Int64.add x acc) Int64.zero keep_alive in
+  Printf.printf "sum of kept alive %s\n%!" (pp s);
+  print_stats ();
+  Printf.printf "\n%!"
+
+let () =
+  test_keep_last 1 10;
+  test_keep_last 50 10;
+  test_keep_last 100 2

testsuite/tests/misc/ephetest3.reference

@@ -0,0 +1,18 @@
+## Keep last 1000 alive, check each 100 ##
+length: 2228
+sum of kept alive 500500
+stats      :  (2228,2048,  6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, 
+stats_alive:  (2228,2048,  6): 0: 658, 1: 791, 2: 413, 3: 143, 4: 34, 5: 8, 6: 1, 
+
+## Keep last 20 alive, check each 100 ##
+length: 458
+sum of kept alive 19810
+stats      :  (458,2048,  3): 0: 1636, 1: 370, 2: 38, 3: 4, 
+stats_alive:  (458,2048,  3): 0: 1636, 1: 370, 2: 38, 3: 4, 
+
+## Keep last 10 alive, check each 500 ##
+length: 339
+sum of kept alive 9955
+stats      :  (339,2048,  3): 0: 1740, 1: 279, 2: 27, 3: 2, 
+stats_alive:  (339,2048,  3): 0: 1740, 1: 279, 2: 27, 3: 2, 
+

testsuite/tests/misc/weaklifetime2.ml

@@ -0,0 +1,69 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*                 Damien Doligez, Jane Street Group, LLC                *)
+(*                                                                       *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+let n = 500
+let loop = 2
+
+let alive = ref (Array.init n (fun _ -> Array.make 10 0))
+
+let create_weaks () =
+  Array.init n (fun i ->
+      let w = Weak.create 1 in
+      Weak.set w 0 (Some (!alive.(i)));
+      w
+    )
+
+(** We are trying to keep the weak pointer of weak2 set when the
+    weak pointer of weak1 and weak3 are wrongly unset.
+    [weak1], [weak2] and [weak3] are identical.
+ *)
+
+let weak1 = create_weaks ()
+let weak2 = create_weaks ()
+let weak3 = create_weaks ()
+
+(** put the weak pointers in the major heap *)
+let () =
+  let dummy = ref [||] in
+  for l=0 to 10 do
+    dummy := Array.make 300 0
+  done
+
+let gccount () = (Gc.quick_stat ()).Gc.major_collections;;
+
+let () =
+  for _l=1 to loop do
+    let bad = ref 0 in
+    for i=0 to n-1 do
+      (** make *this* weak key alive *)
+      for _j=0 to n*10 do
+        ignore (Weak.get weak2.(i) 0);
+      done;
+      (** Check that if it is alive in weak2 it is alive in weak1 *)
+      if Weak.check weak2.(i) 0 &&
+         not (Weak.check weak1.(i) 0) &&
+         Weak.check weak2.(i) 0
+      then incr bad;
+      (** Check that if it is alive in weak2 it is alive in weak3
+          This case was failing before the addition of the clean phase in the gc
+      *)
+      if Weak.check weak2.(i) 0 &&
+         not (Weak.check weak3.(i) 0) &&
+         Weak.check weak2.(i) 0
+      then incr bad;
+      !alive.(i) <- Array.make 10 0;
+    done;
+    (* Printf.printf "bad: %i\  gccount:%i\n%!" !bad (gccount ()); *)
+    if !bad > 0
+    then Printf.printf "failing\n%!"
+    else Printf.printf "success\n%!"
+  done

testsuite/tests/misc/weaklifetime2.reference

@@ -0,0 +1,2 @@
+success
+success