forked from ocaml-multicore/multicoretests
-
Notifications
You must be signed in to change notification settings - Fork 0
/
task_one_dep.ml
180 lines (166 loc) · 6.38 KB
/
task_one_dep.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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
(**
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 sparse DAG of dependencies *)
(* Each task is represented by an array index w/at most 1 dep. each *)
(* This example DAG
A/0 <--- B/1
^.
\
`- C/2 <--- D/3
is represented as: [| None; Some 0; Some 0; Some 2 |] *)
let gen_deps n st =
let a = Array.make n None in
for i=1 to n-1 do
if Gen.bool st then a.(i) <- Some (Gen.int_bound (i-1) st)
done;
a
(* FIXME:
- Make sparsety a random param - not just a bool in gen_deps *)
type test_input =
{
num_domains : int;
length : int;
dependencies : int option array
} [@@deriving show { with_path = false }]
(* an older, more ambitious shrinker *)
(*
let rec shrink_deps i ((len,deps) as pair) =
if len = 0 || i>=len then Iter.empty
else
let front = Array.sub deps 0 i in
let back = Array.sub deps (i+1) (len - (i+1)) in
let adjust_indices a = (* adjust dependencies for removed entry *)
Array.map (function
| None -> None
| Some j ->
if i=j then None else (*old dependency was just removed in shrink candidate *)
if j<i then Some j else Some (j-1)) a in
let without_some deps =
(if deps.(i) = None
then Iter.empty
else let deps' = Array.copy deps in deps'.(i) <- None; Iter.return (len,deps')) in
Iter.append
(Iter.return (len-1, Array.append front (adjust_indices back)))
(Iter.append
(without_some deps)
(shrink_deps (i+1) pair))
*)
let shrink_deps test_input =
let ls = Array.to_list test_input.dependencies in
let is = Shrink.list ~shrink:Shrink.(option nil) 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 j_opt -> match i,j_opt with
| 0, _
| _,None -> None
| _,Some 0 -> Some 0
| _, Some j ->
if j<0 || j>=len || j>=i (* ensure reduced dep is valid *)
then Some ((j + i) mod i)
else Some j) 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_deps length >>= fun dependencies -> return { num_domains; length; dependencies }) in
let shrink_input input =
Iter.append
(Iter.map (fun doms' -> { input with num_domains = doms' }) (Shrink.int input.num_domains))
(shrink_deps input) in
make ~print:show_test_input ~shrink:shrink_input 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
| None ->
Task.async pool work
| Some dep ->
Task.async pool (fun () ->
work();
Task.await pool (List.nth promise_acc (i-1-dep)))) in
build (i+1) (p::promise_acc)
in
build 0 []
let test_one_pool ~domain_bound ~promise_bound =
Test.make ~name:"Task.async/await, one dep, 1 work pool" ~count:100
(*Test.make ~retries:50 ~name:"Task.async/await" ~count:100*)
(arb_deps domain_bound promise_bound)
((*Util.fork_prop_with_timeout 10*)
Util.repeat 10 @@
(*Util.prop_timeout 10 @@*)
fun input ->
(*Printf.printf "%s\n%!" (show_test_input test_input);*)
let pool = Task.setup_pool ~num_domains:input.num_domains () in
Task.run pool (fun () ->
let ps = build_dep_graph pool input in
List.iter (fun p -> Task.await pool p) ps);
Task.teardown_pool pool;
true)
let test_two_pools_sync_last ~domain_bound ~promise_bound =
let gen = arb_deps domain_bound promise_bound in
Test.make ~name:"Task.async/await, one dep, w.2 pools, syncing at the end" ~count:100
(pair gen gen)
((*Util.fork_prop_with_timeout 10 @@*)
Util.repeat 10 @@
(*Util.prop_timeout 10 @@*)
fun (input1,input2) ->
(*Printf.printf "%s\n%!" (Print.pair show_test_input show_test_input (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)
let test_two_nested_pools ~domain_bound ~promise_bound =
let gen = arb_deps domain_bound promise_bound in
Test.make ~name:"Task.async/await, one dep, w.2 nested pools" ~count:100
(pair gen gen)
((*Util.fork_prop_with_timeout 10 @@*)
Util.repeat 10 @@
(*Util.prop_timeout 10 @@*)
fun (input1,input2) ->
(*Printf.printf "%s\n%!" (Print.pair show_test_input show_test_input (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)
;;
Util.set_ci_printing ()
;;
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;
]
(*QCheck_runner.run_tests [test ~domain_bound:8 ~promise_bound:10]*)