Merge pull request #112 from jmid/pbt-adjustments

Adjust PBTs based on recommended_domain_count

Author: Sudha247

test/dune

@@ -1,140 +1,127 @@
 (test
  (name test_chan)
  (libraries domainslib)
- (modules test_chan)
- (modes native))
+ (modules test_chan))
 
 (test
  (name fib)
- (modules fib)
- (modes native))
+ (modules fib))
 
 (test
  (name fib_par)
  (libraries domainslib)
- (modules fib_par)
- (modes native))
+ (modules fib_par))
 
 (test
  (name kcas_integration)
  (libraries domainslib kcas)
- (modules kcas_integration)
- (modes native))
+ (modules kcas_integration))
 
 (test
  (name enumerate_par)
  (libraries domainslib)
- (modules enumerate_par)
- (modes native))
+ (modules enumerate_par))
 
 (test
  (name game_of_life)
- (modules game_of_life)
- (modes native))
+ (modules game_of_life))
 
 (test
  (name game_of_life_multicore)
  (libraries domainslib)
- (modules game_of_life_multicore)
- (modes native))
+ (modules game_of_life_multicore))
 
 (test
  (name LU_decomposition_multicore)
  (libraries domainslib)
  (flags (:standard -runtime-variant d))
  (modules LU_decomposition_multicore)
- (modes native))
+ (enabled_if (or (= %{arch_sixtyfour} true) (<> %{architecture} arm))))
+   ;; disabled temporarily on arm32 due to failure: ocaml/ocaml#12267
 
 
 (test
  (name spectralnorm2)
- (modules spectralnorm2)
- (modes native))
+ (modules spectralnorm2))
 
 (test
-  (name sum_par)
-  (libraries domainslib)
-	(modules sum_par)
-	(modes native))
+ (name sum_par)
+ (libraries domainslib)
+ (modules sum_par))
 
 (test
  (name task_throughput)
  (libraries domainslib mirage-clock-unix)
- (modules task_throughput)
- (modes native))
+ (modules task_throughput))
 
 (test
  (name spectralnorm2_multicore)
  (libraries domainslib)
- (modules spectralnorm2_multicore)
- (modes native))
+ (modules spectralnorm2_multicore))
 
 (test
  (name summed_area_table)
  (libraries domainslib)
- (modules summed_area_table)
- (modes native))
+ (modules summed_area_table))
 
 (test
  (name prefix_sum)
  (libraries domainslib unix)
- (modules prefix_sum)
- (modes native))
+ (modules prefix_sum))
 
 (test
  (name test_task)
  (libraries domainslib)
- (modules test_task)
- (modes native))
+ (modules test_task))
 
 (test
  (name test_parallel_find)
  (libraries domainslib)
- (modules test_parallel_find)
- (modes native))
+ (modules test_parallel_find))
 
 (test
  (name test_deadlock)
  (libraries domainslib)
- (modules test_deadlock)
- (modes native))
+ (modules test_deadlock))
 
 (test
  (name test_task_crash)
  (libraries domainslib)
- (modules test_task_crash)
- (modes native))
+ (modules test_task_crash))
 
 (test
  (name test_task_empty)
  (libraries domainslib)
- (modules test_task_empty)
- (modes native))
+ (modules test_task_empty))
 
 (test
  (name backtrace)
  (libraries domainslib)
  (modules backtrace)
- (modes native))
+ (enabled_if (and (= %{arch_sixtyfour} true) (<> %{architecture} power) (<> %{architecture} s390x))))
+ ;; disabled temporarily on bytecode switches https://github.com/ocaml/dune/issues/7845
 
 (test
  (name off_by_one)
  (libraries domainslib)
- (modules off_by_one)
- (modes native))
+ (modules off_by_one))
 
 ;; Custom property-based tests using QCheck
 
 (test
  (name task_one_dep)
  (modules task_one_dep)
  (libraries qcheck-multicoretests-util qcheck-core qcheck-core.runner domainslib)
+ (enabled_if (and (= %{arch_sixtyfour} true) (<> %{architecture} power) (<> %{architecture} s390x)))
+ ;; takes forever on bytecode
  (action (run %{test} --verbose)))
 
 (test
  (name task_more_deps)
  (modules task_more_deps)
  (libraries qcheck-multicoretests-util qcheck-core qcheck-core.runner domainslib)
+ (enabled_if (and (= %{arch_sixtyfour} true) (<> %{architecture} power) (<> %{architecture} s390x)))
+ ;; takes forever on bytecode
  (action (run %{test} --verbose)))
 
 (test

test/off_by_one.ml

@@ -10,11 +10,18 @@ let print_array a =
 let r = Array.init 20 (fun i -> i + 1)
 
 let scan_task num_doms =
-  let pool = Task.setup_pool ~num_domains:num_doms () in
-  let a = Task.run pool (fun () -> Task.parallel_scan pool (+) (Array.make 20 1)) in
-  Task.teardown_pool pool;
-  Printf.printf "%i:  %s\n%!" num_doms (print_array a);
-  assert (a = r)
+  try
+    let pool = Task.setup_pool ~num_domains:num_doms () in
+    let a = Task.run pool (fun () -> Task.parallel_scan pool (+) (Array.make 20 1)) in
+    Task.teardown_pool pool;
+    Printf.printf "%i:  %s\n%!" num_doms (print_array a);
+    assert (a = r)
+  with Failure msg ->
+    begin
+      assert (msg = "failed to allocate domain");
+      Printf.printf "Failed to allocate %i domains, recommended_domain_count: %i\n%!"
+        num_doms (Domain.recommended_domain_count ());
+    end
 ;;
 for num_dom=0 to 21 do
   scan_task num_dom;

test/task_one_dep.ml

@@ -111,37 +111,45 @@ let test_two_pools_sync_last ~domain_bound ~promise_bound =
     (pair gen gen)
     (Util.repeat 10 @@
      fun (input1,input2) ->
-     let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in
-     let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in
-     let ps1 = build_dep_graph pool1 input1 in
-     let ps2 = build_dep_graph pool2 input2 in
-     Task.run pool1 (fun () -> List.iter (fun p -> Task.await pool1 p) ps1);
-     Task.run pool2 (fun () -> List.iter (fun p -> Task.await pool2 p) ps2);
-     Task.teardown_pool pool1;
-     Task.teardown_pool pool2;
-     true)
+     try
+       let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in
+       let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in
+       let ps1 = build_dep_graph pool1 input1 in
+       let ps2 = build_dep_graph pool2 input2 in
+       Task.run pool1 (fun () -> List.iter (fun p -> Task.await pool1 p) ps1);
+       Task.run pool2 (fun () -> List.iter (fun p -> Task.await pool2 p) ps2);
+       Task.teardown_pool pool1;
+       Task.teardown_pool pool2;
+       true
+     with
+       Failure err -> err = "failed to allocate domain")
 
 let test_two_nested_pools ~domain_bound ~promise_bound =
   let gen = arb_deps domain_bound promise_bound in
   Test.make ~name:"Domainslib.Task.async/await, one dep, w.2 nested pools" ~count:100
     (pair gen gen)
     (Util.repeat 10 @@
      fun (input1,input2) ->
-     let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in
-     let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in
-     Task.run pool1 (fun () ->
-         Task.run pool2 (fun () ->
-             let ps1 = build_dep_graph pool1 input1 in
-             let ps2 = build_dep_graph pool2 input2 in
-             List.iter (fun p -> Task.await pool1 p) ps1;
-             List.iter (fun p -> Task.await pool2 p) ps2));
-     Task.teardown_pool pool1;
-     Task.teardown_pool pool2;
-     true)
+     try
+       let pool1 = Task.setup_pool ~num_domains:input1.num_domains () in
+       let pool2 = Task.setup_pool ~num_domains:input2.num_domains () in
+       Task.run pool1 (fun () ->
+           Task.run pool2 (fun () ->
+               let ps1 = build_dep_graph pool1 input1 in
+               let ps2 = build_dep_graph pool2 input2 in
+               List.iter (fun p -> Task.await pool1 p) ps1;
+               List.iter (fun p -> Task.await pool2 p) ps2));
+       Task.teardown_pool pool1;
+       Task.teardown_pool pool2;
+       true
+     with
+       Failure err -> err = "failed to allocate domain")
 
 let () =
+  let domain_bound = max 1 (Domain.recommended_domain_count () / 2) in
+  let promise_bound = max 2 domain_bound in
   QCheck_base_runner.run_tests_main [
-    test_one_pool            ~domain_bound:8 ~promise_bound:10;
-    test_two_pools_sync_last ~domain_bound:2 ~promise_bound:2;
-    test_two_nested_pools    ~domain_bound:8 ~promise_bound:10;
+    test_one_pool            ~domain_bound ~promise_bound;
+    test_two_pools_sync_last ~domain_bound ~promise_bound;
+    test_two_nested_pools    ~domain_bound ~promise_bound;
   ]