From 457cf5a0ddfd20f0921b9a834bfb242e99c56050 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 23 Oct 2026 07:21:47 +0000 Subject: [PATCH] Report the compile failure of the concurrent async request test When a compile failed in `concurrent_async_context`, the first failed join re-raised while other domains were still writing, and `with_temp_dir`'s cleanup then failed with ENOTEMPTY: `Fun.protect` reported only `Finally_raised` and the directory was left behind. The test now joins every domain before re-raising, and a failed body's cleanup is best effort. Signed-off-by: Christoph Knittel Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Xk6AeCYpCK4SZRtHYKHGoe --- .../async-domains-test-failure.internal.md | 1 + .../ounit_compiler_request_tests.ml | 29 +++++++++++++++++-- 2 files changed, 28 insertions(+), 2 deletions(-) create mode 100644 changes/async-domains-test-failure.internal.md diff --git a/changes/async-domains-test-failure.internal.md b/changes/async-domains-test-failure.internal.md new file mode 100644 index 0000000000..7c69411c30 --- /dev/null +++ b/changes/async-domains-test-failure.internal.md @@ -0,0 +1 @@ +- Make the concurrent async compiler request test report a failed compile instead of a cleanup error, and remove its temporary directory. diff --git a/tests/ounit_tests/ounit_compiler_request_tests.ml b/tests/ounit_tests/ounit_compiler_request_tests.ml index f6af978eca..8768304d41 100644 --- a/tests/ounit_tests/ounit_compiler_request_tests.ml +++ b/tests/ounit_tests/ounit_compiler_request_tests.ml @@ -62,7 +62,32 @@ let with_temp_dir prefix action = Sys.remove path; Unix.mkdir path 0o755; let path = Unix.realpath path in - Fun.protect ~finally:(fun () -> remove_tree path) (fun () -> action path) + (* A failure of the action is reported as it is: removing the directory + after it is best effort, so that a cleanup error, such as [ENOTEMPTY] + from a domain still writing, does not hide it. *) + match action path with + | result -> + remove_tree path; + result + | exception error -> + let backtrace = Printexc.get_raw_backtrace () in + (try remove_tree path with Unix.Unix_error _ | Sys_error _ -> ()); + Printexc.raise_with_backtrace error backtrace + +(* Joins every domain before re-raising the first failure, so that no domain + still runs when the caller cleans up after it. *) +let join_all domains = + let results = + List.map + (fun domain -> + match Domain.join domain with + | () -> None + | exception error -> Some (error, Printexc.get_raw_backtrace ())) + domains + in + match List.find_map Fun.id results with + | Some (error, backtrace) -> Printexc.raise_with_backtrace error backtrace + | None -> () let request_local_counter = Request_local.new_key (fun () -> ref 0) @@ -1596,7 +1621,7 @@ let concurrent_async_context_tests _context = else ["Sync.res"; "Async.res"]) done) in - List.init 8 run_domain |> List.iter Domain.join) + List.init 8 run_domain |> join_all) let suites = __FILE__