Make Ephemeron compatible with infix pointers.

Changes

@@ -90,6 +90,10 @@ Working version
   compaction algorithm and remove its dependence on the page table
   (Damien Doligez, review by Jacques-Henri Jourdan and Xavier Leroy)
 
+- #9742: Ephemerons are now compatible with infix pointers occuring
+   when using mutually recursive functions.
+   (Jacques-Henri Jourdan, review François Bobot)
+
 ### Code generation and optimizations:
 
 - #9551: ocamlc no longer loads DLLs at link time to check that

runtime/caml/weak.h

@@ -191,6 +191,7 @@ Caml_inline void caml_ephe_clean_partial (value v,
           }
         }
       }
+      if (Tag_val (child) == Infix_tag) child -= Infix_offset_val (child);
       if (Is_white_val (child) && !Is_young (child)){
         release_data = 1;
         Field (v, i) = caml_ephe_none;

runtime/minor_gc.c

@@ -284,9 +284,9 @@ Caml_inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){
   for (i = CAML_EPHE_FIRST_KEY; 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;
+       && Is_block (child) && Is_young (child)) {
+      if(Tag_val(child) == Infix_tag) child -= Infix_offset_val(child);
+      if(Hd_val (child) != 0) return 0; /* Value not copied to major heap */
     }
   }
   return 1;
@@ -301,7 +301,10 @@ void caml_oldify_mopup (void)
   value v, new_v, f;
   mlsize_t i;
   struct caml_ephe_ref_elt *re;
-  int redo = 0;
+  int redo;
+
+  again:
+  redo = 0;
 
   while (oldify_todo_list != 0){
     v = oldify_todo_list;                /* Get the head. */
@@ -329,10 +332,12 @@ void caml_oldify_mopup (void)
        re < Caml_state->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);
+      value *data = &Field(re->ephe,1), v = *data;
+      if (v != caml_ephe_none && Is_block (v) && Is_young (v)){
+        mlsize_t offs = Tag_val(v) == Infix_tag ? Infix_offset_val(v) : 0;
+        v -= offs;
+        if (Hd_val (v) == 0){ /* Value copied to major heap */
+          *data = Field (v, 0) + offs;
         } else {
           if (ephe_check_alive_data(re)){
             caml_oldify_one(*data,data);
@@ -343,7 +348,7 @@ void caml_oldify_mopup (void)
     }
   }
 
-  if (redo) caml_oldify_mopup ();
+  if (redo) goto again;
 }
 
 /* Make sure the minor heap is empty by performing a minor collection
@@ -379,10 +384,12 @@ void caml_empty_minor_heap (void)
          re < Caml_state->ephe_ref_table->ptr; re++){
       if(re->offset < Wosize_val(re->ephe)){
         /* If it is not the case, the ephemeron has been truncated */
-        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);
+        value *key = &Field(re->ephe,re->offset), v = *key;
+        if (v != caml_ephe_none && Is_block (v) && Is_young (v)){
+          mlsize_t offs = Tag_val (v) == Infix_tag ? Infix_offset_val (v) : 0;
+          v -= offs;
+          if (Hd_val (v) == 0){ /* Value copied to major heap */
+            *key = Field (v, 0) + offs;
           }else{ /* Value not copied so it's dead */
             CAMLassert(!ephe_check_alive_data(re));
             *key = caml_ephe_none;

runtime/weak.c

@@ -46,12 +46,18 @@ value caml_ephe_none = (value) &ephe_dummy;
     CAMLassert (offset < Wosize_val (eph) - CAML_EPHE_FIRST_KEY);       \
 }while(0)
 
-#define CAMLassert_not_dead_value(v) do{        \
-    CAMLassert ( caml_gc_phase != Phase_clean   \
-                 || !Is_block(v)                \
-                 || !Is_in_heap (v)             \
-                 || !Is_white_val(v) );         \
+#ifdef DEBUG
+#define CAMLassert_not_dead_value(v) do{                        \
+    if (caml_gc_phase == Phase_clean                            \
+        && Is_block(v)                                          \
+        && Is_in_heap (v)) {                                    \
+      if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v);  \
+      CAMLassert ( !Is_white_val(v) );                          \
+    }                                                           \
 }while(0)
+#else
+#define CAMLassert_not_dead_value(v)
+#endif
 
 CAMLexport mlsize_t caml_ephemeron_num_keys(value eph)
 {
@@ -66,10 +72,12 @@ Caml_inline int Is_Dead_during_clean(value x)
 {
   CAMLassert (x != caml_ephe_none);
   CAMLassert (caml_gc_phase == Phase_clean);
+  if (!Is_block(x)) return 0;
+  if (Tag_val(x) == Infix_tag) x -= Infix_offset_val(x);
 #ifdef NO_NAKED_POINTERS
-  return Is_block (x) && !Is_young (x) && Is_white_val(x);
+  return Is_white_val(x) && !Is_young (x);
 #else
-  return Is_block (x) && Is_in_heap (x) && Is_white_val(x);
+  return Is_white_val(x) && Is_in_heap (x);
 #endif
 }
 /** The minor heap doesn't have to be marked, outside they should
@@ -369,7 +377,7 @@ Caml_inline void copy_value(value src, value dst)
 CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset,
                                            value *key)
 {
-  mlsize_t loop = 0;
+  mlsize_t loop = 0, infix_offs;
   CAMLparam1(ar);
   value elt = Val_unit, v; /* Caution: they are NOT local roots. */
   CAMLassert_valid_offset(ar, offset);
@@ -387,6 +395,8 @@ CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset,
       *key = v;
       CAMLreturn(1);
     }
+    infix_offs = Tag_val(v) == Infix_tag ? Infix_offset_val(v) : 0;
+    v -= infix_offs;
     if (elt != Val_unit &&
         Wosize_val(v) == Wosize_val(elt) && Tag_val(v) == Tag_val(elt)) {
       /* The allocation may trigger a finaliser that change the tag
@@ -396,7 +406,7 @@ CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset,
        */
       CAMLassert_not_dead_value(v);
       copy_value(v, elt);
-      *key = elt;
+      *key = elt + infix_offs;
       CAMLreturn(1);
     }
 
@@ -429,7 +439,7 @@ CAMLprim value caml_weak_get_copy (value ar, value n)
 
 CAMLexport int caml_ephemeron_get_data_copy (value ar, value *data)
 {
-  mlsize_t loop = 0;
+  mlsize_t loop = 0, infix_offs;
   CAMLparam1 (ar);
   value elt = Val_unit, v; /* Caution: they are NOT local roots. */
   CAMLassert_valid_ephemeron(ar);
@@ -446,12 +456,14 @@ CAMLexport int caml_ephemeron_get_data_copy (value ar, value *data)
       *data = v;
       CAMLreturn(1);
     }
+    infix_offs = Tag_val(v) == Infix_tag ? Infix_offset_val(v) : 0;
+    v -= infix_offs;
     if (elt != Val_unit &&
         Wosize_val(v) == Wosize_val(elt) && Tag_val(v) == Tag_val(elt)) {
       /** cf caml_ephemeron_get_key_copy */
       CAMLassert_not_dead_value(v);
       copy_value(v, elt);
-      *data = elt;
+      *data = elt + infix_offs;
       CAMLreturn(1);
     }
 

testsuite/tests/misc/ephe_infix.ml

@@ -0,0 +1,26 @@
+(* TEST *)
+
+(* Testing handling of infix_tag by ephemeron *)
+
+let infix n = let rec f () = n and g () = f () in g
+
+(* Issue #9485 *)
+let () =
+  let w = Weak.create 1 in
+  Weak.set w 0 (Some (infix 12));
+  match Weak.get_copy w 0 with Some h -> ignore (h ()) | _ -> ()
+
+(* Issue #7810 *)
+let ephe x =
+  let open Ephemeron.K1 in
+  let e = create () in
+  set_key e x;
+  set_data e 42;
+  Gc.full_major ();
+  (x, get_data e)
+
+let () =
+  assert (ephe (ref 1000) = (ref 1000, Some 42));
+  match ephe (infix 12) with
+  | (h, Some 42) -> ()
+  | _ -> assert false