From 629fae6dc4ee8ddf2293232f99f3b4cea4de4445 Mon Sep 17 00:00:00 2001 From: Jacques-Henri Jourdan Date: Mon, 11 May 2020 17:10:13 +0200 Subject: [PATCH] Add test statmemprof/thread_exit_in_callback. --- .../statmemprof/thread_exit_in_callback.ml | 18 ++++++++++++++++++ .../thread_exit_in_callback.reference | 1 + .../statmemprof/thread_exit_in_callback_stub.c | 16 ++++++++++++++++ 3 files changed, 35 insertions(+) create mode 100644 testsuite/tests/statmemprof/thread_exit_in_callback.ml create mode 100644 testsuite/tests/statmemprof/thread_exit_in_callback.reference create mode 100644 testsuite/tests/statmemprof/thread_exit_in_callback_stub.c diff --git a/testsuite/tests/statmemprof/thread_exit_in_callback.ml b/testsuite/tests/statmemprof/thread_exit_in_callback.ml new file mode 100644 index 000000000..97c1a3aee --- /dev/null +++ b/testsuite/tests/statmemprof/thread_exit_in_callback.ml @@ -0,0 +1,18 @@ +(* TEST +modules = "thread_exit_in_callback_stub.c" +exit_status = "42" +* hassysthreads +include systhreads +** bytecode +** native +*) + +(* We cannot tell Ocamltest that this program is supposed to stop with + a fatal error. Instead, we install a fatal error hook and call exit(42) *) +external install_fatal_error_hook : unit -> unit = "install_fatal_error_hook" + +let _ = + install_fatal_error_hook (); + Gc.Memprof.(start ~callstack_size:10 ~sampling_rate:1. + { null_tracker with alloc_minor = fun _ -> Thread.exit (); None }); + ignore (Sys.opaque_identity (ref 1)) diff --git a/testsuite/tests/statmemprof/thread_exit_in_callback.reference b/testsuite/tests/statmemprof/thread_exit_in_callback.reference new file mode 100644 index 000000000..4d745f0ce --- /dev/null +++ b/testsuite/tests/statmemprof/thread_exit_in_callback.reference @@ -0,0 +1 @@ +Fatal error hook: Thread.exit called from a memprof callback. diff --git a/testsuite/tests/statmemprof/thread_exit_in_callback_stub.c b/testsuite/tests/statmemprof/thread_exit_in_callback_stub.c new file mode 100644 index 000000000..91ed43cc9 --- /dev/null +++ b/testsuite/tests/statmemprof/thread_exit_in_callback_stub.c @@ -0,0 +1,16 @@ +#include +#include "caml/misc.h" +#include "caml/mlvalues.h" + +void fatal_error_hook_exit_3 (char *msg, va_list args) { + fprintf(stderr, "Fatal error hook: "); + vfprintf(stderr, msg, args); + fprintf(stderr, "\n"); + exit(42); +} + + +value install_fatal_error_hook (value unit) { + caml_fatal_error_hook = fatal_error_hook_exit_3; + return Val_unit; +}