Runtime_events tracing system

19 files changed, 542 insertions, 48 deletions

diff --git a/testsuite/tests/instrumented-runtime/main.ml b/testsuite/tests/instrumented-runtime/main.ml
deleted file mode 100644
index 084ceb03ca..0000000000
--- a/testsuite/tests/instrumented-runtime/main.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-(* TEST
-  * instrumented-runtime
-  * skip
-  reason = "instrumented runtime test is not very useful and broken on multicore. (#9413)"
-  ** native
-    flags = "-runtime-variant=i"
-*)
-
-(* Test if the instrumented runtime is in working condition *)
-
-let _ =
-  Gc.eventlog_pause ();
-  Gc.eventlog_resume()
diff --git a/testsuite/tests/instrumented-runtime/main.run b/testsuite/tests/instrumented-runtime/main.run
deleted file mode 100644
index 430dd23188..0000000000
--- a/testsuite/tests/instrumented-runtime/main.run
+++ /dev/null
@@ -1,35 +0,0 @@
-#!/bin/sh
-
-export OCAML_EVENTLOG_ENABLED=1
-export OCAML_EVENTLOG_PREFIX=${program}
-
-if [ "${os_type}" = "Win32" ] ; then
-  program=$(cygpath "$program")
-fi
-
-rm -f "${program}"*.eventlog*
-${program} > ${output} &
-
-pid=$!
-wait $pid
-
-ls "${program}".*.eventlog | grep '\.[0-9][0-9]*\.eventlog$' | \
-while IFS= read -r file; do
-  touch ${program}.eventlogs
-  if [ ! -e "${program}.eventlog" ] ; then
-    touch ${program}.eventlog
-  else
-    rm -f ${program}.eventlog
-    break
-  fi
-done
-
-if [ -f "${program}.eventlog" ]; then
-  exit ${TEST_PASS}
-elif [ -f "${program}.eventlogs" ]; then
-  echo 'too many runtime traces found!' > ${ocamltest_response}
-  exit ${TEST_FAIL}
-else
-  echo 'instrumented runtime trace not found!' > ${ocamltest_response}
-  exit ${TEST_FAIL}
-fi
diff --git a/testsuite/tests/lib-runtime-events/stubs.c b/testsuite/tests/lib-runtime-events/stubs.c
new file mode 100644
index 0000000000..5aac50a4b7
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/stubs.c
@@ -0,0 +1,95 @@
+#define CAML_NAME_SPACE
+
+#include "caml/alloc.h"
+#include "caml/runtime_events.h"
+#include "runtime_events_consumer.h"
+#include "caml/fail.h"
+#include "caml/memory.h"
+#include "caml/mlvalues.h"
+
+#include <assert.h>
+
+struct counters {
+    int minor_started;
+    int major_started;
+    int minors;
+    int majors;
+};
+
+void start_runtime_events() {
+    caml_runtime_events_start();
+}
+
+int ev_begin(int domain_id, void* callback_data,
+                uint64_t timestamp, ev_runtime_phase phase) {
+    struct counters* tmp_counters = (struct counters*)callback_data;
+    switch( phase ) {
+        case EV_MINOR:
+            tmp_counters->minor_started = 1;
+            break;
+        case EV_MAJOR:
+            tmp_counters->major_started = 1;
+            break;
+        default:
+            break;
+    }
+
+    return 1;
+}
+
+int ev_end(int domain_id, void* callback_data, uint64_t timestamp,
+                ev_runtime_phase phase) {
+    struct counters* tmp_counters = (struct counters*)callback_data;
+    switch( phase ) {
+        case EV_MINOR:
+            assert(tmp_counters->minor_started);
+            tmp_counters->minor_started = 0;
+            tmp_counters->minors++;
+            break;
+        case EV_MAJOR:
+            assert(tmp_counters->major_started);
+            tmp_counters->major_started = 0;
+            tmp_counters->majors++;
+            break;
+        default:
+            break;
+    }
+
+    return 1;
+}
+
+value get_event_counts(void) {
+    CAMLparam0();
+    CAMLlocal1(counts_tuple);
+    runtime_events_error res;
+    uintnat events_consumed;
+
+    struct counters tmp_counters = { 0 };
+
+    counts_tuple = caml_alloc_small(2, 0);
+
+    struct caml_runtime_events_cursor* cursor;
+
+    res = caml_runtime_events_create_cursor(NULL, -1, &cursor);
+
+    if( res != E_SUCCESS ) {
+        caml_failwith("Runtime_events.get_event_counts: invalid or non-existent cursor");
+    }
+
+    caml_runtime_events_set_runtime_begin(cursor, &ev_begin);
+    caml_runtime_events_set_runtime_end(cursor, &ev_end);
+
+    res = caml_runtime_events_read_poll(cursor, &tmp_counters, 0,
+                                   &events_consumed);
+
+    if( res != E_SUCCESS ) {
+        caml_failwith("Runtime_events.get_event_counts: error reading from rings");
+    }
+
+    Field(counts_tuple, 0) = Val_long(tmp_counters.minors);
+    Field(counts_tuple, 1) = Val_long(tmp_counters.majors);
+
+    caml_runtime_events_free_cursor(cursor);
+
+    CAMLreturn(counts_tuple);
+}
diff --git a/testsuite/tests/lib-runtime-events/test.ml b/testsuite/tests/lib-runtime-events/test.ml
new file mode 100644
index 0000000000..db08937089
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test.ml
@@ -0,0 +1,24 @@
+(* TEST
+modules = "stubs.c"
+include runtime_events
+*)
+
+external start_runtime_events : unit -> unit = "start_runtime_events"
+external get_event_counts : unit -> (int * int) = "get_event_counts"
+
+let () =
+    start_runtime_events ();
+    for a = 0 to 2 do
+        ignore(Sys.opaque_identity(ref 42));
+        Gc.compact ()
+    done;
+    let (minors, majors) = get_event_counts () in
+    Printf.printf "minors: %d, majors: %d\n" minors majors;
+    (* Now test we can pause/resume while we're doing things *)
+    for a = 0 to 2 do
+        ignore(Sys.opaque_identity(ref 42));
+        Runtime_events.resume ();
+        Gc.compact ();
+        Runtime_events.pause ()
+    done;
+    Printf.printf "minors: %d, majors: %d\n" minors majors
diff --git a/testsuite/tests/lib-runtime-events/test.reference b/testsuite/tests/lib-runtime-events/test.reference
new file mode 100644
index 0000000000..8619296d61
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test.reference
@@ -0,0 +1,2 @@
+minors: 9, majors: 3
+minors: 9, majors: 3
diff --git a/testsuite/tests/lib-runtime-events/test_caml.ml b/testsuite/tests/lib-runtime-events/test_caml.ml
new file mode 100644
index 0000000000..02398467b7
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml.ml
@@ -0,0 +1,79 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+let major = ref 0
+let minor = ref 0
+let compact = ref 0
+let majors = ref 0
+let minors = ref 0
+let compacts = ref 0
+
+let got_start = ref false
+
+let lifecycle domain_id ts lifecycle_event data =
+    match lifecycle_event with
+    | EV_RING_START ->
+        begin
+            assert(match data with
+            | Some(pid) -> true
+            | None -> false);
+            got_start := true
+        end
+    | _ -> ()
+
+let runtime_begin domain_id ts phase =
+    match phase with
+    | EV_MAJOR_SLICE ->
+        begin
+            assert(!major == 0);
+            major := 1
+        end
+    | EV_MINOR ->
+        begin
+            assert(!minor == 0);
+            minor := 1
+        end
+    | _ -> ()
+
+let runtime_end domain_id ts phase =
+    match phase with
+    | EV_MAJOR_SLICE ->
+        begin
+            assert(!major == 1);
+            major := 0;
+            incr majors
+        end
+    | EV_MINOR ->
+        begin
+            assert(!minor == 1);
+            minor := 0;
+            incr minors
+        end
+    | _ -> ()
+
+let lost_events domain_id num =
+    Printf.printf "Lost %d events\n" num
+
+let epochs = 20
+
+let () =
+    let list_ref = ref [] in
+    start ();
+    let cursor = create_cursor None in
+    let callbacks = Callbacks.create ~runtime_begin ~runtime_end ~lifecycle
+                                    ~lost_events ()
+    in
+    for epoch = 1 to epochs do
+        for a = 1 to 100 do
+            list_ref := [];
+            for a = 1 to 10 do
+                list_ref := (Sys.opaque_identity(ref 42)) :: !list_ref
+            done;
+            Gc.full_major ()
+        done;
+        ignore(read_poll cursor callbacks None)
+    done;
+    assert(!got_start);
+    Printf.printf "minors: %d, majors: %d\n" !minors !majors
diff --git a/testsuite/tests/lib-runtime-events/test_caml.reference b/testsuite/tests/lib-runtime-events/test_caml.reference
new file mode 100644
index 0000000000..16e3da2053
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml.reference
@@ -0,0 +1 @@
+minors: 18000, majors: 8000
diff --git a/testsuite/tests/lib-runtime-events/test_caml_exception.ml b/testsuite/tests/lib-runtime-events/test_caml_exception.ml
new file mode 100644
index 0000000000..e1df5aee0b
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_exception.ml
@@ -0,0 +1,24 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+exception Test_exception
+
+let runtime_begin domain_id ts phase =
+    match phase with
+    | EV_MINOR ->
+      raise Test_exception
+    | _ -> ()
+
+let () =
+    start ();
+    let cursor = create_cursor None in
+    let callbacks = Callbacks.create ~runtime_begin ()
+    in
+    Gc.full_major ();
+    try begin
+      ignore(read_poll cursor callbacks None);
+      Printf.printf "Exception ignored"
+    end with
+      Test_exception -> Printf.printf "OK"
diff --git a/testsuite/tests/lib-runtime-events/test_caml_exception.reference b/testsuite/tests/lib-runtime-events/test_caml_exception.reference
new file mode 100644
index 0000000000..a0aba9318a
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_exception.reference
@@ -0,0 +1 @@
+OK
\ No newline at end of file
diff --git a/testsuite/tests/lib-runtime-events/test_caml_parallel.ml b/testsuite/tests/lib-runtime-events/test_caml_parallel.ml
new file mode 100644
index 0000000000..3cd4752282
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_parallel.ml
@@ -0,0 +1,92 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+let majors = Atomic.make 0
+let minors = Atomic.make 0
+
+let got_start = ref false
+
+let lost_events_count = ref 0
+
+let lost_events domain_id num_events =
+    lost_events_count := !lost_events_count + num_events
+
+let lifecycle domain_id ts lifecycle_event data =
+    match lifecycle_event with
+    | EV_RING_START ->
+        begin
+            assert(match data with
+            | Some(pid) -> true
+            | None -> false);
+            got_start := true
+        end
+    | _ -> ()
+
+type phase_record = { mutable major: int; mutable minor: int }
+
+let domain_tbl : (int, phase_record) Hashtbl.t = Hashtbl.create 5
+
+let runtime_begin domain_id ts phase =
+    let phase_count = Hashtbl.find_opt domain_tbl domain_id
+        |> Option.value ~default:{ major = 0; minor = 0 } in
+    match phase with
+    | EV_MAJOR ->
+        begin
+            assert(phase_count.major >= 0);
+            phase_count.major <- phase_count.major + 1
+        end
+    | EV_MINOR ->
+        begin
+            assert(phase_count.minor == 0);
+            phase_count.minor <- 1
+        end
+    | _ -> ();
+    Hashtbl.add domain_tbl domain_id phase_count
+
+let runtime_end domain_id ts phase =
+    let phase_count = Hashtbl.find_opt domain_tbl domain_id
+        |> Option.value ~default:{ major = 0; minor = 0 } in
+    match phase with
+    | EV_MAJOR ->
+        begin
+            assert(phase_count.major >= 1);
+            phase_count.major <- phase_count.major - 1;
+            Atomic.incr majors
+        end
+    | EV_MINOR ->
+        begin
+            assert(phase_count.minor == 1);
+            phase_count.minor <- 0;
+            Atomic.incr minors
+        end
+    | _ -> ();
+    Hashtbl.add domain_tbl domain_id phase_count
+
+let num_domains = 3
+let num_minors = 30
+
+let () =
+    start ();
+    let cursor = create_cursor None in
+    let gc_churn_f () =
+        let list_ref = ref [] in
+        for j = 0 to num_minors do
+            list_ref := [];
+            for a = 0 to 100 do
+                list_ref := (Sys.opaque_identity(ref 42)) :: !list_ref
+            done;
+            Gc.minor ();
+        done
+    in
+    let domains_list = List.init num_domains (fun _ -> Domain.spawn gc_churn_f) in
+    let _ = List.iter Domain.join domains_list in
+    let callbacks = Callbacks.create ~runtime_begin ~runtime_end ~lifecycle
+                                        ~lost_events () in
+    ignore(read_poll cursor callbacks None);
+    assert(!got_start);
+    (* this is num_full_majors rather than num_full_majors*num_domains
+        because in the worst case it can be that low. *)
+    assert(Atomic.get minors >= num_minors);
+    assert(!lost_events_count == 0)
diff --git a/testsuite/tests/lib-runtime-events/test_caml_reentry.ml b/testsuite/tests/lib-runtime-events/test_caml_reentry.ml
new file mode 100644
index 0000000000..d69042e354
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_reentry.ml
@@ -0,0 +1,24 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+let () =
+    start ();
+    let cursor = create_cursor None in
+    let empty_callbacks = Callbacks.create () in
+    let runtime_begin domain_id ts phase =
+      match phase with
+      | EV_MINOR ->
+        ignore(read_poll cursor empty_callbacks None)
+      | _ -> () in
+    let callbacks = Callbacks.create ~runtime_begin ()
+    in
+    Gc.full_major ();
+    try begin
+      ignore(read_poll cursor callbacks None);
+      Printf.printf "Exception ignored"
+    end with
+      Failure(_) ->
+        (* Got an exception because we tried to reenter *)
+        Printf.printf "OK"
diff --git a/testsuite/tests/lib-runtime-events/test_caml_reentry.reference b/testsuite/tests/lib-runtime-events/test_caml_reentry.reference
new file mode 100644
index 0000000000..a0aba9318a
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_reentry.reference
@@ -0,0 +1 @@
+OK
\ No newline at end of file
diff --git a/testsuite/tests/lib-runtime-events/test_caml_slot_reuse.ml b/testsuite/tests/lib-runtime-events/test_caml_slot_reuse.ml
new file mode 100644
index 0000000000..34b034a8e8
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_slot_reuse.ml
@@ -0,0 +1,23 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+let got_minor = ref false
+
+let () =
+    start ();
+    for i = 0 to 256 do
+      Domain.join (Domain.spawn (fun _ -> ()))
+    done;
+    let cursor = create_cursor None in
+    let runtime_begin domain_id ts phase =
+      match phase with
+      | EV_MINOR ->
+        got_minor := true
+      | _ -> () in
+    let callbacks = Callbacks.create ~runtime_begin ()
+    in
+    Domain.join (Domain.spawn (fun _ -> Gc.full_major ()));
+    ignore(read_poll cursor callbacks (Some 1_000_000));
+    assert(!got_minor)
diff --git a/testsuite/tests/lib-runtime-events/test_caml_stubs_gc.ml b/testsuite/tests/lib-runtime-events/test_caml_stubs_gc.ml
new file mode 100644
index 0000000000..35ddd983a1
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_caml_stubs_gc.ml
@@ -0,0 +1,21 @@
+(* TEST
+include runtime_events
+*)
+open Runtime_events
+
+let got_minor = ref false
+
+let () =
+    start ();
+    let cursor = create_cursor None in
+    let runtime_begin domain_id ts phase =
+      match phase with
+      | EV_MINOR ->
+        Gc.full_major ();
+        got_minor := true
+      | _ -> () in
+    let callbacks = Callbacks.create ~runtime_begin ()
+    in
+    Gc.full_major ();
+    ignore(read_poll cursor callbacks (Some 1_000));
+    assert(!got_minor)
diff --git a/testsuite/tests/lib-runtime-events/test_env_start.ml b/testsuite/tests/lib-runtime-events/test_env_start.ml
new file mode 100644
index 0000000000..6b6bca5b09
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_env_start.ml
@@ -0,0 +1,26 @@
+(* TEST
+include runtime_events
+set OCAML_RUNTIME_EVENTS_START = "1"
+*)
+
+(* In this test the runtime_events should already be started by the environment
+   variable that we are passing and so we should not need to start it *)
+
+let got_start = ref false
+
+let lifecycle domain_id ts lifecycle_event data =
+  match lifecycle_event with
+  | Runtime_events.EV_RING_START ->
+      begin
+          assert(match data with
+          | Some(pid) -> true
+          | None -> false);
+          got_start := true
+      end
+  | _ -> ()
+
+let () =
+  let cursor = Runtime_events.create_cursor None in
+    let callbacks = Runtime_events.Callbacks.create ~lifecycle () in
+      let _read = Runtime_events.read_poll cursor callbacks None in
+        assert(!got_start)
diff --git a/testsuite/tests/lib-runtime-events/test_external.ml b/testsuite/tests/lib-runtime-events/test_external.ml
new file mode 100644
index 0000000000..b7269b7501
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_external.ml
@@ -0,0 +1,42 @@
+(* TEST
+   include runtime_events
+   * libunix
+   ** bytecode
+   ** native *)
+
+let got_major = ref false
+let got_minor = ref false
+let finished = ref false
+
+let runtime_end domain_id ts phase =
+  match phase with
+  | Runtime_events.EV_EXPLICIT_GC_FULL_MAJOR ->
+    got_major := true
+  | Runtime_events.EV_MINOR ->
+    got_minor := true
+  | _ -> ()
+
+let () =
+  (* start runtime_events now to avoid a race *)
+  Runtime_events.start ();
+  let parent_pid = Unix.getpid () in
+  let parent_cwd = Sys.getcwd () in
+  let child_pid = Unix.fork () in
+  if child_pid == 0 then begin
+    (* we are in the child *)
+    let cursor = Runtime_events.create_cursor (Some (parent_cwd, parent_pid)) in
+    let callbacks = Runtime_events.Callbacks.create ~runtime_end () in
+    let started = Unix.gettimeofday () in
+    while (not !finished) && (Unix.gettimeofday () -. started < 10.) do
+      Runtime_events.read_poll cursor callbacks None |> ignore;
+      if !got_major && !got_minor then
+        finished := true
+    done;
+    assert(!got_minor);
+    assert(!got_major);
+  end else begin
+    (* we are in the parent, generate some events *)
+    Gc.full_major ();
+    (* now wait for our child to finish *)
+    Unix.wait () |> ignore
+  end
diff --git a/testsuite/tests/lib-runtime-events/test_fork.ml b/testsuite/tests/lib-runtime-events/test_fork.ml
new file mode 100644
index 0000000000..c3add88370
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_fork.ml
@@ -0,0 +1,47 @@
+(* TEST
+   include runtime_events
+   * libunix
+   ** bytecode
+   ** native *)
+
+let got_start = ref false
+let got_fork_child = ref false
+let got_fork_parent = ref false
+
+let child_pid = ref 0
+let am_child = ref false
+
+let lifecycle domain_id ts lifecycle_event data =
+    match lifecycle_event with
+    | Runtime_events.EV_RING_START ->
+        begin
+            assert(match data with
+            | Some(pid) -> true
+            | None -> false);
+            got_start := true
+        end
+    | Runtime_events.EV_FORK_PARENT ->
+        begin
+            (match data with
+            | Some(pid) ->
+                begin
+                    child_pid := pid;
+                    got_fork_parent := true
+                end
+            | None -> assert(false));
+        end
+    | Runtime_events.EV_FORK_CHILD ->
+        got_fork_child := true
+    | _ -> ()
+
+let () =
+    Runtime_events.start ();
+    let new_child_pid = Unix.fork () in
+    let cursor = Runtime_events.create_cursor None in
+    let callbacks = Runtime_events.Callbacks.create ~lifecycle () in
+    ignore(Runtime_events.read_poll cursor callbacks None);
+    if new_child_pid == 0 then
+        assert(!got_fork_child)
+    else
+        assert(!got_fork_parent && !child_pid > 0);
+    assert(!got_start);
diff --git a/testsuite/tests/lib-runtime-events/test_instrumented.ml b/testsuite/tests/lib-runtime-events/test_instrumented.ml
new file mode 100644
index 0000000000..7a41c49b2a
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_instrumented.ml
@@ -0,0 +1,39 @@
+(* TEST
+  * native
+    include runtime_events
+    flags = "-runtime-variant=i"
+*)
+
+open Runtime_events
+
+let list_ref = ref []
+let total_sizes = ref 0
+let total_minors = ref 0
+let lost_event_words = ref 0
+
+let alloc domain_id ts sizes =
+  let size_accum = Array.fold_left (fun x y -> x + y) 0 sizes in
+    total_sizes := !total_sizes + size_accum
+
+let runtime_end domain_id ts phase =
+  match phase with
+  | EV_MINOR ->
+    total_minors := !total_minors + 1
+  | _ -> ()
+
+(* lost words of events *)
+let lost_events domain_id words =
+  lost_event_words := !lost_event_words + words
+
+let () =
+    Gc.full_major ();
+    start ();
+    let cursor = create_cursor None in
+    for a = 0 to 1_000_000 do
+      list_ref := (Sys.opaque_identity(ref 42)) :: !list_ref
+    done;
+    Gc.full_major ();
+    let callbacks = Callbacks.create ~runtime_end ~alloc ~lost_events () in
+    ignore(read_poll cursor callbacks None);
+    Printf.printf "lost_event_words: %d, total_sizes: %d, total_minors: %d\n"
+      !lost_event_words !total_sizes !total_minors
diff --git a/testsuite/tests/lib-runtime-events/test_instrumented.reference b/testsuite/tests/lib-runtime-events/test_instrumented.reference
new file mode 100644
index 0000000000..10ff334124
--- /dev/null
+++ b/testsuite/tests/lib-runtime-events/test_instrumented.reference
@@ -0,0 +1 @@
+lost_event_words: 0, total_sizes: 2000003, total_minors: 33