From f5db9d010c01e345bf65b2eea95d4d6e0e47e6b4 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 20 May 2026 07:24:44 +0200 Subject: [PATCH 1/2] Use qcheck's nat_small instead of deprecated small_nat --- dune-project | 2 +- test/task_parallel.ml | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dune-project b/dune-project index 62adb54..f1191a6 100644 --- a/dune-project +++ b/dune-project @@ -18,6 +18,6 @@ (domain-local-await (>= 0.1.0)) (kcas (and (>= 0.3.0) :with-test)) (mirage-clock-unix (and :with-test (>= "4.2.0"))) - (qcheck-core (and :with-test (>= "0.20"))) + (qcheck-core (and :with-test (>= "0.90"))) (qcheck-multicoretests-util (and :with-test (>= "0.1"))) (qcheck-stm (and :with-test (>= "0.1"))))) diff --git a/test/task_parallel.ml b/test/task_parallel.ml index 3888d6f..e8d9810 100644 --- a/test/task_parallel.ml +++ b/test/task_parallel.ml @@ -7,7 +7,7 @@ let count = 250 let test_parallel_for = Test.make ~name:"Domainslib.Task.parallel_for test" ~count - (triple (int_bound 10) small_nat small_nat) + (triple (int_bound 10) nat_small nat_small) (fun (num_domains,array_size,chunk_size) -> let pool = Task.setup_pool ~num_domains () in let res = Task.run pool (fun () -> @@ -19,7 +19,7 @@ let test_parallel_for = let test_parallel_for_reduce = Test.make ~name:"Domainslib.Task.parallel_for_reduce test" ~count - (triple (int_bound 10) small_nat small_nat) + (triple (int_bound 10) nat_small nat_small) (fun (num_domains,array_size,chunk_size) -> let pool = Task.setup_pool ~num_domains () in let res = Task.run pool (fun () -> @@ -29,7 +29,7 @@ let test_parallel_for_reduce = let test_parallel_scan = Test.make ~name:"Domainslib.Task.parallel_scan test" ~count - (pair (int_bound 10) small_nat) + (pair (int_bound 10) nat_small) (fun (num_domains,array_size) -> let pool = Task.setup_pool ~num_domains () in let a = Task.run pool (fun () -> Task.parallel_scan pool (+) (Array.make array_size 1)) in From 26fac4642bbe722242440f2f56c692e5e79520ed Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 20 May 2026 06:55:11 +0200 Subject: [PATCH 2/2] Task.setup_pool: do not fail on domain allocation failure Fixes: https://github.com/ocaml-multicore/domainslib/issues/133 --- lib/task.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/task.ml b/lib/task.ml index dfa069c..116952a 100644 --- a/lib/task.ml +++ b/lib/task.ml @@ -12,7 +12,7 @@ type message = type task_chan = message Multi_channel.t type pool_data = { - domains : unit Domain.t array; + domains : unit Domain.t option array; task_chan : task_chan; name: string option } @@ -143,7 +143,7 @@ let setup_pool ?name ~num_domains () = else let task_chan = Multi_channel.make (num_domains+1) in let domains = Array.init num_domains (fun _ -> - Domain.spawn (fun _ -> worker task_chan)) + try Some (Domain.spawn (fun _ -> worker task_chan)) with Failure _ -> None) in let p = Atomic.make (Some {domains; task_chan; name}) in begin match name with @@ -161,7 +161,7 @@ let teardown_pool pool = Multi_channel.send pd.task_chan Quit done; Multi_channel.clear_local_state pd.task_chan; - Array.iter Domain.join pd.domains; + Array.iter (Option.iter Domain.join) pd.domains; (* Remove the pool from the table *) begin match pd.name with | None -> ()