91 lines
4.3 KiB
OCaml
91 lines
4.3 KiB
OCaml
(* A clock on every test binary, because a green run is not the only outcome
|
|
to plan for.
|
|
|
|
The mutation pass TODO.org, "The mutation pass has not been re-run", records
|
|
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 ();
|
|
Own_tmp.release ();
|
|
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;
|
|
(* Every [flan dev] this binary starts, directly or from an Emacs it runs,
|
|
dies with its parent and ends once this process is gone (lib/dev.ml,
|
|
[harness]), so a run killed partway leaves no daemon behind. *)
|
|
Unix.putenv "FLAN_DEV_HARNESS" (string_of_int (Unix.getpid ()));
|
|
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
|