Functions from weak are breaking all marking invariants on ephemerons

Changes

@@ -7,6 +7,10 @@ Working version
 
 ### Runtime system:
 
+* #9391, #9424: Fix failed assertion in runtime due to ephemerons *set_* and
+  *blit_* function during Mark phase
+  (François Bobot, reported by Stephen Dolan, reviewed by Damien Doligez)
+
 ### Code generation and optimizations:
 
 ### Standard library:

runtime/caml/major_gc.h

@@ -43,6 +43,7 @@ extern uintnat caml_allocated_words;
 extern double caml_extra_heap_resources;
 extern uintnat caml_dependent_size, caml_dependent_allocated;
 extern uintnat caml_fl_wsz_at_phase_change;
+extern int caml_ephe_list_pure;
 
 #define Phase_mark 0
 #define Phase_clean 1

runtime/major_gc.c

@@ -89,14 +89,16 @@ int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final} */
     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.
+      - An ephemeron in (1) have a data alive (grey/black if in the heap)
+        or none (nb: new ephemerons are added in this part by weak.c)
+      - An ephemeron in (2):
+         - is in any state if caml_ephe_list_pure is false
+         - otherwise has at least a white key or is white or its data is
+           black or none.
+           The third case can happen only using a set_* of weak.c
       - 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.
+    At the end of mark phase, (3) is empty and caml_ephe_list_pure is true.
     The ephemeron in (1) and (2) will be cleaned (white keys and data
     replaced by none or the ephemeron is removed from the list if it is white)
     in clean phase.
@@ -112,7 +114,7 @@ int caml_gc_subphase;     /* Subphase_{mark_roots,mark_main,mark_final} */
     - the ephemerons in (3) should be cleaned or removed if white.
 
  */
-static int ephe_list_pure;
+int caml_ephe_list_pure;
 /** The ephemerons is pure if since the start of its iteration
     no value have been darkened. */
 static value *ephes_checked_if_pure;
@@ -303,7 +305,7 @@ void caml_darken (value v, value *p)
 #endif
     CAMLassert (!Is_blue_hd (h));
     if (Is_white_hd (h)){
-      ephe_list_pure = 0;
+      caml_ephe_list_pure = 0;
       Hd_val (v) = Blackhd_hd (h);
       marked_words += Whsize_hd (h);
       if (t < No_scan_tag){
@@ -387,7 +389,7 @@ static void start_cycle (void)
   caml_gc_phase = Phase_mark;
   heap_wsz_at_cycle_start = Caml_state->stat_heap_wsz;
   caml_gc_subphase = Subphase_mark_roots;
-  ephe_list_pure = 1;
+  caml_ephe_list_pure = 1;
   ephes_checked_if_pure = &caml_ephe_list_head;
   ephes_to_check = &caml_ephe_list_head;
 #ifdef DEBUG
@@ -458,7 +460,7 @@ Caml_inline void mark_slice_darken(struct mark_stack* stk, value v, mlsize_t i,
     CAMLassert (Is_in_heap (child) || Is_black_hd (chd));
 #endif
     if (Is_white_hd (chd)){
-      ephe_list_pure = 0;
+      caml_ephe_list_pure = 0;
       Hd_val (child) = Blackhd_hd (chd);
       if( Tag_hd(chd) < No_scan_tag ) {
         mark_stack_push(stk, child, 0, work);
@@ -635,9 +637,9 @@ static void mark_slice (intnat work)
     } else if (*ephes_to_check != (value) NULL) {
       /* Continue to scan the list of ephe */
       mark_ephe_aux(stk,&work,&slice_pointers);
-    } else if (!ephe_list_pure){
+    } else if (!caml_ephe_list_pure){
       /* We must scan again the list because some value have been darken */
-      ephe_list_pure = 1;
+      caml_ephe_list_pure = 1;
       ephes_to_check = ephes_checked_if_pure;
     }else{
       switch (caml_gc_subphase){

runtime/weak.c

@@ -66,13 +66,10 @@ CAMLexport mlsize_t caml_ephemeron_num_keys(value eph)
   return Wosize_val (eph) - CAML_EPHE_FIRST_KEY;
 }
 
-/** The minor heap is considered alive. */
-
-/** Outside minor and major heap, x must be black. */
-Caml_inline int Is_Dead_during_clean(value x)
-{
+/* The minor heap is considered alive. Outside minor and major heap it is
+   considered alive (out of reach of the GC). */
+Caml_inline int Test_if_its_white(value x){
   CAMLassert (x != caml_ephe_none);
-  CAMLassert (caml_gc_phase == Phase_clean);
 #ifdef NO_NAKED_POINTERS
   if (!Is_block(x) || Is_young (x)) return 0;
 #else
@@ -81,8 +78,24 @@ Caml_inline int Is_Dead_during_clean(value x)
   if (Tag_val(x) == Infix_tag) x -= Infix_offset_val(x);
   return Is_white_val(x);
 }
+
+/* If it is not white during clean phase it is dead, i.e it will be swept */
+Caml_inline int Is_Dead_during_clean(value x)
+{
+  CAMLassert (caml_gc_phase == Phase_clean);
+  return Test_if_its_white(x);
+}
+
+/** caml_ephe_none is considered as not white  */
+Caml_inline int Is_White_During_Mark(value x)
+{
+  CAMLassert (caml_gc_phase == Phase_mark);
+  if (x == caml_ephe_none ) return 0;
+  return Test_if_its_white(x);
+}
+
 /** The minor heap doesn't have to be marked, outside they should
-    already be black
+    already be black. Remains the value in the heap to mark.
 */
 Caml_inline int Must_be_Marked_during_mark(value x)
 {
@@ -162,13 +175,13 @@ CAMLprim value caml_weak_create (value len)
  */
 static void do_check_key_clean(value ar, mlsize_t offset)
 {
+  value elt;
   CAMLassert (offset >= CAML_EPHE_FIRST_KEY);
-  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;
-    };
+  CAMLassert (caml_gc_phase == Phase_clean);
+  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;
   };
 }
 
@@ -208,7 +221,18 @@ CAMLexport void caml_ephemeron_set_key(value ar, mlsize_t offset, value k)
   CAMLassert (Is_in_heap (ar));
 
   offset += CAML_EPHE_FIRST_KEY;
-  do_check_key_clean(ar, offset);
+
+  if( caml_gc_phase == Phase_mark
+      && caml_ephe_list_pure
+      && Field(ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none
+      && !Is_white_val(ar)
+      && Is_White_During_Mark(Field(ar, offset))
+      && !Is_White_During_Mark(k)){
+    /* the ephemeron could be in the set (2) only because of a white key and not
+       have one anymore after set */
+    caml_darken(Field(ar, CAML_EPHE_DATA_OFFSET), NULL);
+  };
+  if(caml_gc_phase == Phase_clean) do_check_key_clean(ar, offset);
   do_set (ar, offset, k);
 }
 
@@ -225,7 +249,17 @@ CAMLexport void caml_ephemeron_unset_key(value ar, mlsize_t offset)
 
   offset += CAML_EPHE_FIRST_KEY;
 
-  do_check_key_clean(ar, offset);
+  if( caml_gc_phase == Phase_mark
+      && caml_ephe_list_pure
+      && Field(ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none
+      && !Is_white_val(ar)
+      && Is_White_During_Mark(Field(ar, offset)) ){
+    /* the ephemeron could be in the set (2) only because of this white key and
+       not have one anymore after unsetting it */
+    caml_darken(Field(ar, CAML_EPHE_DATA_OFFSET), NULL);
+  };
+
+  if(caml_gc_phase == Phase_clean) do_check_key_clean(ar, offset);
   Field (ar, offset) = caml_ephe_none;
 }
 
@@ -256,8 +290,12 @@ CAMLprim value caml_weak_set (value ar, value n, value el)
 
 CAMLexport void caml_ephemeron_set_data (value ar, value el)
 {
+  value old_data;
   CAMLassert_valid_ephemeron(ar);
 
+  old_data = Field (ar, CAML_EPHE_DATA_OFFSET);
+  if (caml_gc_phase == Phase_mark && !Is_White_During_Mark(old_data))
+    caml_darken (el, NULL);
   if (caml_gc_phase == Phase_clean){
     /* During this phase since we don't know which ephemerons have been
        cleaned we always need to check it. */
@@ -534,6 +572,7 @@ CAMLexport void caml_ephemeron_blit_key(value ars, mlsize_t offset_s,
                                         mlsize_t length)
 {
   intnat i; /** intnat because the second for-loop stops with i == -1 */
+  int dest_has_white_value;
   if (length == 0) return;
   CAMLassert_valid_offset(ars, offset_s);
   CAMLassert_valid_offset(ard, offset_d);
@@ -545,10 +584,41 @@ CAMLexport void caml_ephemeron_blit_key(value ars, mlsize_t offset_s,
   offset_s += CAML_EPHE_FIRST_KEY;
   offset_d += CAML_EPHE_FIRST_KEY;
 
+  if ( caml_gc_phase == Phase_mark
+       && caml_ephe_list_pure
+       && Field(ard, CAML_EPHE_DATA_OFFSET) != caml_ephe_none
+       && !Is_white_val(ard)
+       && !Is_White_During_Mark(Field(ard, CAML_EPHE_DATA_OFFSET))
+       ){
+    /* We check here if darkening of the data of the destination is needed
+       because the destination could be in (2). Indeed a white key could
+       disappear from the destination after blitting and being in (2) requires
+       if the ephemeron is alive without white key to have a black or none
+       data. */
+
+    dest_has_white_value = 0;
+
+    for(i = 0; i < length; i++){
+      dest_has_white_value |= Is_White_During_Mark(Field(ard, offset_d + i));
+    };
+    /* test if the destination can't be in set (2) because of the keys that are
+       going to be set */
+    if(!dest_has_white_value) goto No_darkening;
+    for(i = 0; i < length; i++){
+      /* test if the source is going to bring a white key to replace the one
+         set */
+      if(Is_White_During_Mark(Field(ars, offset_s + i))) goto No_darkening;
+    };
+    /* the destination ephemeron could be in the set (2) because of a white key
+        replaced and not have one anymore after. */
+    caml_darken(Field(ard, CAML_EPHE_DATA_OFFSET),NULL);
+  }
+  No_darkening:
+
   if (caml_gc_phase == Phase_clean){
     caml_ephe_clean_partial(ars, offset_s, offset_s + length);
     /* We don't need to clean the keys that are about to be overwritten,
-       except where cleaning them could result in releasing the data,
+       except when cleaning them could result in releasing the data,
        which can't happen if data is already released. */
     if (Field (ard, CAML_EPHE_DATA_OFFSET) != caml_ephe_none)
       caml_ephe_clean_partial(ard, offset_d, offset_d + length);
@@ -581,14 +651,23 @@ CAMLprim value caml_weak_blit (value ars, value ofs,
 
 CAMLexport void caml_ephemeron_blit_data (value ars, value ard)
 {
+  value data, old_data;
   CAMLassert_valid_ephemeron(ars);
   CAMLassert_valid_ephemeron(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));
+
+  data = Field (ars, CAML_EPHE_DATA_OFFSET);
+  old_data = Field (ard, CAML_EPHE_DATA_OFFSET);
+  if (caml_gc_phase == Phase_mark &&
+      data != caml_ephe_none &&
+      !Is_White_During_Mark(old_data))
+    caml_darken (data, NULL);
+
+  do_set (ard, CAML_EPHE_DATA_OFFSET, data);
 }
 
 CAMLprim value caml_ephe_blit_data (value ars, value ard)

testsuite/tests/misc/ephe_issue9391.ml

@@ -0,0 +1,67 @@
+(* TEST
+*)
+
+let debug = false
+
+open Printf
+open Ephemeron
+
+let empty = ref 0
+let make_ra ~size = Array.init size (fun _ -> ref 1) [@@inline never]
+let make_ephes ~size = Array.init size (fun _ -> Ephemeron.K1.create ()) [@@inline never]
+
+let test ~size ~slice =
+  let keys1 = make_ra ~size in
+  let keys2 = make_ra ~size in
+  let datas1 = make_ra ~size in
+  let datas2 = make_ra ~size in
+  let ephe1 = make_ephes ~size in
+  let ephe2 = make_ephes ~size in
+  if debug then Gc.set { (Gc.get ()) with Gc.verbose = 0x3 };
+  (** Fill ephe.(i )from key.(i) to data.(i) *)
+  for i=0 to size-1 do Ephemeron.K1.set_key  ephe1.(i) keys1.(i); done;
+  for i=0 to size-1 do Ephemeron.K1.set_data ephe1.(i) datas1.(i); done;
+  for i=0 to size-1 do Ephemeron.K1.set_key  ephe2.(i) keys2.(i); done;
+  for i=0 to size-1 do Ephemeron.K1.set_data ephe2.(i) datas2.(i); done;
+  (** Push everything in the major heap *)
+  if debug then Printf.eprintf "Start minor major\n%!";
+  Gc.minor ();
+  Gc.major ();
+  if debug then Printf.eprintf "start emptying\n%!";
+  for i=0 to size-1 do keys1.(i) <- empty; done;
+  for i=0 to size-1 do datas1.(i) <- empty; done;
+  (** The emptying is done during a major so keys and data are kept alive by the
+     assignments. Restart a new major *)
+  Gc.major ();
+  if debug then Printf.eprintf "Start checking state\n%!";
+  (** Fill the ephemeron with an alive key *)
+  if debug then Printf.eprintf "Start replacing dead key into alive one\n%!";
+  (* Printf.eprintf "put in set (2) %i\n%!" (Gc.major_slice (10*4*slice*6)); *)
+  for i=0 to size-1 do
+    ignore (Gc.major_slice (4));
+    if debug then Printf.eprintf "@%!";
+    Ephemeron.K1.blit_data ephe1.(i) ephe2.(i);
+    if debug && 0 = i mod (size / 10) then Printf.eprintf "done %5i/%i\n%!" i size;
+  done;
+  if debug then   Printf.eprintf "end\n%!";
+  (** Finish all, assertion in clean phase should not find a dangling data *)
+  Gc.full_major ();
+  let r = ref 0 in
+  if debug then
+    for i=0 to size-1 do
+      if Ephemeron.K1.check_data ephe2.(size-1-i) then incr r;
+      if 0 = i mod (size / 10) then Printf.eprintf "done %5i/%i %i\n%!" i size !r;
+    done;
+  (* keep the arrays alive *)
+  assert (Array.length keys1 = size);
+  assert (Array.length keys2 = size);
+  assert (Array.length datas1 = size);
+  assert (Array.length datas2 = size);
+  assert (Array.length ephe1 = size);
+  assert (Array.length ephe2 = size)
+[@@inline never]
+
+let () =
+  test ~size:1000 ~slice:5;
+  test ~size:1000 ~slice:10;
+  test ~size:1000 ~slice:15