[GC] add full-featured ephemerons in an inefficient way

     - use the generic abstract tag like weak pointers
     - a weak pointer is implemented using an ephemeron (one additionnal word)
     - add for every full GC a complexity of O((n+m)*(m+1))
       with m the number of pure ephemerons,
            n the number of ephemerons used as weak pointers
     - multiple keys, modifiable keys

11 files changed, 505 insertions, 133 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 21f16c8c56..c893a8f7e4 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 92571f5e71..6432b6b2aa 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 63cfe7becd..080b27d4db 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/caml/major_gc.h b/byterun/caml/major_gc.h
index b2e3bd166f..ff83a90c58 100644
--- a/byterun/caml/major_gc.h
+++ b/byterun/caml/major_gc.h
@@ -52,8 +52,8 @@ extern uintnat caml_fl_wsz_at_phase_change;
 #define Subphase_mark_final 12 /* after marking finalized value */
 
 /* Subphase of clean */
-#define Subphase_clean_weak  20 /* clean weak arrays */
-#define Subphase_unlink_weak 21 /* remove dead weak arrays */
+#define Subphase_clean_ephe  20 /* clean ephemeron */
+#define Subphase_unlink_ephe 21 /* remove dead ephemeron */
 
 CAMLextern char *caml_heap_start;
 extern uintnat total_heap_size;
diff --git a/byterun/caml/minor_gc.h b/byterun/caml/minor_gc.h
index a494db2aef..668cb2faa3 100644
--- a/byterun/caml/minor_gc.h
+++ b/byterun/caml/minor_gc.h
@@ -36,8 +36,15 @@ extern int caml_in_minor_collection;
 }
 
 struct caml_ref_table CAML_TABLE_STRUCT(value *);
-CAMLextern struct caml_ref_table caml_ref_table,  caml_weak_ref_table,
-                                 caml_finalize_table;
+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  */
+};
+
+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);
@@ -45,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);
 
@@ -64,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 */
diff --git a/byterun/caml/weak.h b/byterun/caml/weak.h
index 0cf4b8b2b4..ec599dcd58 100644
--- a/byterun/caml/weak.h
+++ b/byterun/caml/weak.h
@@ -18,7 +18,9 @@
 
 #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;
+
+void caml_ephe_clean (value v);
 
 #endif /* CAML_WEAK_H */
diff --git a/byterun/compact.c b/byterun/compact.c
index 07ffabb31e..b317149f71 100644
--- a/byterun/compact.c
+++ b/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");
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index f90e2985d4..ed2aed1c2f 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -51,6 +51,9 @@ static value *gray_vals_cur, *gray_vals_end;
 static asize_t gray_vals_size;
 static int heap_is_pure;   /* The heap is pure if the only gray objects
                               below [markhp] are also in [gray_vals]. */
+static int ephe_list_pure;   /* The list of ephemerons is pure if
+                                since the start of its iteration
+                                no value have been darken. */
 uintnat caml_allocated_words;
 uintnat caml_dependent_size, caml_dependent_allocated;
 double caml_extra_heap_resources;
@@ -61,8 +64,8 @@ extern char *caml_fl_merge;  /* Defined in freelist.c. */
 static char *markhp, *chunk, *limit;
 
 int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final,
-                                       clean_weak,unlink_weak} */
-static value *weak_prev;
+                                       clean_ephe,unlink_ephe} */
+static value *ephe_prev;
 
 int caml_major_window = 1;
 double caml_major_ring[Max_major_window] = { 0. };
@@ -128,6 +131,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;
@@ -148,6 +152,8 @@ static void start_cycle (void)
   caml_gc_phase = Phase_mark;
   caml_gc_subphase = Subphase_mark_roots;
   markhp = NULL;
+  ephe_list_pure = 1;
+  ephe_prev = &caml_ephe_list_head;
 #ifdef DEBUG
   ++ major_gc_counter;
   caml_heap_check ();
@@ -168,9 +174,9 @@ static mlsize_t current_index = 0;
 #define INSTR(x) /**/
 #endif
 
-//auxillary function of mark_slice
+/* auxillary function of mark_slice */
 static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
-                                       int *slice_pointers)
+                                       int in_ephemeron, int *slice_pointers)
 {
   value child;
   header_t chd;
@@ -193,14 +199,21 @@ static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
     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)){
+      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))
-          add_to_ref_table (&caml_ref_table, &Field (v, i));
+        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) {
@@ -212,6 +225,7 @@ static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
     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) {
@@ -225,6 +239,59 @@ static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
   return gray_vals_ptr;
 }
 
+static value* mark_ephe_aux (value *gray_vals_ptr, value v, intnat *work,
+                             int *slice_pointers)
+{
+  value child;
+  header_t hd;
+  mlsize_t size, i;
+
+  hd = Hd_val(v);
+  Assert(Tag_val (v) == Abstract_tag);
+  child = Field(v,1); /* child = data */
+  if ( child != caml_ephe_none &&
+       Is_block (child) && Is_in_heap (child) && Is_white_val (child)){
+
+    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 = 2; alive_data && i < size; i++){
+      child = Field (v, i); /* child = one key */
+    ephemeron_again:
+      if (Tag_val (child) == Forward_tag){
+        value f = Forward_val (child);
+        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) = child = f;
+          goto ephemeron_again;
+        }
+      }
+      if (child != caml_ephe_none &&
+          Is_block (child) && Is_in_heap (child) && Is_white_val (child)){
+        alive_data = 0;
+      }
+    }
+
+    if (alive_data){
+      gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,1,/*in_ephemeron=*/1,
+                                        slice_pointers);
+    }
+    *work -= Whsize_wosize(size);
+  } else {  /* a simily weak pointer or an already alive data */
+    *work -= 1;
+  }
+
+  return gray_vals_ptr;
+}
+
 static void mark_slice (intnat work)
 {
   value *gray_vals_ptr;  /* Local copy of [gray_vals_cur] */
@@ -260,7 +327,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++){
-          gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i,&slice_pointers);
+          gray_vals_ptr = mark_slice_darken(gray_vals_ptr,v,i,
+                                            /*in_ephemeron=*/ 0,
+                                            &slice_pointers);
         }
         if (end < size){
           work = 0;
@@ -303,6 +372,15 @@ static void mark_slice (intnat work)
       chunk = caml_heap_start;
       markhp = chunk;
       limit = chunk + Chunk_size (chunk);
+    } else if (*ephe_prev != (value) NULL) {
+      /* Continue to scan the list of ephe */
+      v = *ephe_prev;
+      gray_vals_ptr=mark_ephe_aux(gray_vals_ptr,v,&work,&slice_pointers);
+      ephe_prev = &Field(v,0);
+    } else if (!ephe_list_pure){
+      /* We must scan again the list because some value have been darken */
+      ephe_list_pure = 1;
+      ephe_prev = &caml_ephe_list_head;
     }else{
       switch (caml_gc_subphase){
       case Subphase_mark_roots: {
@@ -325,14 +403,15 @@ static void mark_slice (intnat work)
             CAMLassert (start == 0);
           }
           /* Complete the marking */
+          ephe_prev = &caml_ephe_list_head;
           caml_gc_subphase = Subphase_mark_final;
       }
         break;
       case Subphase_mark_final: {
         /* Initialise the clean phase. */
         caml_gc_phase = Phase_clean;
-        caml_gc_subphase = Subphase_clean_weak;
-        weak_prev = &caml_weak_list_head;
+        caml_gc_subphase = Subphase_clean_ephe;
+        ephe_prev = &caml_ephe_list_head;
         work = 0;
       }
         break;
@@ -349,65 +428,37 @@ static void mark_slice (intnat work)
 
 static void clean_slice (intnat work)
 {
-  value v, child;
-  header_t hd;
-  mlsize_t size, i;
+  value v;
 
   caml_gc_message (0x40, "Cleaning %ld words\n", work);
   caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
   while (work > 0){
     switch (caml_gc_subphase){
-    case Subphase_clean_weak: {
-      v = *weak_prev;
+    case Subphase_clean_ephe: {
+      v = *ephe_prev;
       if (v != (value) NULL){
-        hd = Hd_val (v);
-        size = Wosize_hd (hd);
-        for (i = 1; i < size; i++){
-          child = Field (v, i);
-          weak_again:
-            if (child != caml_weak_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_ref_table(&caml_weak_ref_table, &Field (v, i));
-                    goto weak_again;
-                  }
-                }
-              }
-          if (Is_white_val (child) && !Is_young (child)){
-            Field (v, i) = caml_weak_none;
-            }
-          }
-        }
-        weak_prev = &Field (v, 0);
-          work -= Whsize_hd (hd);
-        }else{
-        /* Subphase_clean_weak is done.
-           Start removing dead weak arrays. */
-        caml_gc_subphase = Subphase_unlink_weak;
-        weak_prev = &caml_weak_list_head;
-        }
+        caml_ephe_clean(v);
+        ephe_prev = &Field (v, 0);
+        work -= Whsize_val (v);
+      }else{
+        /* Subphase_clean_ephe is done.
+           Start removing dead ephe arrays. */
+        caml_gc_subphase = Subphase_unlink_ephe;
+        ephe_prev = &caml_ephe_list_head;
       }
-        break;
-    case Subphase_unlink_weak: {
-      v = *weak_prev;
+    }
+      break;
+    case Subphase_unlink_ephe: {
+      v = *ephe_prev;
       if (v != (value) NULL){
-        hd = Hd_val (v);
-          if (Color_hd (hd) == Caml_white){
-            /* The whole array is dead, remove it from the list. */
-          *weak_prev = Field (v, 0);
-          }else{
-          weak_prev = &Field (v, 0);
-          }
-          work -= 1;
+        if (Color_val (v) == Caml_white){
+          /* The whole array is dead, remove it from the list. */
+          *ephe_prev = Field (v, 0);
         }else{
+          ephe_prev = &Field (v, 0);
+        }
+        work -= 1;
+      }else{
         /* Phase_clean is done. */
         /* Initialise the sweep phase. */
         caml_gc_sweep_hp = caml_heap_start;
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index b147e5e460..80f96878c7 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -62,10 +62,12 @@ 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 */
@@ -91,6 +93,13 @@ 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;
@@ -174,7 +183,7 @@ void caml_set_minor_heap_size (asize_t bsz)
   caml_minor_heap_wsz = Wsize_bsize (bsz);
 
   reset_table ((struct generic_table *) &caml_ref_table);
-  reset_table ((struct generic_table *) &caml_weak_ref_table);
+  reset_table ((struct generic_table *) &caml_ephe_ref_table);
 }
 
 static value oldify_todo_list = 0;
@@ -273,6 +282,7 @@ void caml_oldify_mopup (void)
 {
   value v, new_v, f;
   mlsize_t i;
+  struct caml_ephe_ref_elt *re;
 
   while (oldify_todo_list != 0){
     v = oldify_todo_list;                /* Get the head. */
@@ -293,6 +303,37 @@ 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,re->offset);
+      if (Is_block (*data) && Is_young (*data)){
+        if (Hd_val (*data) == 0){ /* Value copied to major heap */
+          *data = Field (*data, 0);
+        } else {
+          /* Test if the ephemeron is alive */
+          int alive_data = 1;
+          value child;
+          for (i = 2; alive_data && 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 */
+              alive_data = 0;
+            }
+          }
+          if (alive_data) caml_oldify_one(*data,data);
+        }
+      }
+    }
+  }
+
+  if (oldify_todo_list != 0) caml_oldify_mopup ();
+
 }
 
 /* Make sure the minor heap is empty by performing a minor collection
@@ -302,6 +343,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) ();
@@ -317,15 +359,20 @@ 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 (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 */
+          *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 */
@@ -339,7 +386,7 @@ void caml_empty_minor_heap (void)
                      / caml_minor_heap_wsz;
     caml_young_ptr = caml_young_alloc_end;
     clear_table ((struct generic_table *) &caml_ref_table);
-    clear_table ((struct generic_table *) &caml_weak_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;
@@ -479,3 +526,13 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
      "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");
+}
diff --git a/byterun/weak.c b/byterun/weak.c
index 62b62ef88a..89ec922423 100644
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Operations on weak arrays */
+/* Operations on weak arrays and ephemerons (named ephe here)*/
 
 #include <string.h>
 
@@ -21,29 +21,147 @@
 #include "caml/memory.h"
 #include "caml/mlvalues.h"
 
-value caml_weak_list_head = 0;
+value caml_ephe_list_head = 0;
 
-static value weak_dummy = 0;
-value caml_weak_none = (value) &weak_dummy;
+static value ephe_dummy = 0;
+value caml_ephe_none = (value) &ephe_dummy;
+
+/** 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
+ */
 
 /* [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, 0) = 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.
+
+ */
+
+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)) );
+      }
+  }
+}
+
+
 #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 (Is_block (elt) && Is_in_heap (elt) && Is_white_val(elt)){
+      caml_ephe_clean(ar);
+    };
+  };
+}
+
+/* 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 int is_ephe_key_none(value ar, value elt){
+  if (elt == caml_ephe_none){
+    return 1;
+  }else if (caml_gc_phase == Phase_clean &&
+            Is_block (elt) && Is_in_heap (elt) && Is_white_val(elt)){
+    caml_ephe_clean(ar);
+    return 1;
+  } else {
+    return 0;
+  }
+}
+
+
 static void do_set (value ar, mlsize_t offset, value v)
 {
   if (Is_block (v) && Is_young (v)){
@@ -51,55 +169,116 @@ 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, 1) = caml_ephe_none;
+  return Val_unit;
+}
+
+
 #define Setup_for_gc
 #define Restore_after_gc
 
-int caml_is_weak_none(value ar, mlsize_t offset, value elt){
-  if (elt == caml_weak_none){
-    return 1;
-  }else if (caml_gc_phase == Phase_clean &&
-            Is_block (elt) && Is_in_heap (elt) && Is_white_val(elt)){
-    /** Must be cleaned during this phase */
-    Field (ar, offset) = caml_weak_none; /* just optimisation */
-    return 1;
+CAMLprim value caml_ephe_get_key (value ar, value n)
+{
+  CAMLparam2 (ar, n);
+  mlsize_t offset = Long_val (n) + 2;
+  CAMLlocal2 (res, elt);
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 2 || offset >= Wosize_val (ar)){
+    caml_invalid_argument ("Weak.get_key");
   }
-  return 0;
+  elt = Field (ar, offset);
+  if (is_ephe_key_none(ar, elt)){
+    res = None_val;
+  }else{
+    if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (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)
+CAMLprim value caml_weak_get (value ar, value n){
+  return caml_ephe_get_key(ar, n);
+}
+
+CAMLprim value caml_ephe_get_data (value ar)
 {
-  CAMLparam2 (ar, n);
-  mlsize_t offset = Long_val (n) + 1;
+  CAMLparam1 (ar);
+  mlsize_t offset = 1;
   CAMLlocal2 (res, elt);
                                                    Assert (Is_in_heap (ar));
-  if (offset < 1 || offset >= Wosize_val (ar)){
-    caml_invalid_argument ("Weak.get");
-  }
   elt = Field (ar, offset);
-  if (caml_is_weak_none(ar, offset, elt)){
+  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 && Is_block (elt) && Is_in_heap (elt)){
@@ -114,24 +293,24 @@ 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");
   }
 
   v = Field (ar, offset);
-  if (caml_is_weak_none(ar, offset, v)) CAMLreturn (None_val);
+  if (is_ephe_key_none(ar, v)) 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_is_weak_none(ar, offset, v)) CAMLreturn (None_val);
+    if (is_ephe_key_none(ar, v)) CAMLreturn (None_val);
     if (Tag_val (v) < No_scan_tag){
       mlsize_t i;
       for (i = 0; i < Wosize_val (v); i++){
@@ -153,21 +332,74 @@ CAMLprim value caml_weak_get_copy (value ar, value n)
   CAMLreturn (res);
 }
 
-CAMLprim value caml_weak_check (value ar, value n)
+CAMLprim value caml_weak_get_copy (value ar, value n){
+  return caml_ephe_get_key_copy(ar,n);
+}
+
+CAMLprim value caml_ephe_get_data_copy (value ar)
 {
-  mlsize_t offset = Long_val (n) + 1;
+  CAMLparam1 (ar);
+  mlsize_t offset = 1;
+  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");
+
+  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 && Is_block (f) && Is_in_heap (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 (!caml_is_weak_none(ar, offset, Field (ar, offset)));
+  return Val_bool (!is_ephe_key_none(ar, Field (ar, offset)));
 }
 
-CAMLprim value caml_weak_blit (value ars, value ofs,
+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, 1) != 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));
@@ -178,15 +410,7 @@ 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_clean){
-    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);
   if (offset_d < offset_s){
     for (i = 0; i < length; i++){
       do_set (ard, offset_d + i, Field (ars, offset_s + i));
@@ -198,3 +422,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, 1, Field (ars, 1));
+  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);
+}
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index 71385c9b77..79abf7fff2 100644
--- a/stdlib/weak.ml
+++ b/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";;