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