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
181
182
183
184
185
186
187
188
let runnable f i =
for _ = 1 to i do
ignore (Sys.opaque_identity (f ()))
done
[@@inline]
let record measure =
let (Measure.V (m, (module M))) = Measure.prj measure in
fun () -> M.get m
let stabilize_garbage_collector () =
let rec go fail last_heap_live_words =
if fail <= 0
then
failwith "Unable to stabilize the number of live words in the major heap" ;
Gc.compact () ;
let stat = Gc.stat () in
if stat.Gc.live_words <> last_heap_live_words
then go (fail - 1) stat.Gc.live_words in
go 10 0
let exceeded_allowed_time allowed_time_span t =
let t' = Monotonic_clock.now () in
let t' = Time.of_uint64_ns t' in
Time.span_compare (Time.span t t') allowed_time_span > 0
type sampling = [ `Linear of int | `Geometric of float ]
type stats = {
start : int;
sampling : sampling;
stabilize : bool;
quota : Time.span;
limit : int;
instances : string list;
samples : int;
time : Time.span;
}
type configuration = {
start : int;
sampling : sampling;
stabilize : bool;
quota : Time.span;
kde : int option;
limit : int;
}
type t = {
stats : stats;
lr : Measurement_raw.t array;
kde : Measurement_raw.t array option;
}
let cfg ?(limit = 3000) ?(quota = Time.second 1.) ?(kde = None)
?(sampling = `Geometric 1.01) ?(stabilize = true) ?(start = 1) () :
configuration =
{ limit; start; quota; sampling; kde; stabilize }
let run cfg measures test : t =
let idx = ref 0 in
let run = ref cfg.start in
let (Test.V init) = Test.Elt.fn test in
let fn = init `Init in
let measures = Array.of_list measures in
let length = Array.length measures in
let m = Array.create_float (cfg.limit * (length + 1)) in
let m0 = Array.create_float length in
let m1 = Array.create_float length in
Array.iter Measure.load measures ;
let records = Array.init length (fun i -> record measures.(i)) in
stabilize_garbage_collector () ;
let init_time = Time.of_uint64_ns (Monotonic_clock.now ()) in
let total_run = ref 0 in
while (not (exceeded_allowed_time cfg.quota init_time)) && !idx < cfg.limit do
let current_run = !run in
let current_idx = !idx in
for i = 0 to length - 1 do
m0.(i) <- records.(i) ()
done ;
runnable fn current_run ;
for i = 0 to length - 1 do
m1.(i) <- records.(i) ()
done ;
m.(current_idx * (length + 1)) <- float_of_int current_run ;
for i = 1 to length do
m.((current_idx * (length + 1)) + i) <- m1.(i - 1) -. m0.(i - 1)
done ;
let next =
match cfg.sampling with
| `Linear k -> current_run + k
| `Geometric scale ->
let next_geometric =
int_of_float (float_of_int current_run *. scale) in
if next_geometric >= current_run + 1
then next_geometric
else current_run + 1 in
total_run := !total_run + !run ;
run := next ;
incr idx
done ;
let samples = !idx in
let labels = Array.map Measure.label measures in
let measurement_raw idx =
let run = m.(idx * (length + 1)) in
let measures = Array.sub m ((idx * (length + 1)) + 1) length in
Measurement_raw.make ~measures ~labels run in
let lr_raw = Array.init samples measurement_raw in
let kde_raw =
match cfg.kde with
| None -> None
| Some kde_limit ->
let mkde = Array.create_float (kde_limit * length) in
let init_time' = Time.of_uint64_ns (Monotonic_clock.now ()) in
let current_idx = ref 0 in
while
(not (exceeded_allowed_time cfg.quota init_time'))
&& !current_idx < kde_limit
do
for i = 0 to length - 1 do
m0.(i) <- records.(i) ()
done ;
ignore (Sys.opaque_identity (fn ())) ;
for i = 0 to length - 1 do
m1.(i) <- records.(i) ()
done ;
for i = 0 to length - 1 do
mkde.((!current_idx * length) + i) <- m1.(i) -. m0.(i)
done ;
total_run := !total_run + !run ;
incr current_idx
done ;
let kde_raw idx =
let measures = Array.sub mkde (idx * length) length in
Measurement_raw.make ~measures ~labels 1. in
Some (Array.init !current_idx kde_raw) in
let final_time = Time.of_uint64_ns (Monotonic_clock.now ()) in
Array.iter Measure.unload measures ;
let stats =
{
start = cfg.start;
sampling = cfg.sampling;
stabilize = cfg.stabilize;
quota = cfg.quota;
limit = cfg.limit;
instances = Array.to_list labels;
samples;
time = Time.span init_time final_time;
} in
{ stats; lr = lr_raw; kde = kde_raw }
let all cfg measures test =
let tests = Array.of_list (Test.elements test) in
let tbl = Hashtbl.create (Array.length tests) in
for i = 0 to Array.length tests - 1 do
let results = run cfg measures tests.(i) in
Hashtbl.add tbl (Test.Elt.name tests.(i)) results
done ;
tbl