(* A clock on every test binary, because a green run is not the only outcome
   to plan for.

   The mutation pass that produced NEXT.md's blind-spot list turned up one
   defect that did not make the suite fail — it made it *hang*. A reader loop
   that forgets to advance reads the same character for ever, and every binary
   that reads a .flan file stops there. Nothing prints, nothing exits, and
   [dune test] waits as long as it is left to. In CI that is a job killed by
   the runner's own timeout, with no failing case named and no output to read.

   So: an alarm, at two scales.

   [arm] is the per-binary backstop. It is deliberately generous — test_dev
   launches a daemon and test_acceptance builds for wasm32 — because an alarm
   that fires on a slow machine is a flake, and a flake is how a watchdog gets
   deleted. It is here to turn "for ever" into "fails in ten minutes", not to
   measure anything.

   [within] is the tight one, for a call whose budget really is small: reading
   a few characters of source. It raises [Timeout] rather than exiting, so the
   caller can report one failing row and carry on through the rest of its
   table — a binary that dies on the first hang tells you much less than one
   that finishes and names every case that hung.

   SIGALRM is delivered at OCaml's safepoints, which are inserted at loop
   back-edges and function entries, so a tight loop that allocates nothing is
   still interruptible. *)

exception Timeout

let label = ref "test"
let budget = ref 0
let deadline = ref 0.0

(* A binary that forks workers of its own (test_acceptance's compile pool, at
   least so far) can register cleanup here: something to run to stop those
   workers before [dying] falls through to [Unix._exit]. Without it, an alarm
   firing mid-run kills only this process and every child it had in flight
   becomes an orphan, reparented to init and left to run — or hang — on its
   own. Best-effort and swallowed: a cleanup action that itself fails must
   not stop the rest of them, or the report of the hang, from happening. *)
let cleanup : (unit -> unit) list ref = ref []
let on_cleanup f = cleanup := f :: !cleanup

let dying _ =
  List.iter (fun f -> try f () with _ -> ()) !cleanup;
  Printf.eprintf
    "\nFAIL  %s: no result after %ds — stopped by the test watchdog.\n\
    \      A test that hangs reports nothing at all; this is that outcome\n\
    \      turned into a failing run.\n"
    !label !budget;
  (* [flush_all] and [Unix._exit], not [exit]: the rows that did pass are in
     stdout's buffer and a watchdog that threw them away would be worse than
     the hang, so both channels are flushed explicitly here rather than left
     to [exit]'s own at_exit-registered flush. [_exit] then skips the rest of
     that at_exit chain entirely, which matters now that test_acceptance.ml
     registers a handler of its own: that handler forces exit 1 whenever
     [failures > 0], and calling plain [exit] here would hand it a chance to
     relabel this exit — after the alarm already fired — as an ordinary
     failing run instead of a hang. Going around the chain is simpler than
     coordinating with what is in it, and does not depend on how many
     handlers get added there later. *)
  flush_all ();
  Unix._exit 2

(* Re-arm the backstop for whatever is left of its budget. One second is the
   floor, because [alarm 0] cancels rather than fires. *)
let backstop () =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle dying);
  let left = !deadline -. Unix.gettimeofday () in
  ignore (Unix.alarm (max 1 (int_of_float left)))

let arm ?(seconds = 600) name =
  label := name;
  budget := seconds;
  deadline := Unix.gettimeofday () +. float_of_int seconds;
  backstop ()

(* [f] under a tighter alarm, with the backstop restored afterwards however
   [f] left. *)
let within seconds f =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
  ignore (Unix.alarm seconds);
  Fun.protect ~finally:backstop f