From 6a4c0bed379c1d305faabf64216ca1867406f950 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Aug 2026 11:25:48 +0100 Subject: [PATCH 1/9] [lib] Do not transform Timeout exceptions in splitter Depending on the timing of the timeout signal, the exception was captured by a wildcard match, masking the timeout failure and showing an unrelated error. There might be other cases hidden throughout the code, and it might even be raised in the third-party dependencies, making timeout reporting difficult to do in all cases. A different design for reporting timeouts is needed, but making one that doesn't cause churn might be too disruptive. In particular, cooperative, polled timers might be interesting to investigate. Signed-off-by: Pau Ruiz Safont --- lib/splitter.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/splitter.mll b/lib/splitter.mll index b6bbf928fd..e32d620695 100644 --- a/lib/splitter.mll +++ b/lib/splitter.mll @@ -263,7 +263,7 @@ let split_lexbuf name lexbuf = with | LexMisc.Error (msg,loc) -> failwith (Printf.sprintf "%s: splitter error in sublexer %s" (Pos.str_pos loc) msg) - | Assert_failure _ as e -> raise e + | (Assert_failure _ | Misc.Timeout) as e -> raise e | e -> failwith (Printf.sprintf "%s: Uncaught exception in splitter %s" (Pos.str_pos lexbuf.lex_curr_p) (Printexc.to_string e)) in From 4898384722cf092b8bf81cea8bbe8e6c2453c076 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Aug 2026 12:39:40 +0100 Subject: [PATCH 2/9] [internal] Use options for expected filepaths These were using "" as a special value to mean None, a fact which was not mentioned in the interface of the functions. Signed-off-by: Pau Ruiz Safont --- internal/herd_diycross_regression_test.ml | 4 ++-- internal/herd_regression_test.ml | 4 ++-- internal/herd_test.ml | 4 ++-- internal/lib/testHerd.ml | 18 ++++++++---------- internal/lib/testHerd.mli | 15 +++++++-------- 5 files changed, 21 insertions(+), 24 deletions(-) diff --git a/internal/herd_diycross_regression_test.ml b/internal/herd_diycross_regression_test.ml index 04f1759ffb..47c8e93da1 100644 --- a/internal/herd_diycross_regression_test.ml +++ b/internal/herd_diycross_regression_test.ml @@ -123,7 +123,7 @@ let run_tests ?j flags = (* check if a `*.expected-warn` exists *) let warn_file = Filename.remove_extension e |> TestHerd.expected_warn_of_litmus in - let warn_file = if Sys.file_exists warn_file then warn_file else "" in + let warn_file = if Sys.file_exists warn_file then Some warn_file else None in TestHerd.herd_output_matches_expected ~verbose:flags.verbose ~nohash:flags.nohash @@ -131,7 +131,7 @@ let run_tests ?j flags = ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir - flags.herd l e "" warn_file) + flags.herd l e None warn_file) les | Some j -> ignore diff --git a/internal/herd_regression_test.ml b/internal/herd_regression_test.ml index c4435aed88..67019da5db 100644 --- a/internal/herd_regression_test.ml +++ b/internal/herd_regression_test.ml @@ -137,8 +137,8 @@ let show_tests_par j flags = ~libdir:flags.libdir flags.herd l (TestHerd.expected_of_litmus l) - (TestHerd.expected_failure_of_litmus l) - (TestHerd.expected_warn_of_litmus l) + (Some (TestHerd.expected_failure_of_litmus l)) + (Some (TestHerd.expected_warn_of_litmus l)) in let everything_passed = ref true in for_each_litmus_in_dir flags.litmus_dir (fun l -> diff --git a/internal/herd_test.ml b/internal/herd_test.ml index 5df9ba525d..484367514b 100644 --- a/internal/herd_test.ml +++ b/internal/herd_test.ml @@ -54,8 +54,8 @@ let flags, litmus = let () = let expected = TestHerd.expected_of_litmus litmus - and expected_failure = TestHerd.expected_failure_of_litmus litmus - and expected_warn = TestHerd.expected_warn_of_litmus litmus in + and expected_failure = Some (TestHerd.expected_failure_of_litmus litmus) + and expected_warn = Some (TestHerd.expected_warn_of_litmus litmus) in if TestHerd.herd_args_output_matches_expected ~verbose:flags.verbose ~check:flags.check com ~nohash:flags.nohash wrapped litmus diff --git a/internal/lib/testHerd.ml b/internal/lib/testHerd.ml index 04db7635af..2e270c5f91 100644 --- a/internal/lib/testHerd.ml +++ b/internal/lib/testHerd.ml @@ -297,17 +297,14 @@ let run_herd_concurrent ?verbose ~bell ~cat ~conf ~variants ~libdir herd ~j litm Command.NonBlock.run_status ~stdin:litmuses mapply args let read_some_file litmus name = - if name = "" then None - else - try Some (Filesystem.read_file name Channel.read_lines) - with _ -> - begin - Printf.printf "Failed %s : Missing file '%s'\n" litmus name ; - None - end + Option.bind name @@ fun name -> + try Some (Filesystem.read_file name Channel.read_lines) + with _ -> + Printf.printf "Failed %s : Missing file '%s'\n" litmus name ; + None let do_check_output - check nohash litmus expected expected_failure expected_warn t = + check nohash litmus expected expected_failure expected_warn t = let () = let _,lines,_ = t in if false && lines <> [] then begin @@ -317,6 +314,7 @@ let do_check_output List.iter prerr_endline lines ; () end in + let expected = Some expected in match t with | 0,[],[] -> true (* Can occur in case of controlled timeout *) @@ -403,7 +401,7 @@ let read_output_files litmus = let output_matches_expected ?(check=All) ?(nohash=false) litmus expected = try let o,e = read_output_files litmus in - do_check_output check nohash litmus expected "" "" (0,o,e) + do_check_output check nohash litmus expected None None (0,o,e) with Command.Error e -> Printf.printf "Failed %s : %s \n" litmus (Command.string_of_error e) ; false diff --git a/internal/lib/testHerd.mli b/internal/lib/testHerd.mli index 3ccd0b2c56..c354ac2ad2 100644 --- a/internal/lib/testHerd.mli +++ b/internal/lib/testHerd.mli @@ -145,11 +145,10 @@ val run_herd_concurrent : libdir : path -> path -> j:int-> path list -> int -(** [herd_output_matches_expected check nohash litmus expected] returns true when - * the output file produced by running [litmus] matches reference - * [expected]. If argument [nohash] is true, hashes are not compared. - * If argument [check] specifies the valididy check - * (see type check above). *) +(** [herd_output_matches_expected ?check ?nohash litmus expected] returns true + when the output file produced by running [litmus] matches reference + [expected]. If argument [nohash] is true, hashes are not compared. If + argument [check] specifies the valididy check (see type check above). *) val output_matches_expected : ?check:check -> ?nohash:bool -> path -> path -> bool @@ -175,15 +174,15 @@ val herd_output_matches_expected : conf : path option -> variants : string list -> libdir : path -> - path -> path -> path -> path -> path -> bool + path -> path -> path -> path option -> path option -> bool (** [herd_args_output_mathes_expected herd args litmus * expected expected_failure expected_warn] has the same functionality * as [herd_output_matches_expected] above but a different interface, * as command line options are given as the list [args]. *) val herd_args_output_matches_expected : - ?verbose:bool -> ?check:check -> ?nohash:bool -> - path -> string list -> path -> path -> path -> path -> bool + ?verbose:bool -> ?check:check -> ?nohash:bool -> path -> + string list -> path -> path -> path option -> path option -> bool (** [is_litmus filename] returns whether the [filename] is a .litmus file. *) val is_litmus : path -> bool From d25d530cc8b35835981885e9005c2d8f0949ebcc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 25 Aug 2026 14:48:51 +0100 Subject: [PATCH 3/9] [internal] Convert Command runs to use result-based control flow Programs running commands are now forced to deal with the errors. With the previous code that used exceptions, they were not always handled, and in some cases they were handled even if the code could not raise them. Now more programs are more aware of the different ways that a herd run can fail, this includes the mismatches between expected files and herd output. This handling of error can also be used the future to build complex control flows and better integrate it with mapply. For the time being, only a single error is being surfaced when running mapply. Signed-off-by: Pau Ruiz Safont --- internal/diy_regression_test.ml | 6 +- internal/diyone_test.ml | 9 +- internal/herd_assumptions_test.ml | 2 + internal/herd_catalogue_regression_test.ml | 13 +- internal/herd_diycross_regression_test.ml | 26 +++- internal/herd_promote.ml | 16 +- internal/herd_regression_test.ml | 15 +- internal/herd_test.ml | 22 ++- internal/lib/command.ml | 44 +++--- internal/lib/command.mli | 16 +- internal/lib/shelf.ml | 17 +-- internal/lib/testHerd.ml | 161 ++++++++++----------- internal/lib/testHerd.mli | 53 ++++--- internal/lib/tests/command_test.ml | 14 +- 14 files changed, 219 insertions(+), 195 deletions(-) diff --git a/internal/diy_regression_test.ml b/internal/diy_regression_test.ml index 8f74883f72..239ef30dfe 100644 --- a/internal/diy_regression_test.ml +++ b/internal/diy_regression_test.ml @@ -42,8 +42,10 @@ let do_run flags = |> Fun.flip List.nth 1 |> String.trim in cycles := cycle :: !cycles in - (* ignore the output to stderr *) - Command.NonBlock.run ~stdout:read_line ~stderr:(fun _ -> ()) flags.diy (diy_argument flags); + let ignore _ = () in + let raise_e e = failwith (Command.string_of_error e) in + Command.NonBlock.run ~stdout:read_line ~stderr:ignore flags.diy (diy_argument flags) + |> Result.fold ~ok:ignore ~error:raise_e ; StringSet.of_list !cycles let run_tests flags = diff --git a/internal/diyone_test.ml b/internal/diyone_test.ml index b77fbd06c3..a5de950d66 100644 --- a/internal/diyone_test.ml +++ b/internal/diyone_test.ml @@ -57,9 +57,12 @@ let run_diyone flags command = "/bin/sh" ["-c";shell_command] in let comment = match status,!stderr with - | 0,stderr -> stderr - | status,"" -> Printf.sprintf "[%d]" status - | status,stderr -> Printf.sprintf "[%d]\n%s" status stderr in + | Ok 0,stderr -> stderr + | Ok status,"" -> Printf.sprintf "[%d]" status + | Ok status,stderr -> Printf.sprintf "[%d]\n%s" status stderr + | Error err, stderr -> + Printf.sprintf "[%s]\n%s" (Command.string_of_error err) stderr + in match comment,!stdout with | "",stdout -> stdout | comment,"" -> Printf.sprintf "(*\n%s\n*)" comment diff --git a/internal/herd_assumptions_test.ml b/internal/herd_assumptions_test.ml index bbdc1d9649..520e0e29b9 100644 --- a/internal/herd_assumptions_test.ml +++ b/internal/herd_assumptions_test.ml @@ -111,12 +111,14 @@ let run flags = (fun remaining_flags (dir, conf) -> Printf.printf "Checking assumptions against %s ...\n%!" dir; let litmuses = get_each_litmus_in_dir dir in + let raise_e e = failwith (Command.string_of_error e) in let remaining_flags = List.fold_left (fun remaining_flags litmus -> let _, stdout, stderr = TestHerd.run_herd ~bell:None ~cat:(Some flags.assumptions_file) ~conf ~variants:[] ~libdir:flags.libdir flags.herd [ litmus ] + |> Result.fold ~ok:Fun.id ~error:raise_e in let stdout = String.concat "\n" stdout in let stderr = String.concat "\n" stderr in diff --git a/internal/herd_catalogue_regression_test.ml b/internal/herd_catalogue_regression_test.ml index d9e2a0937d..58938e7602 100644 --- a/internal/herd_catalogue_regression_test.ml +++ b/internal/herd_catalogue_regression_test.ml @@ -84,13 +84,16 @@ let herd_kinds_of_permutation ?j ?timeout flags shelf_dir litmuses p = flags.herd ?j ?timeout in match cmd litmuses with - | 0,stdout, [] -> + | Ok (0, stdout, []) -> let kind_of_log l = Log.(l.name, Option.get l.kind) in List.map kind_of_log (Log.of_string_list stdout) - | _, _, stderr -> + | Ok (_, _, stderr) -> let lines = String.concat "\n" stderr in let msg = Printf.sprintf "Herd returned stderr:\n%s" lines in raise (Error msg) + | Result.Error e -> + let msg = Printf.sprintf "Herd returned error: %s" (Command.string_of_error e) in + raise (Error msg) (* Shelves. *) @@ -167,7 +170,7 @@ let run_tests ?j ?timeout flags = pf (String.concat "," excess) end ; match diff with - | [] -> true + | [] -> Ok () | rs -> let pp = List.map @@ -178,9 +181,9 @@ let run_tests ?j ?timeout flags = Printf.printf "Kinds differs: kinds file = %s ; %s\n" kinds_path (string_of_permutation p) ; List.iter (Printf.printf "%s\n") pp ; - false in + Result.Error () in let passed = result_of_permutation flags.kinds_path cat in - if not passed then exit 1 + if passed <> Ok () then exit 1 let promote_tests ?j flags = diff --git a/internal/herd_diycross_regression_test.ml b/internal/herd_diycross_regression_test.ml index 47c8e93da1..73ad01d022 100644 --- a/internal/herd_diycross_regression_test.ml +++ b/internal/herd_diycross_regression_test.ml @@ -49,15 +49,16 @@ let common xs ys = let diycross_args flags out_dir = ["-o"; out_dir; "-set-libdir"; flags.libdir; ] @ flags.diycross_args +let raise_e e = failwith (Command.string_of_error e) (* Commands *) let run_diycross flags = let tmp_dir = Filesystem.new_temp_dir () in let args = diycross_args flags tmp_dir in - Command.run flags.diycross args ; + Command.run flags.diycross args + |> Result.fold ~ok:Fun.id ~error:raise_e ; tmp_dir,List.filter TestHerd.is_litmus (list_dir tmp_dir) - let show_tests ?j flags = let tmp_dir,litmuses = run_diycross flags in match j with @@ -114,6 +115,11 @@ let run_tests ?j flags = concat_dir flags.expected_dir (List.map TestHerd.expected_of_litmus in_both) in + + let is_result_expected = function + | Ok () -> true + | Error (_ : TestHerd.run_error) -> false + in let results = let les = List.combine litmus_paths expected_paths in match j with @@ -124,14 +130,16 @@ let run_tests ?j flags = let warn_file = Filename.remove_extension e |> TestHerd.expected_warn_of_litmus in let warn_file = if Sys.file_exists warn_file then Some warn_file else None in - TestHerd.herd_output_matches_expected - ~verbose:flags.verbose - ~nohash:flags.nohash - ~bell:None ~cat:None + TestHerd.herd_output_matches_expected + ~verbose:flags.verbose + ~nohash:flags.nohash + ~bell:None ~cat:None ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir - flags.herd l e None warn_file) + flags.herd l e None warn_file + |> is_result_expected + ) les | Some j -> ignore @@ -180,7 +188,9 @@ let promote_tests ?j flags = ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir - flags.herd [l] in + flags.herd [l] + |> Result.fold ~ok:Fun.id ~error:raise_e + in List.map (fun l -> output_of_litmus l) litmus_paths | Some j -> ignore diff --git a/internal/herd_promote.ml b/internal/herd_promote.ml index be2146994a..a01c4becd9 100644 --- a/internal/herd_promote.ml +++ b/internal/herd_promote.ml @@ -40,6 +40,16 @@ let () = Sys.argv.(0) com (String.concat "; " wrapped) let () = - let st = TestHerd.run_herd_args com wrapped litmus in - let ok = TestHerd.promote litmus st in - exit (if ok then 0 else 1) + let ok = + TestHerd.run_herd_args com wrapped litmus + |> Result.map (TestHerd.promote litmus) + in + let err_code = match ok with + | Ok true -> 0 + | Ok false -> 1 + | Error e -> + Printf.eprintf "%s: Error when running test: %s\n%!" + (Filename.basename Sys.argv.(0)) (Command.string_of_error e) ; + 1 + in + exit err_code diff --git a/internal/herd_regression_test.ml b/internal/herd_regression_test.ml index 67019da5db..ccb3a22ac4 100644 --- a/internal/herd_regression_test.ml +++ b/internal/herd_regression_test.ml @@ -140,12 +140,13 @@ let show_tests_par j flags = (Some (TestHerd.expected_failure_of_litmus l)) (Some (TestHerd.expected_warn_of_litmus l)) in - let everything_passed = ref true in + let found_errors = ref [] in for_each_litmus_in_dir flags.litmus_dir (fun l -> - if not (test_passes l) then - everything_passed := false + match test_passes l with + | Ok () -> () + | Error e -> found_errors := e :: !found_errors ) ; - if not !everything_passed then begin + if !found_errors <> [] then begin Printf.printf "Some tests had errors\n" ; exit 1 end @@ -173,7 +174,7 @@ let do_run_test_par wrapper j flags = let com = Command.command mapply args in Printf.eprintf "Will run: %s\n%!" com in let st = Command.run_status mapply args in - if st <> 0 then begin + if st <> Ok 0 then begin Printf.printf "Some tests had errors\n" ; exit 1 end @@ -198,7 +199,9 @@ let promote_tests_seq flags = for_each_litmus_in_dir flags.litmus_dir (fun litmus -> let ok = - TestHerd.promote litmus (output_of_litmus litmus) in + (output_of_litmus litmus) + |> Result.fold ~ok:(TestHerd.promote litmus) ~error:(fun _ -> false) + in if not ok then everything_ok := false) ; if not !everything_ok then begin Printf.printf "Some tests had errors\n" ; diff --git a/internal/herd_test.ml b/internal/herd_test.ml index 484367514b..c33b22314a 100644 --- a/internal/herd_test.ml +++ b/internal/herd_test.ml @@ -56,16 +56,14 @@ let () = let expected = TestHerd.expected_of_litmus litmus and expected_failure = Some (TestHerd.expected_failure_of_litmus litmus) and expected_warn = Some (TestHerd.expected_warn_of_litmus litmus) in - if + let test = TestHerd.herd_args_output_matches_expected - ~verbose:flags.verbose ~check:flags.check com ~nohash:flags.nohash wrapped litmus - expected expected_failure expected_warn - then - exit 0 - else begin - let () = - if false then - Printf.printf "Test not ok: %s %s\n%!" - (String.concat " " (com::wrapped)) litmus in - exit 1 - end + ~verbose:flags.verbose ~check:flags.check com ~nohash:flags.nohash + wrapped litmus expected expected_failure expected_warn + in + match test with + | Ok () -> exit 0 + | Error e -> + Printf.printf "Test not ok: %s %s; error %s\n%!" + (String.concat " " (com::wrapped)) litmus (TestHerd.pp_run_error e) ; + exit 1 diff --git a/internal/lib/command.ml b/internal/lib/command.ml index a57bc6f330..662ff86ca6 100644 --- a/internal/lib/command.ml +++ b/internal/lib/command.ml @@ -18,13 +18,9 @@ module Option = Base.Option -type error = { - binary : string ; - args : string list ; - status : Unix.process_status ; -} +type ctx = {must_succeed : bool ; binary : string ; args: string list} -exception Error of error +type error = {context : ctx ; status : Unix.process_status} let command bin args = match args with @@ -37,7 +33,7 @@ let string_of_process_status = function | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %i" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %i" n -let string_of_error { binary = bin ; args = args ; status = s } = +let string_of_error {context = {binary = bin ; args = args; _} ; status = s} = Printf.sprintf "Process %s (command: %s)" (string_of_process_status s) (command bin args) @@ -55,6 +51,12 @@ let out_pipe nonblock = if nonblock then Unix.set_nonblock out_fd ; in_fd, Unix.out_channel_of_descr out_fd +let to_result context = function + | Unix.WEXITED 0 -> Ok 0 + | Unix.WEXITED r when not context.must_succeed -> Ok r + | status -> + Error { context; status } + let do_run must_succeed ?stdin:in_f ?stdout:out_f ?stderr:err_f bin args = (* Notes: * - By default, the file descriptors are Unix.stdin, Unix.stdout, Unix.stderr, @@ -102,15 +104,13 @@ let do_run must_succeed ?stdin:in_f ?stdout:out_f ?stderr:err_f bin args = ) in let _, status = Unix.waitpid [] pid in - match status with - | Unix.WEXITED 0 -> 0 - | Unix.WEXITED r when not must_succeed -> r - | status -> - raise (Error { binary = bin ; args = args ; status = status }) + to_result {must_succeed; binary=bin; args} status let run ?stdin ?stdout ?stderr bin args = - ignore (do_run true ?stdin ?stdout ?stderr bin args) -and run_status ?stdin ?stdout ?stderr bin args = + do_run true ?stdin ?stdout ?stderr bin args + |> Result.map (fun _ -> ()) + +let run_status ?stdin ?stdout ?stderr bin args = do_run false ?stdin ?stdout ?stderr bin args @@ -227,14 +227,12 @@ module NonBlock = struct loop i o e ; pid) in let _, status = Unix.waitpid [] pid in - match status with - | Unix.WEXITED 0 -> 0 - | Unix.WEXITED r when not must_succeed -> r - | status -> - raise (Error { binary = bin ; args = args ; status = status }) + to_result {must_succeed; args; binary=bin} status -let run ?stdin ?stdout ?stderr bin args = - ignore (do_run true ?stdin ?stdout ?stderr bin args) -and run_status ?stdin ?stdout ?stderr bin args = - do_run false ?stdin ?stdout ?stderr bin args + let run ?stdin ?stdout ?stderr bin args = + do_run true ?stdin ?stdout ?stderr bin args + |> Result.map (fun _ -> ()) + + let run_status ?stdin ?stdout ?stderr bin args = + do_run false ?stdin ?stdout ?stderr bin args end diff --git a/internal/lib/command.mli b/internal/lib/command.mli index 6825202f5e..3984299738 100644 --- a/internal/lib/command.mli +++ b/internal/lib/command.mli @@ -16,13 +16,7 @@ (** Utilities for running commands. *) -type error = { - binary : string ; - args : string list ; - status : Unix.process_status ; -} - -exception Error of error +type error (** [string_of_error e] returns a human-readable representation of an error * [e]. *) @@ -40,14 +34,14 @@ val command : string -> string list -> string val run : ?stdin:(out_channel -> unit) -> ?stdout:(in_channel -> unit) -> - ?stderr:(in_channel -> unit) -> string -> string list -> unit + ?stderr:(in_channel -> unit) -> string -> string list -> (unit, error) result (** Same as [run] above, does not raise [Error] on non-zero exit * code. Returns exit code *) val run_status : ?stdin:(out_channel -> unit) -> ?stdout:(in_channel -> unit) -> - ?stderr:(in_channel -> unit) -> string -> string list -> int + ?stderr:(in_channel -> unit) -> string -> string list -> (int, error) result module NonBlock : sig @@ -64,13 +58,13 @@ module NonBlock : sig val run : ?stdin:(unit -> string option) -> ?stdout:(string -> unit) -> - ?stderr:(string -> unit) -> string -> string list -> unit + ?stderr:(string -> unit) -> string -> string list -> (unit, error) result (** Same as [run] above, does not raise [Error] on non-zero exit * code. Returns exit code *) val run_status : ?stdin:(unit -> string option) -> ?stdout:(string -> unit) -> - ?stderr:(string -> unit) -> string -> string list -> int + ?stderr:(string -> unit) -> string -> string list -> (int, error) result end diff --git a/internal/lib/shelf.ml b/internal/lib/shelf.ml index 3e12f87e61..cdfc0eb051 100644 --- a/internal/lib/shelf.ml +++ b/internal/lib/shelf.ml @@ -60,12 +60,9 @@ let python = lazy begin let exists p = let dev_null ch = ignore (Channel.read_lines ch) in - try - Command.run ~stdout:dev_null ~stderr:dev_null p ["--version"] ; - true - with - | Unix.Unix_error _ -> false - | Command.Error _ -> false + match Command.run ~stdout:dev_null ~stderr:dev_null p ["--version"] with + | Ok () -> true + | Error _ | exception Unix.Unix_error _ -> false in match List.find_opt exists ["python"; "python3"] with | Some p -> p @@ -97,11 +94,9 @@ let do_list_of_file sorted path key = in let lines = ref [] in let read_lines c = lines := Channel.read_lines c in - begin try - Command.run ~stdin:script ~stdout:read_lines (Lazy.force python) [] - with - Command.Error e -> failwith (Command.string_of_error e) - end ; + let raise_e e = failwith (Command.string_of_error e) in + Command.run ~stdin:script ~stdout:read_lines (Lazy.force python) [] + |> Result.fold ~ok:Fun.id ~error:raise_e ; if sorted then List.sort String.compare !lines else diff --git a/internal/lib/testHerd.ml b/internal/lib/testHerd.ml index 2e270c5f91..365bbdccad 100644 --- a/internal/lib/testHerd.ml +++ b/internal/lib/testHerd.ml @@ -247,6 +247,8 @@ let check_tags s = let check line = if check_tags line then prerr_endline line +let ( let* ) = Result.bind + let do_run_herd_args verbose herd args ?j litmuses = let litmuses = Base.Iter.of_list litmuses in (* @@ -261,7 +263,7 @@ let do_run_herd_args verbose herd args ?j litmuses = else fun line -> lines := line :: !lines in let read_err_line line = err_lines := line :: !err_lines in - let r = + let* r = match j with | None -> Command.NonBlock.run_status @@ -272,7 +274,7 @@ let do_run_herd_args verbose herd args ?j litmuses = let args = mapply_args ~j ~com:herd args in Command.NonBlock.run_status ~stdin:litmuses ~stdout:read_line ~stderr:read_err_line mapply args in - (r,without_unstable_lines (List.rev !lines), (List.rev !err_lines)) + Ok (r,without_unstable_lines (List.rev !lines), (List.rev !err_lines)) let run_herd_args ?(verbose=false) herd args litmus = do_run_herd_args verbose herd args [litmus] @@ -296,84 +298,75 @@ let run_herd_concurrent ?verbose ~bell ~cat ~conf ~variants ~libdir herd ~j litm let args = mapply_herd_redirect_args ?verbose ~j ~herd ~litmuses:[] args in Command.NonBlock.run_status ~stdin:litmuses mapply args -let read_some_file litmus name = - Option.bind name @@ fun name -> - try Some (Filesystem.read_file name Channel.read_lines) - with _ -> - Printf.printf "Failed %s : Missing file '%s'\n" litmus name ; - None +type run_error = + | Expected_missing + | Expected_fail_missing + | Stdout_missing + | Stdout_mismatch + | Stderr_mismatch + | Stderr_not_expected of string list (** stderr *) + | Unknown_exit_code of int * bool * bool + (** exit code, stdout present, stderr present *) + | Command_error of Command.error + +let pp_run_error = function + | Expected_missing -> "Expected file was missing" + | Expected_fail_missing -> "Expected_failure file was missing" + | Stdout_missing -> "Stdout was missing" + | Stdout_mismatch -> "Stdout did not match Expected file" + | Stderr_mismatch -> "Stderr did not match Expected_failure file" + | Stderr_not_expected _ -> "Stderr found, but not expected" + | Unknown_exit_code (ec, stdout, stderr) -> + Printf.sprintf "Unknown exit code: %i; stdout: %b; stderr: %b" + ec stdout stderr + | Command_error err -> + Printf.sprintf "Command error: %s" (Command.string_of_error err) + +let read_some_file _litmus ~error name = + Option.to_result ~none:error name |> Fun.flip Result.bind (fun name -> + try Ok (Filesystem.read_file name Channel.read_lines) + with _ -> + Error error + ) let do_check_output check nohash litmus expected expected_failure expected_warn t = - let () = - let _,lines,_ = t in - if false && lines <> [] then begin - Printf.eprintf "Expected (%s) %s, Out of test:\n" - (pp_check check) - expected ; - List.iter prerr_endline lines ; - () - end in let expected = Some expected in + let check_f f reason ~expected actual = + if f actual expected then Error reason else Ok () + in + let check_stdout ~expected actual = + check_f (checklog litmus check nohash) Stdout_mismatch ~expected actual + in + let check_stderr ~expected actual = + check_f (checkerrlog check nohash) Stderr_mismatch ~expected actual + in + let ( let* ) = Result.bind in match t with - | 0,[],[] -> true (* Can occur in case of controlled timeout *) + | 0,[],[] -> Ok () (* Can occur in case of controlled timeout *) + | _,[],[] -> - Printf.printf - "Failed %s : Herd finished but returned no output or errors\n" litmus ; - false + Error Stdout_missing | 0,(_::_ as stdout), [] -> (* Herd finished without errors - normal *) - begin - match read_some_file litmus expected with - | None -> false - | Some expected_output -> - if - checklog litmus check nohash stdout expected_output - then begin - Printf.printf "Failed %s : Logs do not match\n%!" litmus ; - false - end else true - end - + let* expected_output = + read_some_file ~error:Expected_missing litmus expected + in + check_stdout ~expected:expected_output stdout | r,[], (_::_ as stderr) when r <> 0 -> (* Herd finished with errors - check expected failure *) - begin - match read_some_file litmus expected_failure with - | None -> false - | Some expected_failure_output -> - if checkerrlog check nohash stderr expected_failure_output then begin - Printf.printf - "Failed %s : Expected Failure Logs do not match\n" litmus ; - false - end else true - end - | 0,(_::_ as stdout),(_::_ as stderr) -> - (* Herd returned both output and errors *) - begin - match read_some_file litmus expected with - | None -> false - | Some expected_output -> - if - checklog litmus check nohash stdout expected_output - then begin - Printf.printf "Failed %s : Logs do not match\n" litmus ; - false - end else - match read_some_file litmus expected_warn with - | None -> - if _dbg then begin - Printf.eprintf - "** Unexpected warning stderr for %s\n" - (Filename.basename litmus) ; - List.iter prerr_endline stderr - end ; - false - | Some expected_warn -> - if log_diff nohash stderr expected_warn then begin - Printf.printf - "Failed %s : Warning logs do not match\n" litmus ; - false - end else true - end + let* expected_failure_output = + read_some_file ~error:Expected_fail_missing litmus expected_failure + in + check_stderr ~expected:expected_failure_output stderr + | 0,(_::_ as stdout),(_::_ as stderr) -> (* Herd returned both output and errors *) + let* expected_output = + read_some_file ~error:Expected_missing litmus expected + in + let* () = check_stdout ~expected:expected_output stdout in + let* expected_warn = + read_some_file ~error:(Stderr_not_expected stderr) litmus expected_warn + in + check_stderr ~expected:expected_warn stderr | r,stdout,stderr -> let some f = match f with @@ -391,7 +384,7 @@ let do_check_output display "stdout" stdout ; display "stderr" stderr end ; - false + Error (Unknown_exit_code (r, stdout <> [], stderr <> [])) let read_output_files litmus = let o = read_file (outname litmus) @@ -399,24 +392,20 @@ let read_output_files litmus = o,e let output_matches_expected ?(check=All) ?(nohash=false) litmus expected = - try - let o,e = read_output_files litmus in - do_check_output check nohash litmus expected None None (0,o,e) - with Command.Error e -> - Printf.printf "Failed %s : %s \n" litmus - (Command.string_of_error e) ; false + let o,e = read_output_files litmus in + do_check_output check nohash litmus expected None None (0,o,e) + |> Result.is_ok let do_herd_output_matches_expected (check:check) nohash do_run litmus expected expected_failure expected_warn = - try - let t = do_run litmus in - do_check_output - check nohash litmus expected expected_failure expected_warn t - with - | Command.Error e -> - Printf.printf "Failed %s : %s \n" litmus - (Command.string_of_error e) ; false + let error_of_command_error e = Command_error e in + let check_output = + do_check_output check nohash litmus expected expected_failure expected_warn + in + do_run litmus + |> Result.map_error error_of_command_error + |> Fun.flip Result.bind check_output let herd_output_matches_expected ?(verbose=false) ?(check=All) ?(nohash=false) diff --git a/internal/lib/testHerd.mli b/internal/lib/testHerd.mli index c354ac2ad2..a795251c48 100644 --- a/internal/lib/testHerd.mli +++ b/internal/lib/testHerd.mli @@ -122,7 +122,7 @@ val run_herd : libdir : path -> path -> ?j:int -> ?timeout:float -> ?speedcheck:speedcheck -> ?checkfilter:bool -> - path list -> int * string list * string list + path list -> (int * string list * string list, Command.error) result (** [run_herd_args herd args litmus] similar in functionality to * [run_herd] above but different as regards interface: @@ -131,7 +131,7 @@ val run_herd : *) val run_herd_args : ?verbose:bool -> path -> string list -> path -> - int * string list * string list + (int * string list * string list, Command.error) result (** [run_herd_concurrent ~bell ~cat ~conf ~variants ~libdir herd j litmuses] * Similar to [run_herd] except that output is stored into files specific @@ -143,7 +143,7 @@ val run_herd_concurrent : conf : path option -> variants : string list -> libdir : path -> - path -> j:int-> path list -> int + path -> j:int-> path list -> (int, Command.error) result (** [herd_output_matches_expected ?check ?nohash litmus expected] returns true when the output file produced by running [litmus] matches reference @@ -152,19 +152,30 @@ val run_herd_concurrent : val output_matches_expected : ?check:check -> ?nohash:bool -> path -> path -> bool +type run_error = + | Expected_missing (** The expected file for the litmus test is missing *) + | Expected_fail_missing + (** The expected failure file for the litmus test is missing *) + | Stdout_missing (** Herd didn't produce contents in stdout *) + | Stdout_mismatch (** The expected file contents and stdout were different *) + | Stderr_mismatch + (** The expected failure file contents and stderr were different *) + | Stderr_not_expected of string list + (** Stdout was present, but not expected *) + | Unknown_exit_code of int * bool * bool + (** Herd exited with an unknown exit code. Shows presence of stdout and stderr *) + | Command_error of Command.error + (** THere's was an error when running herd, see [Command.error] for more information *) + +val pp_run_error : run_error -> string + (** [herd_output_matches_expected ~bell ~cat ~conf ~variants ~libdir herd - * litmus expected expected_failure expected_warn] runs the binary - * [herd] with a custom [libdir] on a [litmus] file, - * and compares the output with an [expected] file. - * If the run writes to stderr then we check [expected_failure]. If the - * contents of [expected_failure] match then it is an expected failure, - * otherwise it is an unexpected failure and will raise an Error. - * If the run writes to both stdout and stderr, stdout is checked - * against the [expected] file, while stderr is checked against - * the [expected_warn] file. If any file is missing or differs, - * an Error is raised. - * Paths to [cat], [bell], and [conf] files, as well as [variants], can also - * be passed in. *) + litmus expected expected_failure expected_warn] runs the binary [herd] with + a custom [libdir] on a [litmus] file, compares the output in stdout and + stderr, and compares it with an [expected] and [expected_failure] files, + respectively. It returns [Ok ()] if the command is successful and outputs + match, otherwise returns a {run_error} Error. Paths to [cat], [bell], and + [conf] files, as well as [variants], can also be passed in. *) val herd_output_matches_expected : ?verbose : bool -> ?check : check -> @@ -174,15 +185,15 @@ val herd_output_matches_expected : conf : path option -> variants : string list -> libdir : path -> - path -> path -> path -> path option -> path option -> bool + path -> path -> path -> path option -> path option -> (unit, run_error) result -(** [herd_args_output_mathes_expected herd args litmus - * expected expected_failure expected_warn] has the same functionality - * as [herd_output_matches_expected] above but a different interface, - * as command line options are given as the list [args]. *) +(** [herd_args_output_mathes_expected herd args litmus expected + expected_failure expected_warn] has the same functionality as + [herd_output_matches_expected] above but a different interface, as command + line options are given as the list [args]. *) val herd_args_output_matches_expected : ?verbose:bool -> ?check:check -> ?nohash:bool -> path -> - string list -> path -> path -> path option -> path option -> bool + string list -> path -> path -> path option -> path option -> (unit, run_error) result (** [is_litmus filename] returns whether the [filename] is a .litmus file. *) val is_litmus : path -> bool diff --git a/internal/lib/tests/command_test.ml b/internal/lib/tests/command_test.ml index 563d96d777..dc70a36e09 100644 --- a/internal/lib/tests/command_test.ml +++ b/internal/lib/tests/command_test.ml @@ -23,6 +23,8 @@ module StringList = struct let to_ocaml_string = Base.List.to_ocaml_string Base.String.to_ocaml_string end +let raise_e e = failwith (Command.string_of_error e) + let tests = [ "Command.command without args", (fun () -> let expected = "'foo'" in @@ -52,7 +54,8 @@ let tests = [ Sys.remove path ; (* Recreate it with `touch`. *) - Command.run "touch" [path] ; + Command.run "touch" [path] + |> Result.fold ~ok:Fun.id ~error:raise_e ; if not (Sys.file_exists path) then Test.fail "File doesn't exist after `touch`" @@ -72,7 +75,8 @@ let tests = [ (fun (bin, args, expected) -> let actual = ref None in let read_lines i = actual := Some (Channel.read_lines i) in - Command.run ~stdout:read_lines bin args ; + Command.run ~stdout:read_lines bin args + |> Result.fold ~ok:Fun.id ~error:raise_e ; let actual = Option.get !actual in if StringList.compare actual expected <> 0 then @@ -96,7 +100,8 @@ let tests = [ let actual = ref None in let read_lines i = actual := Some (Channel.read_lines i) in - Command.run ~stdin:echo ~stdout:read_lines "cat" [] ; + Command.run ~stdin:echo ~stdout:read_lines "cat" [] + |> Result.fold ~ok:Fun.id ~error:raise_e ; let actual = Option.get !actual in if StringList.compare actual expected <> 0 then @@ -121,7 +126,8 @@ let tests = [ Command.run ~stdout:(read actual_stdout) ~stderr:(read actual_stderr) - bin args ; + bin args + |> Result.fold ~ok:Fun.id ~error:raise_e ; let actual_stdout = Option.get !actual_stdout in let actual_stderr = Option.get !actual_stderr in From b616e7e2ef3fe98e34c86718e14807d3dbb6558a Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 24 Sep 2026 16:44:54 +0100 Subject: [PATCH 4/9] [internal] override configuration with other passed parameters Because configurations can apply other parameters, they can override them. This is many times unexpected, so override them make test-all and make test-all-asl still pass with this, meaning they don't timeout in their default configuration Signed-off-by: Pau Ruiz Safont --- internal/lib/testHerd.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/internal/lib/testHerd.ml b/internal/lib/testHerd.ml index 365bbdccad..6fc5199ffc 100644 --- a/internal/lib/testHerd.ml +++ b/internal/lib/testHerd.ml @@ -185,7 +185,7 @@ let herd_args ~bell ~cat ~conf ~variants ~libdir ~timeout ~speedcheck in List.concat [ - exits; libdirs; timeout; bells; cats; confs; variants; speedchecks; + libdirs; bells; cats; confs; exits; timeout; variants; speedchecks; checkfilters ] From 0794a9e62f5b8b26e9aecedc6096126064c9e7f1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Aug 2026 13:14:30 +0100 Subject: [PATCH 5/9] [herd] exit with special exit code when a timeout is hit The value is 128 + SIGVTALRM, following the convention of bash when it's interrupted by a signal, which is 128 + signal. The internal tools are modified as well to report the timeout immediately in a list of tests, while allowing the makefile-based tests to continue. Timeouts for catalog tests are reported for the whole directory, more work needs to be done on mapply to be able to report only the tests that timed out. Example of current output of `make test`: ``` Warning: tests timed out: catalogue/aarch64-mixed/tests/2+2W+posb0b0+posb1b1.litmus, catalogue/aarch64-mixed/tests/CO-MIXED-20cc+H.litmus, catalogue/aarch64-mixed/tests/CoRR+amo.swph0h0-posh0a.w0+w0.litmus, catalogue/aarch64-mixed/tests/CoRR+rmwh0h0-posh0a.w0+w0.litmus, catalogue/aarch64-mixed/tests/CoRW2+posb0b0+b0.litmus, catalogue/aarch64-mixed/tests/CoRW2+posb1b0+h0.litmus, catalogue/aarch64-mixed/tests/CoRW2+posh0h0+h0.litmus, catalogue/aarch64-mixed/tests/LB+dmb.sy+data-wsi-wsi+MIXED+H.litmus, catalogue/aarch64-mixed/tests/MP+HAmo+BAcqAmo.litmus, catalogue/aarch64-mixed/tests/MP+dmb.syb0b1+datab1b1-rfib1h0.litmus, catalogue/aarch64-mixed/tests/MP-Koeln.litmus, catalogue/aarch64-mixed/tests/SmallEndian.litmus herd7 catalogue aarch64-mixed tests: OK ``` Thanks to ShaleXIONG for providing an expensive test to run for the timeouts. Signed-off-by: Pau Ruiz Safont --- herd/herd.ml | 8 +- herd/itimer.ml | 2 +- .../Armv8-ext-forbidden000018.litmus | 25 ++++++ herd/tests/other/timeout-report.t/run.t | 11 +++ internal/herd_catalogue_regression_test.ml | 90 ++++++++++++------- internal/herd_regression_test.ml | 8 +- internal/lib/testHerd.ml | 9 +- internal/lib/testHerd.mli | 1 + 8 files changed, 116 insertions(+), 38 deletions(-) create mode 100644 herd/tests/other/timeout-report.t/Armv8-ext-forbidden000018.litmus create mode 100644 herd/tests/other/timeout-report.t/run.t diff --git a/herd/herd.ml b/herd/herd.ml index da50aa767c..e92fbfbbf7 100644 --- a/herd/herd.ml +++ b/herd/herd.ml @@ -27,6 +27,7 @@ open OptNames let exit_code_of_exn = function | Misc.Exit | Misc.UserError _ | Misc.Fatal _ -> 2 + | Misc.Timeout -> 128 + 26 (* SIGVTALRM *) | _ -> 1 (* Command line arguments *) @@ -808,10 +809,13 @@ let () = (fun _ -> raise Misc.Timeout) !debug.Debug_herd.timeout; Misc.fold_argv_or_stdin - (fun name ((exit_code, seen) as r) -> + (fun name (exit_code, seen) -> try exit_code, from_file name seen with - | Misc.Timeout -> r + | Misc.Timeout as e -> + if dbg_exc then raise e ; + Warn.warn_always "%a: timed out" Pos.pp_pos0 name ; + check_exit e seen | Misc.Exit as e -> if dbg_exc then raise e ; check_exit e seen diff --git a/herd/itimer.ml b/herd/itimer.ml index 88f938199e..0e1c44791a 100644 --- a/herd/itimer.ml +++ b/herd/itimer.ml @@ -32,7 +32,7 @@ let set_signal timeout f dbg = f s else f in Sys.set_signal - 26 (* SIGVTALARM *) + 26 (* SIGVTALRM *) (Sys.Signal_handle g) let start n timeout = diff --git a/herd/tests/other/timeout-report.t/Armv8-ext-forbidden000018.litmus b/herd/tests/other/timeout-report.t/Armv8-ext-forbidden000018.litmus new file mode 100644 index 0000000000..9d118a63a6 --- /dev/null +++ b/herd/tests/other/timeout-report.t/Armv8-ext-forbidden000018.litmus @@ -0,0 +1,25 @@ +AArch64 Armv8-ext-forbidden000018 +"TLBI-sync.ISHdWWPteAF0P Rfe DpAddrdR LxSx PosWRPA FreAPteAF0" +Cycle=Rfe DpAddrdR LxSx PosWRPA FreAPteAF0 TLBI-sync.ISHdWWPteAF0P +Relax=[Fre,PteAF0,TLBI-sync.ISHdWW] +Safe=Rfe DpAddrdR [LxSx,PosWR,A] +Generator=diy7 (version 7.58+1) +Prefetch=0:x=F,0:y=W,1:y=F,1:x=T +Com=Rf Fr +Orig=TLBI-sync.ISHdWWPteAF0P Rfe DpAddrdR LxSx PosWRPA FreAPteAF0 +{ int y=0x4; +0:X0=PTE(x); 0:X1=(oa:PA(x), af:0); 0:X3=y; 0:X4=x; +1:X3=y; 1:X4=x; +} + P0 | P1 ; + STR X1,[X0] | LDR W2,[X3] ; + DSB ISH | MOV W8,#1 ; + LSR X5,X4,#12 | EOR W5,W2,W2 ; + TLBI VAAE1IS,X5 | ADD X6,X4,W5,SXTW ; + DSB ISH | Loop00: ; + MOV W2,#5 | L00: ; + STR W2,[X3] | LDXR W7,[X6] ; + | STXR W9,W8,[X6] ; + | CBNZ W9,Loop00 ; + | LDAR W10,[X4] ; +exists (1:X2=0x5 /\ 1:X7=0x0 /\ 1:X10=0x1 /\ ~Fault(P1:L00,x)) diff --git a/herd/tests/other/timeout-report.t/run.t b/herd/tests/other/timeout-report.t/run.t new file mode 100644 index 0000000000..6e03e86d61 --- /dev/null +++ b/herd/tests/other/timeout-report.t/run.t @@ -0,0 +1,11 @@ +Force test timeouts by picking an expensive test and setting the timeout to a +single millisecondand observe the timeout is applied for every litmus test + + $ herd7 -set-libdir ../libdir -timeout 0.001 Armv8-ext-forbidden000018.litmus Armv8-ext-forbidden000018.litmus Armv8-ext-forbidden000018.litmus + Warning: File "Armv8-ext-forbidden000018.litmus": timed out + Warning: File "Armv8-ext-forbidden000018.litmus": timed out + Warning: File "Armv8-ext-forbidden000018.litmus": timed out + [154] + +Note that 154 is generated by adding SIGVTALRM 26, and 128, because the +execution got interrupted by a signal. diff --git a/internal/herd_catalogue_regression_test.ml b/internal/herd_catalogue_regression_test.ml index 58938e7602..f60ce45050 100644 --- a/internal/herd_catalogue_regression_test.ml +++ b/internal/herd_catalogue_regression_test.ml @@ -69,6 +69,9 @@ let (>>=) o1 o2 = match o1 with | "" -> o2 | _ -> Some o1 +type herd_kinds = + | Kinds of (string * ConstrGen.kind) list + | Timeout of string list let herd_kinds_of_permutation ?j ?timeout flags shelf_dir litmuses p = let prepend path = Filename.concat shelf_dir path in @@ -86,7 +89,9 @@ let herd_kinds_of_permutation ?j ?timeout flags shelf_dir litmuses p = match cmd litmuses with | Ok (0, stdout, []) -> let kind_of_log l = Log.(l.name, Option.get l.kind) in - List.map kind_of_log (Log.of_string_list stdout) + Kinds (List.map kind_of_log (Log.of_string_list stdout)) + | Ok (ec, _, _) when ec = 128 + 26 -> (* SIGVTALRM *) + Timeout litmuses | Ok (_, _, stderr) -> let lines = String.concat "\n" stderr in let msg = Printf.sprintf "Herd returned stderr:\n%s" lines in @@ -118,6 +123,8 @@ let exit_1_if_any_files_missing ~description paths = List.iter (Printf.printf "Missing %s: %s\n" description) missing ; raise (Error "Some files are missing") +let short_test_name path = Misc.filebase path + (* Commands. *) let show_tests ?j ?timeout flags = @@ -146,42 +153,54 @@ let show_tests ?j ?timeout flags = let run_tests ?j ?timeout flags = let cat, shelf_dir, tests = first_of_shelf flags.shelf_path flags.index_path in + let catalogue = Filename.basename shelf_dir in exit_1_if_any_files_missing ~description:"test" tests ; exit_1_if_any_files_missing ~description:"kinds.txt file" [flags.kinds_path] ; let result_of_permutation kinds_path p = let expected = Kinds.of_file kinds_path in - let actual = - herd_kinds_of_permutation ?j ?timeout flags shelf_dir tests p in - let diff,miss,excess = Kinds.check ~expected ~actual in - if Misc.consp miss then begin - let pf = - match miss with - | [_] -> Printf.eprintf "Warning: test %s is not in reference kind file %s\n" - | _ -> Printf.eprintf "Warning: tests %s are not in reference kind file %s\n" in - pf (String.concat "," miss) kinds_path - end ; - if Misc.consp excess then begin - let pf = - match excess with - | [_] -> Printf.eprintf "Warning: test %s is not in test base\n" - | _ -> Printf.eprintf "Warning: tests %s are not in test base\n" in - pf (String.concat "," excess) - end ; - match diff with - | [] -> Ok () - | rs -> - let pp = - List.map - (fun (n,ke,ka) -> - Printf.sprintf "%s: expected=%s, actual=%s" - n (ConstrGen.pp_kind ke) (ConstrGen.pp_kind ka)) - rs in - Printf.printf "Kinds differs: kinds file = %s ; %s\n" - kinds_path (string_of_permutation p) ; - List.iter (Printf.printf "%s\n") pp ; - Result.Error () in + match herd_kinds_of_permutation ?j ?timeout flags shelf_dir tests p with + | Timeout litmuses -> + let pf = + ( match litmuses with + | [_] -> Printf.eprintf "Warning: a test timed out in catalogue %s: %s\n" + | _ -> Printf.eprintf "Warning: tests timed out in catalogue %s: %s\n" + ) + in + pf catalogue + (String.concat ", " + (List.map short_test_name litmuses)) ; + Result.Error () + | Kinds actual -> + let diff,miss,excess = Kinds.check ~expected ~actual in + if Misc.consp miss then begin + let pf = + match miss with + | [_] -> Printf.eprintf "Warning: test %s is not in reference kind file %s\n" + | _ -> Printf.eprintf "Warning: tests %s are not in reference kind file %s\n" in + pf (String.concat "," miss) kinds_path + end ; + if Misc.consp excess then begin + let pf = + match excess with + | [_] -> Printf.eprintf "Warning: test %s is not in test base\n" + | _ -> Printf.eprintf "Warning: tests %s are not in test base\n" in + pf (String.concat "," excess) + end ; + match diff with + | [] -> Ok () + | rs -> + let pp = + List.map + (fun (n,ke,ka) -> + Printf.sprintf "%s: expected=%s, actual=%s" + n (ConstrGen.pp_kind ke) (ConstrGen.pp_kind ka)) + rs in + Printf.printf "Kinds differs: kinds file = %s ; %s\n" + kinds_path (string_of_permutation p) ; + List.iter (Printf.printf "%s\n") pp ; + Result.Error () in let passed = result_of_permutation flags.kinds_path cat in if passed <> Ok () then exit 1 @@ -189,10 +208,17 @@ let run_tests ?j ?timeout flags = let promote_tests ?j flags = let cat, shelf_dir, tests = first_of_shelf flags.shelf_path flags.index_path in + let catalogue = Filename.basename shelf_dir in exit_1_if_any_files_missing ~description:"tests" tests ; let kinds = - herd_kinds_of_permutation ?j flags shelf_dir tests cat + match herd_kinds_of_permutation ?j flags shelf_dir tests cat with + | Kinds kinds -> kinds + | Timeout litmuses -> + Printf.eprintf "Warning: timeout for tests in catalogue %s: %s\n" + catalogue (String.concat "; " + (List.map short_test_name litmuses)) ; + [] in Filesystem.write_file flags.kinds_path (fun o -> output_string o (Kinds.to_string kinds)) diff --git a/internal/herd_regression_test.ml b/internal/herd_regression_test.ml index ccb3a22ac4..fa1ffa394f 100644 --- a/internal/herd_regression_test.ml +++ b/internal/herd_regression_test.ml @@ -174,10 +174,14 @@ let do_run_test_par wrapper j flags = let com = Command.command mapply args in Printf.eprintf "Will run: %s\n%!" com in let st = Command.run_status mapply args in - if st <> Ok 0 then begin + match st with + | Ok 0 -> () + | Ok ec when ec = 128 + 26 -> (* SIGVTALRM *) + Printf.printf "Some tests timed out\n" ; + exit ec + | _ -> Printf.printf "Some tests had errors\n" ; exit 1 - end let run_test_par = do_run_test_par Test diff --git a/internal/lib/testHerd.ml b/internal/lib/testHerd.ml index 6fc5199ffc..ccbcffe62d 100644 --- a/internal/lib/testHerd.ml +++ b/internal/lib/testHerd.ml @@ -305,6 +305,7 @@ type run_error = | Stdout_mismatch | Stderr_mismatch | Stderr_not_expected of string list (** stderr *) + | Timed_out | Unknown_exit_code of int * bool * bool (** exit code, stdout present, stderr present *) | Command_error of Command.error @@ -316,6 +317,7 @@ let pp_run_error = function | Stdout_mismatch -> "Stdout did not match Expected file" | Stderr_mismatch -> "Stderr did not match Expected_failure file" | Stderr_not_expected _ -> "Stderr found, but not expected" + | Timed_out -> "Timed out" | Unknown_exit_code (ec, stdout, stderr) -> Printf.sprintf "Unknown exit code: %i; stdout: %b; stderr: %b" ec stdout stderr @@ -345,7 +347,12 @@ let do_check_output let ( let* ) = Result.bind in match t with | 0,[],[] -> Ok () (* Can occur in case of controlled timeout *) - + | ec, _, stderr when ec = 128 + 26 -> (* Timeout with SIGVTALRM *) + let* expected_timeout_output = + read_some_file ~error:Timed_out litmus expected + in + let* () = check_stderr ~expected:expected_timeout_output stderr in + Error Timed_out | _,[],[] -> Error Stdout_missing | 0,(_::_ as stdout), [] -> (* Herd finished without errors - normal *) diff --git a/internal/lib/testHerd.mli b/internal/lib/testHerd.mli index a795251c48..baa37bf7c7 100644 --- a/internal/lib/testHerd.mli +++ b/internal/lib/testHerd.mli @@ -162,6 +162,7 @@ type run_error = (** The expected failure file contents and stderr were different *) | Stderr_not_expected of string list (** Stdout was present, but not expected *) + | Timed_out (** Herd timed out *) | Unknown_exit_code of int * bool * bool (** Herd exited with an unknown exit code. Shows presence of stdout and stderr *) | Command_error of Command.error From c114c7d5cd7a4c750682214616b956bd6c1f5ef1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 4 Sep 2026 15:10:07 +0100 Subject: [PATCH 6/9] [doc] Address typos in herd.tex Signed-off-by: Pau Ruiz Safont --- doc/herd.tex | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/herd.tex b/doc/herd.tex index 7af8ce717c..8befa853a6 100644 --- a/doc/herd.tex +++ b/doc/herd.tex @@ -481,7 +481,7 @@ \subsection{Computing \label{sec:cos}coherence orders} \end{verbatim} Where the pre-defined sets \texttt{IW} and~\texttt{FW} are the sets of all initial and final writes respectively. -%TODO exemple of co0 on 2+2W +%TODO example of co0 on 2+2W Then, assuming that $W_x$ is the set of all writes to location~$x$, one can compute the set of all possible coherence orders for~$x$ with @@ -855,7 +855,7 @@ \subsection{\label{overview}Overview} There are two structured values: tuples of values and sets of values. One should notice that primitive set of events and structured set of events are not the same thing. In fact, the language prevents the construction of structured set of events. -Similarily, there are no structured sets of elements of relations, there are only relations. +Similarly, there are no structured sets of elements of relations, there are only relations. \item There is a distinction between expressions that evaluate to some value, and instructions that are executed for their effect. @@ -1308,7 +1308,7 @@ \subsubsection*{\label{sec:check}Checks} evaluates \nt{expr} and applies the check \nt{check}. There are six checks: the three basic acyclicity (keyword~\T{acyclic}), irreflexivity (keyword~\T{irreflexive}) -and emptyness (keyword~\T{empty}); and their +and emptiness (keyword~\T{empty}); and their negations. If the check succeeds, execution goes on. Otherwise, execution stops. @@ -1902,7 +1902,7 @@ \subsection{Options} \item[{\tt -texmacros }] Use latex commands in some text of pictures. If activated (\opt{-showthread true}), thread numbers are shown as \verb+\myth{+$n$\verb+}+. Assembler instructions are locations in nodes -are argument to an \verb+\asm+ command. It user responsability to define +are argument to an \verb+\asm+ command. It user responsibility to define those commands in their \LaTeX{} documents that include the pictures. Possible definitions are \verb+\newcommand{\myth}[1]{Thread~#1}+ and \verb+\newcommand{\asm}[1]{\texttt{#1}}+. @@ -1935,7 +1935,7 @@ \subsection{Options} \item[{\tt -squished }] The setting \opt{-squished true} drastically limits the information displayed in graph nodes. This is usually what is wanted in modes \opt{free} and~\opt{columns}. Default is~\opt{false}. -\item[{\tt -fixedsize }] This setting is meaningfull in +\item[{\tt -fixedsize }] This setting is meaningful in \opt{columns} graph mode and for squished nodes. When set by \opt{-fixedsize true} it forces node width to be $65\%$ of the space between columns. This may sometime yield a nice edge routing. Default is~\opt{false} From 80d6f5450ab87966aeaa8e9a54ea9a5c50cb6c87 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 4 Sep 2026 16:09:36 +0100 Subject: [PATCH 7/9] [doc] don't hardcode path for hevea and hacha Let the system locate the location for the executables, it can still be overriden in special cases. Signed-off-by: Pau Ruiz Safont --- doc/Makefile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/Makefile b/doc/Makefile index 0611003263..01381bc606 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -247,10 +247,9 @@ clean:: /bin/rm -f version.tex #HTML -HEVEABIN=/usr/local/bin -HEVEA=$(HEVEABIN)/hevea +HEVEA=hevea HEVEAOPTS=-fix -exec xxdate.exe -O -HACHA=$(HEVEABIN)/hacha +HACHA=hacha HACHAOPTS=-tocter dochtml: html/index.html From a5de4e50bbed46e00a19be1fa568ef67a5d9ef60 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 4 Sep 2026 16:21:30 +0100 Subject: [PATCH 8/9] [doc] Add exit status section to herd's documentation Signed-off-by: Pau Ruiz Safont --- doc/herd.tex | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/doc/herd.tex b/doc/herd.tex index 8befa853a6..49c9a27b49 100644 --- a/doc/herd.tex +++ b/doc/herd.tex @@ -2095,6 +2095,16 @@ \subsection{\label{herd:searchpath}File searching} and then in herd installation directory, which is defined while compiling~\herd. + +\subsection{\label{herd:exitstatus}Exit Status} +\herd{} exits with different status depending on the errors it encounters while running: +\begin{description} +\item[{\tt 0}] All test executions were successful. +\item[{\tt 1}] A test execution encountered an unexpected internal error (bug). +\item[{\tt 2}] A test execution encountered a fatal or a user error. +\item[{\tt 154}] A test execution was interrupted because of a timeout. +\end{description} + %\section{Extensions to Herd} % %\begin{quote}\it From b1505d3d2b137de53195833af0ad96cc344e9c67 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 7 Sep 2026 15:52:18 +0100 Subject: [PATCH 9/9] [catalogue] rename tests in VMSA to match their content Some tests didn't match the content, change this. Signed-off-by: Pau Ruiz Safont --- catalogue/aarch64-VMSA/shelf.py | 8 ++++---- ...itmus => 2+2WNExpExp+NExpNExp+DMBST+DMBST+SHOW.litmus} | 0 ...BST.litmus => 2+2WNExpExp+NExpNExp+DMBST+DMBST.litmus} | 0 ...xpExp+SHOW.litmus => 2+2WNExpExp+NExpNExp+SHOW.litmus} | 0 ...NExpExp+NExpExp.litmus => 2+2WNExpExp+NExpNExp.litmus} | 0 5 files changed, 4 insertions(+), 4 deletions(-) rename catalogue/aarch64-VMSA/tests/{2+2WNExpExp+NExpExp+DMBST+DMBST+SHOW.litmus => 2+2WNExpExp+NExpNExp+DMBST+DMBST+SHOW.litmus} (100%) rename catalogue/aarch64-VMSA/tests/{2+2WNExpExp+NExpExp+DMBST+DMBST.litmus => 2+2WNExpExp+NExpNExp+DMBST+DMBST.litmus} (100%) rename catalogue/aarch64-VMSA/tests/{2+2WNExpExp+NExpExp+SHOW.litmus => 2+2WNExpExp+NExpNExp+SHOW.litmus} (100%) rename catalogue/aarch64-VMSA/tests/{2+2WNExpExp+NExpExp.litmus => 2+2WNExpExp+NExpNExp.litmus} (100%) diff --git a/catalogue/aarch64-VMSA/shelf.py b/catalogue/aarch64-VMSA/shelf.py index 4bd15010ab..bb04cbc50c 100644 --- a/catalogue/aarch64-VMSA/shelf.py +++ b/catalogue/aarch64-VMSA/shelf.py @@ -10,10 +10,10 @@ illustrative_tests = [ "tests/A031.litmus", - "tests/2+2WNExpExp+NExpExp+DMBST+DMBST+SHOW.litmus", - "tests/2+2WNExpExp+NExpExp+DMBST+DMBST.litmus", - "tests/2+2WNExpExp+NExpExp+SHOW.litmus", - "tests/2+2WNExpExp+NExpExp.litmus", + "tests/2+2WNExpExp+NExpNExp+DMBST+DMBST+SHOW.litmus", + "tests/2+2WNExpExp+NExpNExp+DMBST+DMBST.litmus", + "tests/2+2WNExpExp+NExpNExp+SHOW.litmus", + "tests/2+2WNExpExp+NExpNExp.litmus", "tests/Artem2+TLBIx-HDy+dsb.ish.litmus", "tests/Artem2+TLBIx-TLBIy+dmb2.litmus", "tests/Artem2+TLBIx-UCy+dsb.ish.litmus", diff --git a/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+DMBST+DMBST+SHOW.litmus b/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+DMBST+DMBST+SHOW.litmus similarity index 100% rename from catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+DMBST+DMBST+SHOW.litmus rename to catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+DMBST+DMBST+SHOW.litmus diff --git a/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+DMBST+DMBST.litmus b/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+DMBST+DMBST.litmus similarity index 100% rename from catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+DMBST+DMBST.litmus rename to catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+DMBST+DMBST.litmus diff --git a/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+SHOW.litmus b/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+SHOW.litmus similarity index 100% rename from catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp+SHOW.litmus rename to catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp+SHOW.litmus diff --git a/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp.litmus b/catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp.litmus similarity index 100% rename from catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpExp.litmus rename to catalogue/aarch64-VMSA/tests/2+2WNExpExp+NExpNExp.litmus