vm.fail
cache line locking on AMD x86_64 utilising L3 CAT pseudo-locking
1open Ctypes
2open Foreign
3
4exception Icepick_error of string
5
6type prime_strategy =
7 | Prime_temporal
8 | Prime_prefetcht2
9 | Prime_prefetchnta
10 | Prime_nt_store
11
12type access_pattern =
13 | Pattern_sequential
14 | Pattern_reverse
15 | Pattern_strided
16 | Pattern_pointer_chase
17
18type core_type =
19 | Core_any
20 | Core_pcore
21 | Core_ecore
22
23let () = Callback.register_exception "Icepick_error" (Icepick_error "")
24
25let () =
26 let _ = Dl.dlopen ~filename:"/home/oni/Projects/icepick/libicepick.so"
27 ~flags:[Dl.RTLD_NOW; Dl.RTLD_GLOBAL] in
28 ()
29
30module C = struct
31 let icepick_strerror = foreign "icepick_strerror" (int @-> returning string)
32
33 let check_error ret =
34 if ret < 0 then raise (Icepick_error (icepick_strerror ret))
35
36 module Topology = struct
37 type t = unit ptr
38 let t : t typ = ptr void
39
40 let discover = foreign "icepick_discover_topology" (ptr t @-> returning int)
41 let free = foreign "icepick_free_topology" (t @-> returning void)
42 let l3_ways = foreign "icepick_topology_l3_ways" (t @-> returning uint)
43 let l3_size = foreign "icepick_topology_l3_size" (t @-> returning size_t)
44 let way_size = foreign "icepick_topology_way_size" (t @-> returning size_t)
45 let max_clos = foreign "icepick_topology_max_clos" (t @-> returning uint)
46 let ccx_count = foreign "icepick_topology_ccx_count" (t @-> returning uint)
47 let cat_supported = foreign "icepick_topology_cat_supported" (t @-> returning bool)
48 let mba_supported = foreign "icepick_topology_mba_supported" (t @-> returning bool)
49 let mba_is_linear = foreign "icepick_topology_mba_is_linear" (t @-> returning bool)
50 let max_mba_thrtl = foreign "icepick_topology_max_mba_thrtl" (t @-> returning uint)
51 let is_hybrid = foreign "icepick_topology_is_hybrid" (t @-> returning bool)
52 let pcore_count = foreign "icepick_topology_pcore_count" (t @-> returning uint)
53 let ecore_count = foreign "icepick_topology_ecore_count" (t @-> returning uint)
54 end
55
56 module Region = struct
57 type t = unit ptr
58 let t : t typ = ptr void
59
60 let ptr = foreign "icepick_region_ptr" (t @-> returning (ptr void))
61 let size = foreign "icepick_region_size" (t @-> returning size_t)
62 let clos = foreign "icepick_region_clos" (t @-> returning uint)
63 end
64
65 module Config = struct
66 type t
67 let t : t structure typ = structure "icepick_config_t"
68 let size = field t "size" size_t
69 let clos_id = field t "clos_id" uint
70 let numa_node = field t "numa_node" int
71 let huge_pages = field t "huge_pages" bool
72 let verify = field t "verify" bool
73 let auto_monitor = field t "auto_monitor" bool
74 let pmu_poll_interval_ns = field t "pmu_poll_interval_ns" uint64_t
75 let probe_interval_ns = field t "probe_interval_ns" uint64_t
76 let miss_threshold = field t "miss_threshold" uint32_t
77 let prime_strategy = field t "prime_strategy" int
78 let access_pattern = field t "access_pattern" int
79 let stride_bytes = field t "stride_bytes" size_t
80 let prime_iterations = field t "prime_iterations" uint
81 let mba_throttle = field t "mba_throttle" uint
82 let core_type = field t "core_type" int
83 let () = seal t
84 end
85
86 module Latency_stats = struct
87 type t
88 let t : t structure typ = structure "icepick_latency_stats_t"
89 let mean_ns = field t "mean_ns" uint64_t
90 let stddev_ns = field t "stddev_ns" uint64_t
91 let p50_ns = field t "p50_ns" uint64_t
92 let p99_ns = field t "p99_ns" uint64_t
93 let p999_ns = field t "p999_ns" uint64_t
94 let min_ns = field t "min_ns" uint64_t
95 let max_ns = field t "max_ns" uint64_t
96 let () = seal t
97 end
98
99 let lock = foreign "icepick_lock"
100 (Topology.t @-> ptr Config.t @-> ptr Region.t @-> returning int)
101
102 let unlock = foreign "icepick_unlock" (Region.t @-> returning int)
103
104 let verify = foreign "icepick_verify"
105 (Region.t @-> ptr Latency_stats.t @-> returning int)
106
107 let bench = foreign "icepick_bench"
108 (ptr void @-> size_t @-> size_t @-> ptr Latency_stats.t @-> returning int)
109
110 module Monitor = struct
111 type t = unit ptr
112 let t : t typ = ptr void
113
114 let start = foreign "icepick_monitor_start" (Region.t @-> ptr t @-> returning int)
115 let start_ex = foreign "icepick_monitor_start_ex"
116 (Region.t @-> uint64_t @-> uint64_t @-> uint32_t @-> ptr t @-> returning int)
117 let stop = foreign "icepick_monitor_stop" (t @-> returning int)
118 let eviction_count = foreign "icepick_monitor_eviction_count" (t @-> returning uint64_t)
119 let reprime_count = foreign "icepick_monitor_reprime_count" (t @-> returning uint64_t)
120 let is_degraded = foreign "icepick_monitor_is_degraded" (t @-> returning bool)
121 end
122end
123
124module Topology = struct
125 type t = {
126 ptr : C.Topology.t;
127 mutable released : bool;
128 }
129
130 let release t =
131 if not t.released then begin
132 C.Topology.free t.ptr;
133 t.released <- true
134 end
135
136 let discover () =
137 let ptr_ref = allocate C.Topology.t (from_voidp void null) in
138 let ret = C.Topology.discover ptr_ref in
139 C.check_error ret;
140 let t = { ptr = !@ ptr_ref; released = false } in
141 Gc.finalise release t;
142 t
143
144 let l3_ways t = Unsigned.UInt.to_int (C.Topology.l3_ways t.ptr)
145 let l3_size t = Unsigned.Size_t.to_int (C.Topology.l3_size t.ptr)
146 let way_size t = Unsigned.Size_t.to_int (C.Topology.way_size t.ptr)
147 let max_clos t = Unsigned.UInt.to_int (C.Topology.max_clos t.ptr)
148 let ccx_count t = Unsigned.UInt.to_int (C.Topology.ccx_count t.ptr)
149 let cat_supported t = C.Topology.cat_supported t.ptr
150 let mba_supported t = C.Topology.mba_supported t.ptr
151 let mba_is_linear t = C.Topology.mba_is_linear t.ptr
152 let max_mba_thrtl t = Unsigned.UInt.to_int (C.Topology.max_mba_thrtl t.ptr)
153 let is_hybrid t = C.Topology.is_hybrid t.ptr
154 let pcore_count t = Unsigned.UInt.to_int (C.Topology.pcore_count t.ptr)
155 let ecore_count t = Unsigned.UInt.to_int (C.Topology.ecore_count t.ptr)
156end
157
158module Latency_stats = struct
159 type t = {
160 mean_ns : int;
161 stddev_ns : int;
162 p50_ns : int;
163 p99_ns : int;
164 p999_ns : int;
165 min_ns : int;
166 max_ns : int;
167 }
168
169 let of_c stats =
170 {
171 mean_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.mean_ns);
172 stddev_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.stddev_ns);
173 p50_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.p50_ns);
174 p99_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.p99_ns);
175 p999_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.p999_ns);
176 min_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.min_ns);
177 max_ns = Unsigned.UInt64.to_int (getf stats C.Latency_stats.max_ns);
178 }
179end
180
181module Region = struct
182 type t = {
183 ptr : C.Region.t;
184 topo : Topology.t;
185 mutable released : bool;
186 }
187
188 let release t =
189 if not t.released then begin
190 let _ = C.unlock t.ptr in
191 t.released <- true
192 end
193
194 let prime_strategy_to_int = function
195 | Prime_temporal -> 0
196 | Prime_prefetcht2 -> 1
197 | Prime_prefetchnta -> 2
198 | Prime_nt_store -> 3
199
200 let access_pattern_to_int = function
201 | Pattern_sequential -> 0
202 | Pattern_reverse -> 1
203 | Pattern_strided -> 2
204 | Pattern_pointer_chase -> 3
205
206 let core_type_to_int = function
207 | Core_any -> 0
208 | Core_pcore -> 1
209 | Core_ecore -> 2
210
211 let lock topo ~size ~clos ?(numa = -1) ?(huge_pages = true) ?(verify = false)
212 ?(prime_strategy = Prime_temporal) ?(access_pattern = Pattern_sequential)
213 ?(stride = 0) ?(prime_iterations = 3) ?(mba_throttle = 0)
214 ?(core_type = Core_any) () =
215 let cfg = make C.Config.t in
216 setf cfg C.Config.size (Unsigned.Size_t.of_int size);
217 setf cfg C.Config.clos_id (Unsigned.UInt.of_int clos);
218 setf cfg C.Config.numa_node numa;
219 setf cfg C.Config.huge_pages huge_pages;
220 setf cfg C.Config.verify verify;
221 setf cfg C.Config.auto_monitor false;
222 setf cfg C.Config.pmu_poll_interval_ns (Unsigned.UInt64.of_int 0);
223 setf cfg C.Config.probe_interval_ns (Unsigned.UInt64.of_int 0);
224 setf cfg C.Config.miss_threshold (Unsigned.UInt32.of_int 0);
225 setf cfg C.Config.prime_strategy (prime_strategy_to_int prime_strategy);
226 setf cfg C.Config.access_pattern (access_pattern_to_int access_pattern);
227 setf cfg C.Config.stride_bytes (Unsigned.Size_t.of_int stride);
228 setf cfg C.Config.prime_iterations (Unsigned.UInt.of_int prime_iterations);
229 setf cfg C.Config.mba_throttle (Unsigned.UInt.of_int mba_throttle);
230 setf cfg C.Config.core_type (core_type_to_int core_type);
231 let ptr_ref = allocate C.Region.t (from_voidp void null) in
232 let ret = C.lock topo.Topology.ptr (addr cfg) ptr_ref in
233 C.check_error ret;
234 let t = { ptr = !@ ptr_ref; topo; released = false } in
235 Gc.finalise release t;
236 t
237
238 let unlock t =
239 if not t.released then begin
240 let ret = C.unlock t.ptr in
241 t.released <- true;
242 C.check_error ret
243 end
244
245 let ptr t = raw_address_of_ptr (C.Region.ptr t.ptr)
246 let size t = Unsigned.Size_t.to_int (C.Region.size t.ptr)
247 let clos t = Unsigned.UInt.to_int (C.Region.clos t.ptr)
248
249 let to_bigarray_float64 t =
250 let region_ptr = C.Region.ptr t.ptr in
251 let region_size = Unsigned.Size_t.to_int (C.Region.size t.ptr) in
252 let len = region_size / 8 in
253 let typed_ptr = from_voidp double (to_voidp region_ptr) in
254 CArray.from_ptr typed_ptr len |> CArray.to_list |> Array.of_list |>
255 Bigarray.Array1.of_array Bigarray.Float64 Bigarray.c_layout
256end
257
258module Monitor = struct
259 type t = {
260 ptr : C.Monitor.t;
261 region : Region.t;
262 mutable stopped : bool;
263 }
264
265 let release t =
266 if not t.stopped then begin
267 let _ = C.Monitor.stop t.ptr in
268 t.stopped <- true
269 end
270
271 let start region =
272 let ptr_ref = allocate C.Monitor.t (from_voidp void null) in
273 let ret = C.Monitor.start region.Region.ptr ptr_ref in
274 C.check_error ret;
275 let t = { ptr = !@ ptr_ref; region; stopped = false } in
276 Gc.finalise release t;
277 t
278
279 let start_ex region ~pmu_poll_ns ~probe_ns ~miss_thresh =
280 let ptr_ref = allocate C.Monitor.t (from_voidp void null) in
281 let ret = C.Monitor.start_ex region.Region.ptr
282 (Unsigned.UInt64.of_int pmu_poll_ns)
283 (Unsigned.UInt64.of_int probe_ns)
284 (Unsigned.UInt32.of_int miss_thresh)
285 ptr_ref in
286 C.check_error ret;
287 let t = { ptr = !@ ptr_ref; region; stopped = false } in
288 Gc.finalise release t;
289 t
290
291 let stop t =
292 if not t.stopped then begin
293 let ret = C.Monitor.stop t.ptr in
294 t.stopped <- true;
295 C.check_error ret
296 end
297
298 let eviction_count t = Unsigned.UInt64.to_int (C.Monitor.eviction_count t.ptr)
299 let reprime_count t = Unsigned.UInt64.to_int (C.Monitor.reprime_count t.ptr)
300 let is_degraded t = C.Monitor.is_degraded t.ptr
301end
302
303let verify region =
304 let stats = make C.Latency_stats.t in
305 let ret = C.verify region.Region.ptr (addr stats) in
306 C.check_error ret;
307 Latency_stats.of_c stats
308
309let bench ptr ~size ~iterations =
310 let stats = make C.Latency_stats.t in
311 let p = ptr_of_raw_address ptr in
312 let ret = C.bench p (Unsigned.Size_t.of_int size) (Unsigned.Size_t.of_int iterations) (addr stats) in
313 C.check_error ret;
314 Latency_stats.of_c stats