diff --git a/test/dune b/test/dune index 4efb846..ac37170 100644 --- a/test/dune +++ b/test/dune @@ -2,8 +2,10 @@ (names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider) ; Explicit because test_sanitize lives in this directory and is not one of ; these: two stanzas in one directory have to say which modules are whose. + ; watchdog is every binary's clock: a hanging test reports nothing, so each + ; of these arms an alarm that turns "for ever" into a failing run. (modules test_flan test_acceptance test_reload test_agent test_session - test_dev test_emacs test_repl test_cider) + test_dev test_emacs test_repl test_cider watchdog) (libraries flan unix) ; The acceptance programs are part of the test corpus: if the reader, the ; parser or the checker regresses on them we want to know here, not at the CLI. @@ -44,7 +46,7 @@ ; is the whole point here. (executable (name test_sanitize) - (modules test_sanitize) + (modules test_sanitize watchdog) (libraries flan unix)) (rule diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4d044b6..6228b62 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -6,6 +6,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:1200 "test_acceptance" + let failures = ref 0 let scratch = Filename.get_temp_dir_name () diff --git a/test/test_agent.ml b/test/test_agent.ml index 557c33b..e2dbb61 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -14,6 +14,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_agent" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_cider.ml b/test/test_cider.ml index 7fc6ad5..d573061 100644 --- a/test/test_cider.ml +++ b/test/test_cider.ml @@ -12,6 +12,9 @@ Skipped, not failed, where there is no emacs: the compiler does not depend on one. *) +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_cider" let () = if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then print_endline "cider: skipped (no emacs on PATH)" diff --git a/test/test_dev.ml b/test/test_dev.ml index 50ce32f..4140ae3 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8,6 +8,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:900 "test_dev" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_emacs.ml b/test/test_emacs.ml index 4bafa59..b2ffdc0 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -9,6 +9,9 @@ Skipped, not failed, where there is no emacs — the compiler does not depend on one. *) +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_emacs" let scratch = Filename.get_temp_dir_name () let tmp n = Filename.concat scratch ("flan-emacs-" ^ n) diff --git a/test/test_flan.ml b/test/test_flan.ml index 9768a6e..dbb57fe 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3,6 +3,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_flan" + let failures = ref 0 let check name cond = @@ -16,8 +20,34 @@ let contains hay needle = let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n = 0 || go 0 +(* Every read in this table runs under a five-second alarm. The reader is the + one part of the compiler whose mistakes loop rather than raise — a branch + that forgets to advance reads the same character for ever — and a hanging + case reports nothing at all. Five seconds is thousands of times what any + row here needs; what it buys is that a loop becomes a named failing row and + the rest of the table still runs. *) +(* Once one read has not returned, the reader is looping and every row after + it would spend the same five seconds proving the same thing — a hundred + rows is eight minutes of that. So the first timeout wedges the rest: they + fail immediately and the binary still reports, which is the whole point of + the alarm. *) +let wedged = ref false + +let guarded seconds f = + if !wedged then raise Watchdog.Timeout + else + match Watchdog.within seconds f with + | x -> x + | exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout + +let read ?(file = "") src = + guarded 5 (fun () -> Reader.read_all ~file src) + +(* The corpus files, which are larger and are read from disk. *) +let read_file path = guarded 30 (fun () -> Reader.read_file path) + let reads name src expected = - match Reader.read_all ~file:"" src with + match read src with | forms -> let got = String.concat " " (List.map Form.to_string forms) in if got <> expected then begin @@ -29,13 +59,20 @@ let reads name src expected = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src (* [needle] is the point: a read error that fires for the wrong reason is not the test passing. Without it "backtick at end of input" would be green even if the backtick were still an ordinary symbol character. *) let rejects ?needle name src = - match Reader.read_all ~file:"" src with + match read src with | _ -> incr failures; Printf.printf "FAIL %s: expected a read error\n" name + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s: the reader did not return\n" name | exception Loc.Error (_, msg) -> (match needle with | Some n when not (contains msg n) -> @@ -140,7 +177,7 @@ let () = `(i ~j ~@k) `(l `(m ~n)) [`o ~p] {:q `r} (f a~b x`y)" in check "no sigils leak into names" - (bad_names (Form.make (Form.List (Reader.read_all ~file:"" corpus)) + (bad_names (Form.make (Form.List (read corpus)) Loc.unknown) = []); (* ── Errors ────────────────────────────────────────────────────── *) @@ -158,7 +195,7 @@ let () = above rejects the unknown one and not escaping itself. Asserted on the string's bytes rather than through [Form.to_string], which escapes them again and would compare the source with itself. *) - (match Reader.read_all ~file:"" "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with + (match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with | [ { Form.v = Form.Str s; _ } ] -> check "known escapes" (s = "a\nb\tc\\d\"e\000f") | _ -> check "known escapes: one string" false); @@ -171,14 +208,14 @@ let () = rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed"; (* ── Locations ─────────────────────────────────────────────────── *) - (match Reader.read_all ~file:"f.flan" "(a)\n (b)" with + (match read ~file:"f.flan" "(a)\n (b)" with | [ a; b ] -> check "loc line 1" (a.loc.line = 1 && a.loc.col = 1); check "loc line 2" (b.loc.line = 2 && b.loc.col = 3); check "loc file" (a.loc.file = "f.flan") | _ -> check "loc: two forms" false); - (match Reader.read_all ~file:"f.flan" "(f\n bad" with + (match read ~file:"f.flan" "(f\n bad" with | _ -> check "unclosed reports opening loc" false | exception Loc.Error (loc, _) -> check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1)); @@ -192,12 +229,12 @@ let () = (* ═══ Parse: forms → AST ═══════════════════════════════════════════ *) let parse1 src = - match Reader.read_all ~file:"" src with + match read src with | [ f ] -> Parse.expr f | _ -> failwith "test source must be exactly one form" let parse_decl src = - match Reader.read_all ~file:"" src with + match read src with | [ f ] -> Parse.decl f | _ -> failwith "test source must be exactly one form" @@ -205,7 +242,7 @@ let parse_decl src = name with the reason, so a test that only proves *something* failed does not observe the rule it is there for. *) let parse_rejects ?needle name src = - match Reader.read_all ~file:"" src |> Parse.program with + match read src |> Parse.program with | _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name | exception Loc.Error (_, msg) -> (match needle with @@ -360,7 +397,7 @@ let () = (* ── The corpus parses ─────────────────────────────────────────── *) List.iter (fun path -> - match Reader.read_file path |> Parse.program with + match read_file path |> Parse.program with | _ -> () | exception Loc.Error (loc, msg) -> incr failures; @@ -382,7 +419,9 @@ let () = capitalisation — otherwise a body starting with a constructor call gets silently eaten as a return type. *) -let program src = Reader.read_all ~file:"" src |> Parse.program +(* Through [read], so the parser and checker tables are under the reader's + alarm too: their sources go through the same reader. *) +let program src = read src |> Parse.program let () = let open Ast in @@ -440,6 +479,10 @@ let infers name src expected = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src let accepts name src = match checked src with @@ -448,6 +491,10 @@ let accepts name src = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src (* [needle] pins the *reason* down: a rejection for the wrong reason is not a passing test, and the unimplemented-feature errors are the whole point. *) diff --git a/test/test_reload.ml b/test/test_reload.ml index 804aa5f..b94eccd 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -21,6 +21,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_reload" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_repl.ml b/test/test_repl.ml index 64aa096..b8c889f 100644 --- a/test/test_repl.ml +++ b/test/test_repl.ml @@ -16,6 +16,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_repl" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index cf384ab..dc3e52b 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -31,6 +31,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:3600 "test_sanitize" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_session.ml b/test/test_session.ml index 3c14ede..8221b20 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -9,6 +9,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_session" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/watchdog.ml b/test/watchdog.ml new file mode 100644 index 0000000..99c9040 --- /dev/null +++ b/test/watchdog.ml @@ -0,0 +1,62 @@ +(* 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 + +let dying _ = + 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 stderr; + 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