Merge pull request #8897 from stedolan/fix-alloc-async

Ensure that C allocation functions do not trigger callbacks

4 files changed, 77 insertions, 0 deletions

diff --git a/testsuite/tests/c-api/alloc_async.ml b/testsuite/tests/c-api/alloc_async.ml
new file mode 100644
index 0000000000..0ed35acf16
--- /dev/null
+++ b/testsuite/tests/c-api/alloc_async.ml
@@ -0,0 +1,17 @@
+(* TEST
+   modules = "alloc_async_stubs.c"
+*)
+
+external test : int ref -> unit = "stub"
+
+let f () =
+  let r = ref 42 in
+  Gc.finalise (fun s -> r := !s) (ref 17);
+  Printf.printf "OCaml, before: %d\n%!" !r;
+  test r;
+  Printf.printf "OCaml, after: %d\n%!" !r;
+  ignore (Sys.opaque_identity (ref 100));
+  Printf.printf "OCaml, after alloc: %d\n%!" !r;
+  ()
+
+let () = (f [@inlined never]) ()
diff --git a/testsuite/tests/c-api/alloc_async.reference b/testsuite/tests/c-api/alloc_async.reference
new file mode 100644
index 0000000000..839271f55d
--- /dev/null
+++ b/testsuite/tests/c-api/alloc_async.reference
@@ -0,0 +1,5 @@
+OCaml, before: 42
+C, before: 42
+C, after: 42
+OCaml, after: 42
+OCaml, after alloc: 17
diff --git a/testsuite/tests/c-api/alloc_async_stubs.c b/testsuite/tests/c-api/alloc_async_stubs.c
new file mode 100644
index 0000000000..5734b06de4
--- /dev/null
+++ b/testsuite/tests/c-api/alloc_async_stubs.c
@@ -0,0 +1,54 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include "caml/alloc.h"
+#include "caml/memory.h"
+
+const char* strs[] = { "foo", "bar", 0 };
+value stub(value ref)
+{
+  CAMLparam1(ref);
+  CAMLlocal2(x, y);
+  int i; char* s; intnat coll_before;
+
+  printf("C, before: %d\n", Int_val(Field(ref, 0)));
+
+  /* First, do enough major allocation to trigger a major collection */
+  coll_before = Caml_state_field(stat_major_collections);
+  while (Caml_state_field(stat_major_collections) == coll_before) {
+    caml_alloc(10000, 0);
+  }
+
+  /* Now, call lots of allocation functions */
+
+  /* Small allocations */
+  caml_alloc(10, 0);
+  x = caml_alloc_small(2, 0);
+  Field(x, 0) = Val_unit;
+  Field(x, 1) = Val_unit;
+  caml_alloc_tuple(3);
+  caml_alloc_float_array(10);
+  caml_alloc_string(42);
+  caml_alloc_initialized_string(10, "abcdeabcde");
+  caml_copy_string("asoidjfa");
+  caml_copy_string_array(strs);
+  caml_copy_double(42.0);
+  caml_copy_int32(100);
+  caml_copy_int64(100);
+  caml_alloc_array(caml_copy_string, strs);
+  caml_alloc_sprintf("[%d]", 42);
+
+  /* Large allocations */
+  caml_alloc(1000, 0);
+  caml_alloc_shr(1000, 0);
+  caml_alloc_tuple(1000);
+  caml_alloc_float_array(1000);
+  caml_alloc_string(10000);
+  s = calloc(10000, 1);
+  caml_alloc_initialized_string(10000, s);
+  free(s);
+
+
+  printf("C, after: %d\n", Int_val(Field(ref, 0)));
+  fflush(stdout);
+  CAMLreturn (Val_unit);
+}
diff --git a/testsuite/tests/c-api/ocamltests b/testsuite/tests/c-api/ocamltests
new file mode 100644
index 0000000000..2741b81d4e
--- /dev/null
+++ b/testsuite/tests/c-api/ocamltests
@@ -0,0 +1 @@
+alloc_async.ml