From c2b2da223472aedb2a4f21efe0c3a8ea1d542719 Mon Sep 17 00:00:00 2001
From: Stephen Dolan <sdolan@janestreet.com>
Date: Mon, 27 Jul 2020 17:14:48 +0100
Subject: [PATCH] Tests for EINTR-based signal handling

---
 testsuite/tests/lib-systhreads/eintr.ml       | 91 +++++++++++++++++++
 .../tests/lib-systhreads/eintr.reference      |  4 +
 2 files changed, 95 insertions(+)
 create mode 100644 testsuite/tests/lib-systhreads/eintr.ml
 create mode 100644 testsuite/tests/lib-systhreads/eintr.reference

diff --git a/testsuite/tests/lib-systhreads/eintr.ml b/testsuite/tests/lib-systhreads/eintr.ml
new file mode 100644
index 000000000..5c0a4d045
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/eintr.ml
@@ -0,0 +1,91 @@
+(* TEST
+
+* hassysthreads
+include systhreads
+** not-windows
+*** bytecode
+*** native
+*)
+
+let signals_requested = Atomic.make 0
+let signal_delay = 0.1
+let _ = Thread.create (fun () ->
+  let signals_sent = ref 0 in
+  ignore (Thread.sigmask Unix.SIG_BLOCK [Sys.sigint]);
+  while true do
+    if Atomic.get signals_requested > !signals_sent then begin
+      Thread.delay signal_delay;
+      Unix.kill (Unix.getpid ()) Sys.sigint;
+      incr signals_sent
+    end else begin
+      Thread.yield ()
+    end
+  done) ()
+let request_signal () = Atomic.incr signals_requested
+
+let () =
+  let (rd, wr) = Unix.pipe () in
+  Sys.catch_break true;
+  request_signal ();
+  begin match Unix.read rd (Bytes.make 1 'a') 0 1 with
+  | _ -> assert false
+  | exception Sys.Break -> print_endline "break: ok" end;
+  Sys.catch_break false;
+  Unix.close rd;
+  Unix.close wr
+
+let () =
+  let (rd, wr) = Unix.pipe () in
+  Sys.set_signal Sys.sigint (Signal_handle (fun _ -> Gc.full_major ()));
+  request_signal ();
+  begin match Unix.read rd (Bytes.make 1 'a') 0 1 with
+  | _ -> assert false
+  | exception Unix.Unix_error(Unix.EINTR, "read", _) ->
+     print_endline "eintr: ok" end;
+  Sys.set_signal Sys.sigint Signal_default;
+  Unix.close rd;
+  Unix.close wr
+
+
+(* Doing I/O on stdout would be more realistic, but seeking has the
+   same locking & scheduling effects, without actually producing any
+   output *)
+let poke_stdout () =
+  match out_channel_length stdout with
+  | _ -> ()
+  | exception Sys_error _ -> ()
+
+let () =
+  let r = Atomic.make true in
+  Sys.set_signal Sys.sigint (Signal_handle (fun _ ->
+    poke_stdout (); Atomic.set r false));
+  request_signal ();
+  while Atomic.get r do
+    poke_stdout ()
+  done;
+  Sys.set_signal Sys.sigint Signal_default;
+  print_endline "chan: ok"
+
+let () =
+  let mklist () = List.init 1000 (fun i -> (i, i)) in
+  let before = Sys.opaque_identity (ref (mklist ())) in
+  let during = Atomic.make (Sys.opaque_identity (mklist ())) in
+  let siglist = ref [] in
+  Sys.set_signal Sys.sigint (Signal_handle (fun _ ->
+    Gc.full_major (); poke_stdout (); Gc.compact ();
+    siglist := mklist ();
+    raise Sys.Break));
+  request_signal ();
+  begin match
+    while true do
+      poke_stdout ();
+      Atomic.set during (mklist ())
+    done
+  with
+  | () -> assert false
+  | exception Sys.Break -> () end;
+  let expected = Sys.opaque_identity (mklist ()) in
+  assert (!before = expected);
+  assert (Atomic.get during = expected);
+  assert (!siglist = expected);
+  print_endline "gc: ok"
diff --git a/testsuite/tests/lib-systhreads/eintr.reference b/testsuite/tests/lib-systhreads/eintr.reference
new file mode 100644
index 000000000..89355b9dd
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/eintr.reference
@@ -0,0 +1,4 @@
+break: ok
+eintr: ok
+chan: ok
+gc: ok