forked from ocaml-multicore/multicoretests
-
Notifications
You must be signed in to change notification settings - Fork 0
/
task_more_deps.ml
109 lines (97 loc) · 3.3 KB
/
task_more_deps.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
(**
Generate tests of async+await from Domainslib.Task.
It does so by generating a random, acyclic dependency graph of [async] tasks,
each [await]ing on its dependency.
*)
open QCheck
open Domainslib
(* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *)
let rec tak x y z =
if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
else z
let work () =
for _ = 1 to 200 do
assert (7 = tak 18 12 6);
done
(* Generates a DAG of dependencies *)
(* Each task is represented by an array index w/a deps.list *)
(* This example DAG
A/0 <--- B/1 <
^. \
\ \
`- C/2 <--- D/3
is represented as: [| []; [0]; [0]; [1;2] |] *)
let gen_dag n st =
Array.init n (fun i ->
let deps = ref [] in
for dep = 0 to i-1 do
if Gen.bool st then deps := dep :: !deps
done;
List.rev !deps)
type test_input =
{
num_domains : int;
length : int;
dependencies : int list array
} [@@deriving show { with_path = false }]
(* FIXME:
- Make sparsety a random param - not just a bool in gen_deps
*)
let shrink_deps test_input =
let ls = Array.to_list test_input.dependencies in
let is = Shrink.list ~shrink:Shrink.list ls in
Iter.map
(fun deps ->
let len = List.length deps in
let arr = Array.of_list deps in
let deps = Array.mapi (fun i i_deps -> match i,i_deps with
| 0, _
| _,[] -> []
| _,[0] -> [0]
| _, _ ->
List.map (fun j ->
if j<0 || j>=len || j>=i (* ensure reduced dep is valid *)
then ((j + i) mod i)
else j) i_deps) arr in
{ test_input with length=len; dependencies=deps }) is
let arb_deps domain_bound promise_bound =
let gen_deps =
Gen.(pair (int_bound (domain_bound-1)) (int_bound promise_bound) >>= fun (num_domains,length) ->
let num_domains = succ num_domains in
let length = succ length in
gen_dag length >>= fun dependencies -> return { num_domains; length; dependencies }) in
make ~print:show_test_input ~shrink:(shrink_deps) gen_deps
let build_dep_graph pool test_input =
let len = test_input.length in
let deps = test_input.dependencies in
let rec build i promise_acc =
if i=len
then promise_acc
else
let p = (match deps.(i) with
| [] ->
Task.async pool work
| deps ->
Task.async pool (fun () ->
work ();
List.iter (fun dep -> Task.await pool (List.nth promise_acc (i-1-dep))) deps)) in
build (i+1) (p::promise_acc)
in
build 0 []
let test_one_pool ~domain_bound ~promise_bound =
Test.make ~name:"Task.async/await, more deps, 1 work pool" ~count:100
(arb_deps domain_bound promise_bound)
((*Util.fork_prop_with_timeout 10*)
Util.repeat 10
(fun test_input ->
(*Printf.printf "%s\n%!" (show_test_input test_input);*)
let pool = Task.setup_pool ~num_domains:test_input.num_domains () in
Task.run pool (fun () ->
let ps = build_dep_graph pool test_input in
List.iter (fun p -> Task.await pool p) ps);
Task.teardown_pool pool;
true))
;;
Util.set_ci_printing ()
;;
QCheck_base_runner.run_tests_main [test_one_pool ~domain_bound:8 ~promise_bound:10]