Merge pull request #607 from jhjourdan/generational_roots_bug

Bug in generational global roots

3 files changed, 19 insertions, 4 deletions

diff --git a/byterun/globroots.c b/byterun/globroots.c
index 138b808b89..96cd31667a 100644
--- a/byterun/globroots.c
+++ b/byterun/globroots.c
@@ -216,9 +216,9 @@ CAMLexport void caml_remove_generational_global_root(value *r)
 {
   value v = *r;
   if (Is_block(v)) {
-    if (Is_young(v))
+    if (Is_in_heap_or_young(v))
       caml_delete_global_root(&caml_global_roots_young, r);
-    else if (Is_in_heap(v))
+    if (Is_in_heap(v))
       caml_delete_global_root(&caml_global_roots_old, r);
   }
 }
@@ -254,9 +254,9 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval)
        the root should be removed. If [oldval] is young, this will happen
        anyway at the next minor collection, but it is safer to delete it
        here. */
-    if (Is_young(oldval))
+    if (Is_in_heap_or_young(oldval))
       caml_delete_global_root(&caml_global_roots_young, r);
-    else if (Is_in_heap(oldval))
+    if (Is_in_heap(oldval))
       caml_delete_global_root(&caml_global_roots_old, r);
   }
   /* end PR#4704 */
diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml
index a12e24568f..d78ab6a705 100644
--- a/testsuite/tests/gc-roots/globroots.ml
+++ b/testsuite/tests/gc-roots/globroots.ml
@@ -84,6 +84,9 @@ end
 module TestClassic = Test(Classic)
 module TestGenerational = Test(Generational)
 
+external young2old : unit -> unit = "gb_young2old"
+let _ = young2old (); Gc.full_major ()
+
 let _ =
   let n =
     if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in
diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c
index 5c540acf55..28ad2267a2 100644
--- a/testsuite/tests/gc-roots/globrootsprim.c
+++ b/testsuite/tests/gc-roots/globrootsprim.c
@@ -69,3 +69,15 @@ value gb_generational_remove(value vblock)
   caml_remove_generational_global_root(&(Block_val(vblock)->v));
   return Val_unit;
 }
+
+value root;
+
+value gb_young2old(value _dummy) {
+  root = caml_alloc_small(1, 0);
+  caml_register_generational_global_root(&root);
+  caml_modify_generational_global_root(&root, caml_alloc_shr(10, String_tag));
+  Field(root, 0) = 0xFFFFFFFF;
+  caml_remove_generational_global_root(&root);
+  root += sizeof(value);
+  return Val_unit;
+}