From 8a5436fafbe36741855c94846089e7dc90f8be91 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Fri, 24 Feb 2023 19:49:58 +0100 Subject: [PATCH 1/8] Add a custom runner for tests This custom runner allows to display the result of a test in the same way on Unix and Windows (by mapping Windows error codes to their equivalent result on Unix) It also uses GitHub CI formats when available so that test failures are referenced as such at their positions in the logs --- tools/dune | 5 ++ tools/runner.ml | 131 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) create mode 100644 tools/dune create mode 100644 tools/runner.ml diff --git a/tools/dune b/tools/dune new file mode 100644 index 000000000..63b25f432 --- /dev/null +++ b/tools/dune @@ -0,0 +1,5 @@ +(executable + (name runner) + (public_name runner) + (package multicoretests) + (libraries unix)) diff --git a/tools/runner.ml b/tools/runner.ml new file mode 100644 index 000000000..9df1737e9 --- /dev/null +++ b/tools/runner.ml @@ -0,0 +1,131 @@ +(* Custom runner for the tests so that: + - error codes on Windows are turned back into their Unix meaninrgs + - anchors are added to CI logs with relevant information *) + +let use_github_anchors = Sys.getenv_opt "CI" = Some "true" + +let signals = + let open Sys in + [ + (sigabrt, "ABRT"); + (sigalrm, "ALRM"); + (sigfpe, "FPE"); + (sighup, "HUP"); + (sigill, "ILL"); + (sigint, "INT"); + (sigkill, "KILL"); + (sigpipe, "PIPE"); + (sigquit, "QUIT"); + (sigsegv, "SEGV"); + (sigterm, "TERM"); + (sigusr1, "USR1"); + (sigusr2, "USR2"); + (sigchld, "CHLD"); + (sigcont, "CONT"); + (sigstop, "STOP"); + (sigtstp, "TSTP"); + (sigttin, "TTIN"); + (sigttou, "TTOU"); + (sigvtalrm, "VTALRM"); + (sigprof, "PROF"); + (sigbus, "BUS"); + (sigpoll, "POLL"); + (sigsys, "SYS"); + (sigtrap, "TRAP"); + (sigurg, "URG"); + (sigxcpu, "XCPU"); + (sigxfsz, "XFSZ"); + ] + +let error fmt cmd msg = + if use_github_anchors then + Format.fprintf fmt "\n::error title=%s in %s::%s in %s\n%!" msg cmd msg cmd + else Format.fprintf fmt "\nError: %s in %s\n%!" msg cmd + +let pp_status_unix fmt cmd status = + let open Unix in + (match status with + | WEXITED 0 -> () + | WEXITED s -> error fmt cmd (Printf.sprintf "Exit %d" s) + | WSIGNALED s -> + let msg = + match List.assoc_opt s signals with + | Some signal -> "Signal " ^ signal + | None -> Printf.sprintf "Unknown signal %d" s + in + error fmt cmd msg + | WSTOPPED s -> + let msg = + match List.assoc_opt s signals with + | Some signal -> "Stop with signal " ^ signal + | None -> Printf.sprintf "Stop with unknown signal %d" s + in + error fmt cmd msg); + status = WEXITED 0 + +(* Under Windows, there is no such thing as terminating due to a + signal, so the WSIGNALED and WSTOPPED cases are dead code. + + The strategy is to use conventional exit values (which are 32-bit, + not just 8-bit like on Unix) to describe the cause. + The documentation of ”NTSTATUS Values” list {e many} cases, too + many to handle them all. This is where the value akin to SEGV comes + from. Other special cases will be caught as they appear. + + The value used to match ABRT comes from the code of the abort + function in the standard library. + + {{:https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-erref/596a1078-e883-4972-9bbc-49e60bebca55}NTSTATUS Values} +*) +let pp_status_win fmt cmd status = + let open Unix in + (match status with + | WEXITED 0 -> () + | WEXITED 3 -> error fmt cmd "Signal ABRT" + | WEXITED -1073741819 (* 0xC0000005 *) -> error fmt cmd "Signal SEGV" + | WEXITED s -> error fmt cmd (Printf.sprintf "Exit %d" s) + (* Those last 2 cases are dead code on Windows *) + | WSIGNALED s -> + let msg = + match List.assoc_opt s signals with + | Some signal -> "Signal " ^ signal + | None -> Printf.sprintf "Unknown signal %d" s + in + error fmt cmd msg + | WSTOPPED s -> + let msg = + match List.assoc_opt s signals with + | Some signal -> "Stop with signal " ^ signal + | None -> Printf.sprintf "Stop with unknown signal %d" s + in + error fmt cmd msg); + status = WEXITED 0 + +let pp_status = if Sys.win32 then pp_status_win else pp_status_unix + +let run ofmt efmt argv = + let argv = + match argv with [| cmd |] -> [| cmd; "--verbose" |] | _ -> argv + in + let testdir = Filename.basename (Sys.getcwd ()) in + let exe, cmd = + if Filename.is_implicit argv.(0) then + ( Filename.concat Filename.current_dir_name argv.(0), + Filename.concat testdir argv.(0) ) + else (argv.(0), argv.(0)) + in + let cmdline = String.concat " " (Array.to_list argv) in + Format.fprintf ofmt "\n\nStarting (in %s) %s:\n%!" testdir cmdline; + let pid = Unix.(create_process exe argv stdin stdout stderr) in + let _, status = Unix.waitpid [] pid in + pp_status efmt cmd status + +let _ = + let open Format in + if Array.length Sys.argv < 2 then ( + fprintf err_formatter + "\nError: %s expects the\n command to run as argument\n%!" Sys.argv.(0); + exit 1); + let cmd = Array.sub Sys.argv 1 (Array.length Sys.argv - 1) in + let success = run std_formatter err_formatter cmd in + if not success then exit 1 From b7da2bad4671e53b448d69399c84b2acd0f15157 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Mon, 27 Feb 2023 12:43:59 +0100 Subject: [PATCH 2/8] Use the custom runner for the test suite Unfortunately, syntax such as `%{dep:%{test}}` is not understood in an action, and simply using: `(action (run runner %{test}))` does not add the test executable to the dependencies of the action, so dune does not build it We keep the standard runner for the _internal_ tests, as the custom runner would bring no benefit there --- src/array/dune | 6 +++--- src/atomic/dune | 6 +++--- src/bigarray/dune | 4 ++-- src/buffer/dune | 2 +- src/bytes/dune | 4 ++-- src/domain/dune | 4 ++-- src/dynlink/dune | 2 +- src/ephemeron/dune | 4 ++-- src/floatarray/dune | 4 ++-- src/hashtbl/dune | 6 +++--- src/io/dune | 6 +++--- src/lazy/dune | 6 +++--- src/neg_tests/dune | 35 ++++++++++++++++++++++------------- src/queue/dune | 4 ++-- src/semaphore/dune | 2 +- src/stack/dune | 4 ++-- src/sys/dune | 2 +- src/thread/dune | 4 ++-- src/threadomain/dune | 2 +- src/weak/dune | 8 ++++---- 20 files changed, 62 insertions(+), 53 deletions(-) diff --git a/src/array/dune b/src/array/dune index 91892dbe7..8dd985ebb 100644 --- a/src/array/dune +++ b/src/array/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -16,7 +16,7 @@ (flags (:standard -w -27)) (libraries qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/array/%{test} from the test suite\n\n")) ) @@ -25,5 +25,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/atomic/dune b/src/atomic/dune index b9ab37456..8855e19eb 100644 --- a/src/atomic/dune +++ b/src/atomic/dune @@ -8,7 +8,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) ;; Linearization tests of Atomic, utilizing ppx_deriving_qcheck @@ -20,7 +20,7 @@ (flags (:standard -w -27)) (libraries qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/atomic/%{test} from the test suite\n\n")) ) @@ -29,5 +29,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/bigarray/dune b/src/bigarray/dune index 5016d76d8..4157c035b 100644 --- a/src/bigarray/dune +++ b/src/bigarray/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:stm_tests.exe})) (action (echo "Skipping src/bigarray/%{test} from the test suite\n\n")) ) @@ -15,5 +15,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/buffer/dune b/src/buffer/dune index 725058f70..e643c2e1c 100644 --- a/src/buffer/dune +++ b/src/buffer/dune @@ -6,5 +6,5 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) diff --git a/src/bytes/dune b/src/bytes/dune index d20e3c6e8..c5359d768 100644 --- a/src/bytes/dune +++ b/src/bytes/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -14,5 +14,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain qcheck-lin.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/domain/dune b/src/domain/dune index 35630838d..239bbf820 100644 --- a/src/domain/dune +++ b/src/domain/dune @@ -8,7 +8,7 @@ (package multicoretests) (libraries util qcheck-core qcheck-core.runner) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:domain_joingraph.exe})) ) (test @@ -17,5 +17,5 @@ (package multicoretests) (libraries util qcheck-core qcheck-core.runner) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:domain_spawntree.exe})) ) diff --git a/src/dynlink/dune b/src/dynlink/dune index 34cb1679a..eab7e453d 100644 --- a/src/dynlink/dune +++ b/src/dynlink/dune @@ -15,5 +15,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain dynlink libA libB) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/ephemeron/dune b/src/ephemeron/dune index 27f1f7f1b..5a2927ae4 100644 --- a/src/ephemeron/dune +++ b/src/ephemeron/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -14,5 +14,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain qcheck-lin.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/floatarray/dune b/src/floatarray/dune index eb4811ff2..ecca151ba 100644 --- a/src/floatarray/dune +++ b/src/floatarray/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -14,5 +14,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/hashtbl/dune b/src/hashtbl/dune index b3373a377..40087580a 100644 --- a/src/hashtbl/dune +++ b/src/hashtbl/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -16,7 +16,7 @@ (flags (:standard -w -27)) (libraries qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/hashtbl/%{test} from the test suite\n\n")) ) @@ -25,5 +25,5 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) diff --git a/src/io/dune b/src/io/dune index 4985a5b0d..7362036a8 100644 --- a/src/io/dune +++ b/src/io/dune @@ -6,7 +6,7 @@ (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.domain) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/io/%{test} from the test suite\n\n")) ) @@ -23,7 +23,7 @@ (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.domain lin_tests_dsl_common_io) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl_domain.exe})) ) (test @@ -32,6 +32,6 @@ (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.thread lin_tests_dsl_common_io) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests_dsl_thread.exe})) (action (echo "Skipping src/io/%{test} from the test suite\n\n")) ) diff --git a/src/lazy/dune b/src/lazy/dune index 937d13dd8..9ca6374cc 100644 --- a/src/lazy/dune +++ b/src/lazy/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -15,7 +15,7 @@ (package multicoretests) (libraries qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/lazy/%{test} from the test suite\n\n")) ) @@ -24,6 +24,6 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests_dsl.exe})) (action (echo "Skipping src/lazy/%{test} from the test suite\n\n")) ) diff --git a/src/neg_tests/dune b/src/neg_tests/dune index 7c36a7454..1529e7c15 100644 --- a/src/neg_tests/dune +++ b/src/neg_tests/dune @@ -13,7 +13,7 @@ (modules stm_tests_sequential_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.sequential) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests_sequential_ref.exe})) ) (test @@ -21,7 +21,7 @@ (modules stm_tests_domain_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests_domain_ref.exe})) ) (test @@ -29,7 +29,7 @@ (modules stm_tests_thread_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests_thread_ref.exe})) ) (library @@ -44,7 +44,7 @@ (package multicoretests) (libraries CList qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests_conclist.exe})) ) ;; Linearization tests of ref and Clist with Lin @@ -70,7 +70,7 @@ (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_dsl_common) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl_domain.exe})) ) (test @@ -79,7 +79,7 @@ (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_dsl_common qcheck-lin.thread) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests_dsl_thread.exe})) (action (echo "Skipping src/neg_tests/%{test} from the test suite\n\n")) ) @@ -89,7 +89,7 @@ (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_dsl_common qcheck-lin.effect) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl_effect.exe})) ) ;; Linearization tests of ref and Clist with Lin.Internal @@ -100,17 +100,26 @@ (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_common) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests_domain.exe})) (action (echo "Skipping src/neg_tests/%{test} from the test suite\n\n")) ) -(tests - (names lin_tests_thread_ref lin_tests_thread_conclist) - (modules lin_tests_thread_ref lin_tests_thread_conclist) +(test + (name lin_tests_thread_ref) + (modules lin_tests_thread_ref) + (package multicoretests) + (flags (:standard -w -27)) + (libraries lin_tests_common qcheck-lin.thread) + (action (run runner %{dep:lin_tests_thread_ref.exe})) +) + +(test + (name lin_tests_thread_conclist) + (modules lin_tests_thread_conclist) (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_common qcheck-lin.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_thread_conclist.exe})) ) (test @@ -120,6 +129,6 @@ (flags (:standard -w -27)) (libraries lin_tests_common qcheck-lin.effect) (preprocess (pps ppx_deriving.show ppx_deriving.eq)) - ; (action (run ./%{deps} --verbose)) + ; (action (run runner %{dep:lin_tests_effect.exe})) (action (echo "Skipping src/neg_tests/%{test} from the test suite\n\n")) ) diff --git a/src/queue/dune b/src/queue/dune index 246e7bf06..77005663e 100644 --- a/src/queue/dune +++ b/src/queue/dune @@ -6,7 +6,7 @@ (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) (test @@ -16,6 +16,6 @@ (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ;(action (run %{test} --verbose)) + ;(action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/queue/%{test} from the test suite\n\n")) ) diff --git a/src/semaphore/dune b/src/semaphore/dune index 6e4d5e285..c2cac616f 100644 --- a/src/semaphore/dune +++ b/src/semaphore/dune @@ -6,5 +6,5 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) diff --git a/src/stack/dune b/src/stack/dune index ac02856a6..a25a0f0da 100644 --- a/src/stack/dune +++ b/src/stack/dune @@ -6,7 +6,7 @@ (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) (test @@ -16,7 +16,7 @@ (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) - ; (action (run %{test} --verbose)) + ; (action (run runner %{dep:lin_tests.exe})) (action (echo "Skipping src/stack/%{test} from the test suite\n\n")) ) diff --git a/src/sys/dune b/src/sys/dune index bac13a868..bf9713f1f 100644 --- a/src/sys/dune +++ b/src/sys/dune @@ -6,5 +6,5 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) diff --git a/src/thread/dune b/src/thread/dune index a2d5087a0..dc6c9d26c 100644 --- a/src/thread/dune +++ b/src/thread/dune @@ -8,7 +8,7 @@ (package multicoretests) (libraries threads qcheck-core util) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:thread_joingraph.exe})) ) (test @@ -17,5 +17,5 @@ (package multicoretests) (libraries threads qcheck-core util) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:thread_createtree.exe})) ) diff --git a/src/threadomain/dune b/src/threadomain/dune index 2034a3e5e..be0d8fbcc 100644 --- a/src/threadomain/dune +++ b/src/threadomain/dune @@ -6,5 +6,5 @@ (package multicoretests) (libraries util qcheck-core threads) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:threadomain.exe})) ) diff --git a/src/weak/dune b/src/weak/dune index d054148f3..9a6a2474a 100644 --- a/src/weak/dune +++ b/src/weak/dune @@ -6,7 +6,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests.exe})) ) (test @@ -15,7 +15,7 @@ (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) - (action (run %{test} --verbose)) + (action (run runner %{dep:stm_tests_hashset.exe})) ) (test @@ -23,7 +23,7 @@ (modules lin_tests_dsl) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl.exe})) ) (test @@ -31,5 +31,5 @@ (modules lin_tests_dsl_hashset) (package multicoretests) (libraries qcheck-lin.domain) - (action (run %{test} --verbose)) + (action (run runner %{dep:lin_tests_dsl_hashset.exe})) ) From cfabed76e6d139e258897ad9a03051e6251bea74 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 1 Mar 2023 15:15:23 +0100 Subject: [PATCH 3/8] Teach the runner to avoid running out of time --- tools/runner.ml | 51 +++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 6 deletions(-) diff --git a/tools/runner.ml b/tools/runner.ml index 9df1737e9..575a1e7ed 100644 --- a/tools/runner.ml +++ b/tools/runner.ml @@ -42,11 +42,25 @@ let error fmt cmd msg = Format.fprintf fmt "\n::error title=%s in %s::%s in %s\n%!" msg cmd msg cmd else Format.fprintf fmt "\nError: %s in %s\n%!" msg cmd +let warning fmt cmd msg = + if use_github_anchors then + Format.fprintf fmt "\n::warning title=%s in %s::%s in %s\n%!" msg cmd msg + cmd + else Format.fprintf fmt "\nWarning: %s in %s\n%!" msg cmd + +let timed_out = Atomic.make false + let pp_status_unix fmt cmd status = let open Unix in + let success = ref false in (match status with - | WEXITED 0 -> () + | WEXITED 0 -> success := true | WEXITED s -> error fmt cmd (Printf.sprintf "Exit %d" s) + | WSIGNALED s when Atomic.get timed_out && (s = Sys.sigkill || s = Sys.sigterm) + -> + warning fmt cmd "Deadline reached, test interrupted"; + (* We nevertheless want the test to globally succeed *) + success := true | WSIGNALED s -> let msg = match List.assoc_opt s signals with @@ -61,7 +75,7 @@ let pp_status_unix fmt cmd status = | None -> Printf.sprintf "Stop with unknown signal %d" s in error fmt cmd msg); - status = WEXITED 0 + !success (* Under Windows, there is no such thing as terminating due to a signal, so the WSIGNALED and WSTOPPED cases are dead code. @@ -103,6 +117,26 @@ let pp_status_win fmt cmd status = let pp_status = if Sys.win32 then pp_status_win else pp_status_unix +let now = int_of_float (Unix.time ()) + +let deadline = + let getint v = Option.bind (Sys.getenv_opt v) int_of_string_opt in + let global = Option.value ~default:max_int (getint "DEADLINE") in + match getint "TEST_TIMEOUT" with + | None -> global + | Some t -> min global (now + (t * 60)) + +let deadline_watcher pid () = + let open Unix in + assert (deadline > now); + sleep (deadline - now); + Atomic.set timed_out true; + if not Sys.win32 then ( + (* let's give it a little time to stop *) + kill pid Sys.sigterm; + sleep 2); + kill pid Sys.sigkill + let run ofmt efmt argv = let argv = match argv with [| cmd |] -> [| cmd; "--verbose" |] | _ -> argv @@ -115,10 +149,15 @@ let run ofmt efmt argv = else (argv.(0), argv.(0)) in let cmdline = String.concat " " (Array.to_list argv) in - Format.fprintf ofmt "\n\nStarting (in %s) %s:\n%!" testdir cmdline; - let pid = Unix.(create_process exe argv stdin stdout stderr) in - let _, status = Unix.waitpid [] pid in - pp_status efmt cmd status + if now < deadline then ( + Format.fprintf ofmt "\n\nStarting (in %s) %s:\n%!" testdir cmdline; + let pid = Unix.(create_process exe argv stdin stdout stderr) in + ignore @@ Domain.spawn (deadline_watcher pid); + let _, status = Unix.waitpid [] pid in + pp_status efmt cmd status) + else ( + warning ofmt cmd "Deadline reached, skipping test"; + true) let _ = let open Format in From fcde3175e30c17b50b3466ccaaec1af11b5e31d5 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 1 Mar 2023 15:52:15 +0100 Subject: [PATCH 4/8] Teach the runner to log test durations --- tools/runner.ml | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/tools/runner.ml b/tools/runner.ml index 575a1e7ed..aaf036940 100644 --- a/tools/runner.ml +++ b/tools/runner.ml @@ -116,20 +116,19 @@ let pp_status_win fmt cmd status = status = WEXITED 0 let pp_status = if Sys.win32 then pp_status_win else pp_status_unix - -let now = int_of_float (Unix.time ()) +let start_time = int_of_float (Unix.time ()) let deadline = let getint v = Option.bind (Sys.getenv_opt v) int_of_string_opt in let global = Option.value ~default:max_int (getint "DEADLINE") in match getint "TEST_TIMEOUT" with | None -> global - | Some t -> min global (now + (t * 60)) + | Some t -> min global (start_time + (t * 60)) let deadline_watcher pid () = let open Unix in - assert (deadline > now); - sleep (deadline - now); + assert (deadline > start_time); + sleep (deadline - start_time); Atomic.set timed_out true; if not Sys.win32 then ( (* let's give it a little time to stop *) @@ -137,6 +136,24 @@ let deadline_watcher pid () = sleep 2); kill pid Sys.sigkill +let log_time cmd = + match Sys.getenv_opt "TIMELOGDIR" with + | None -> () + | Some d -> + let f = Filename.concat d "times.log" in + let flags = [ Open_wronly; Open_append; Open_creat; Open_binary ] in + Out_channel.with_open_gen flags 0o666 f @@ fun oc -> + let dur = int_of_float (Unix.time ()) - start_time in + let hours = dur / 3600 + and minutes = dur mod 3600 / 60 + and seconds = dur mod 60 in + if hours > 0 then + Printf.fprintf oc "%-40s finished in %d:%02d:%02d (%ds)\n" cmd hours + minutes seconds dur + else + Printf.fprintf oc "%-40s finished in %02d:%02d (%ds)\n" cmd minutes + seconds dur + let run ofmt efmt argv = let argv = match argv with [| cmd |] -> [| cmd; "--verbose" |] | _ -> argv @@ -149,11 +166,12 @@ let run ofmt efmt argv = else (argv.(0), argv.(0)) in let cmdline = String.concat " " (Array.to_list argv) in - if now < deadline then ( + if start_time < deadline then ( Format.fprintf ofmt "\n\nStarting (in %s) %s:\n%!" testdir cmdline; let pid = Unix.(create_process exe argv stdin stdout stderr) in ignore @@ Domain.spawn (deadline_watcher pid); let _, status = Unix.waitpid [] pid in + log_time cmd; pp_status efmt cmd status) else ( warning ofmt cmd "Deadline reached, skipping test"; From 7aa68a6a5c6fdd3b0345456c24eb280d593a1a7f Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 1 Mar 2023 17:13:28 +0100 Subject: [PATCH 5/8] Add a rule to display the final times.log Also add a rule to build a dummy file in case the TIMELOGDIR was never set --- tools/dune | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tools/dune b/tools/dune index 63b25f432..d1da59de1 100644 --- a/tools/dune +++ b/tools/dune @@ -3,3 +3,12 @@ (public_name runner) (package multicoretests) (libraries unix)) + +(rule + (action + (write-file times.log "Dummy file for missing timing data"))) + +(rule + (alias cat-times) + (action + (cat %{env:TIMELOGDIR=.}/times.log))) From 2695a8e65873a88487d9e44270a53bd03dac2b57 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 1 Mar 2023 17:41:48 +0100 Subject: [PATCH 6/8] Use the test runner to avoid hitting the CI hard limit mid-test suite --- .github/workflows/common.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/common.yml b/.github/workflows/common.yml index 946bcaac1..37a373a56 100644 --- a/.github/workflows/common.yml +++ b/.github/workflows/common.yml @@ -81,6 +81,7 @@ jobs: build-and-test: env: QCHECK_MSG_INTERVAL: '60' + TIMEOUT: ${{ inputs.timeout }} DUNE_PROFILE: ${{ inputs.dune_profile }} OCAMLRUNPARAM: ${{ inputs.runparam }} ONLY_TEST: ${{ inputs.only_test }} @@ -118,6 +119,10 @@ jobs: echo "LDFLAGS=-L/usr/lib/i386-linux-gnu/" >> $GITHUB_ENV fi + # Compute a deadline to respect time-out + echo "DEADLINE=$(date -d "now + $((TIMEOUT - 3)) minutes" +%s)" >> "$GITHUB_ENV" + cat "$GITHUB_ENV" + # Generate an OPAM config for a custom compiler if [ -n "$CUSTOM_COMPILER_VERSION" ]; then if [ -z "$CUSTOM_COMPILER_SRC" ]; then From 724a043ffddde941f70f94ada3dbfd4404ddabb8 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Wed, 1 Mar 2023 17:47:19 +0100 Subject: [PATCH 7/8] Display running times at the end of the test suite --- .github/workflows/common.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.github/workflows/common.yml b/.github/workflows/common.yml index 37a373a56..8ee21d6d0 100644 --- a/.github/workflows/common.yml +++ b/.github/workflows/common.yml @@ -81,6 +81,7 @@ jobs: build-and-test: env: QCHECK_MSG_INTERVAL: '60' + TIMELOGDIR: ${{ github.workspace }} TIMEOUT: ${{ inputs.timeout }} DUNE_PROFILE: ${{ inputs.dune_profile }} OCAMLRUNPARAM: ${{ inputs.runparam }} @@ -208,6 +209,7 @@ jobs: echo "OPAMJOBS=1" >> $GITHUB_ENV - name: Install Multicore Tests dependencies + id: dependencies run: | opam install . --deps-only --with-test @@ -277,3 +279,7 @@ jobs: } echo "Test failed $failures times" if: env.ONLY_TEST != '' && runner.os == 'Windows' + + - name: Summarize test run times + run: opam exec -- dune build @cat-times + if: "success() || (failure() && steps.dependencies.conclusion == 'success')" From 2109996a5ae537829348657705e32da16d06c9a7 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Thu, 2 Mar 2023 16:17:44 +0100 Subject: [PATCH 8/8] runner: Use floats for times to be compatible with 32 bits Unix.time () does not fit inside a 31-bit int (which must be why it is using float in the first place), so use floats for times --- tools/runner.ml | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/tools/runner.ml b/tools/runner.ml index aaf036940..717f842bc 100644 --- a/tools/runner.ml +++ b/tools/runner.ml @@ -116,25 +116,26 @@ let pp_status_win fmt cmd status = status = WEXITED 0 let pp_status = if Sys.win32 then pp_status_win else pp_status_unix -let start_time = int_of_float (Unix.time ()) +let start_time = Unix.time () let deadline = - let getint v = Option.bind (Sys.getenv_opt v) int_of_string_opt in - let global = Option.value ~default:max_int (getint "DEADLINE") in - match getint "TEST_TIMEOUT" with + let getfloat v = Option.bind (Sys.getenv_opt v) float_of_string_opt in + let global = Option.value ~default:Float.infinity (getfloat "DEADLINE") in + match getfloat "TEST_TIMEOUT" with | None -> global - | Some t -> min global (start_time + (t * 60)) + | Some t -> min global (start_time +. (t *. 60.)) let deadline_watcher pid () = let open Unix in assert (deadline > start_time); - sleep (deadline - start_time); - Atomic.set timed_out true; - if not Sys.win32 then ( - (* let's give it a little time to stop *) - kill pid Sys.sigterm; - sleep 2); - kill pid Sys.sigkill + if Float.is_finite deadline then ( + sleepf (deadline -. start_time); + Atomic.set timed_out true; + if not Sys.win32 then ( + (* let's give it a little time to stop *) + kill pid Sys.sigterm; + sleep 2); + kill pid Sys.sigkill) let log_time cmd = match Sys.getenv_opt "TIMELOGDIR" with @@ -143,7 +144,7 @@ let log_time cmd = let f = Filename.concat d "times.log" in let flags = [ Open_wronly; Open_append; Open_creat; Open_binary ] in Out_channel.with_open_gen flags 0o666 f @@ fun oc -> - let dur = int_of_float (Unix.time ()) - start_time in + let dur = int_of_float (Unix.time () -. start_time) in let hours = dur / 3600 and minutes = dur mod 3600 / 60 and seconds = dur mod 60 in