gazagnaire.org
upstream: https://github.com/janestreet/memtrace
1let cache_size = 1 lsl 14
2
3type cache_bucket = int (* 0 to cache_size - 1 *)
4
5module Writer = struct
6 open Buf.Write
7
8 (* The writer cache carries slightly more state than the reader cache,
9 since the writer must make decisions about which slot to use.
10 (The reader just follows the choices made by the writer) *)
11 type t = {
12 cache : int array;
13 cache_date : int array;
14 (* when an entry was added to the cache (used for eviction) *)
15 cache_next : cache_bucket array;
16 (* last time we saw this entry, which entry followed it? *)
17 mutable next_verify_ix : int;
18 }
19
20 let create () =
21 {
22 cache = Array.make cache_size 0;
23 cache_date = Array.make cache_size 0;
24 cache_next = Array.make cache_size 0;
25 next_verify_ix = 4242;
26 }
27
28 let max_length = 4096
29
30 let put_backtrace cache b ~alloc_id ~callstack ~callstack_pos ~callstack_len
31 ~log_new_location =
32 let max_entry = 2 + 8 in
33 let limit = b.pos + max_length - max_entry in
34 let put_hit b bucket ncorrect =
35 match ncorrect with
36 | 0 -> put_16 b (bucket lsl 2)
37 | 1 -> put_16 b ((bucket lsl 2) lor 1)
38 | n ->
39 put_16 b ((bucket lsl 2) lor 2);
40 put_8 b n
41 in
42 let rec code_no_prediction predictor pos ncodes =
43 if pos < callstack_pos || b.pos > limit then ncodes
44 else
45 let mask = cache_size - 1 in
46 let slot = callstack.(pos) in
47 (* Pick the least recently used of two slots, selected by two
48 different hashes. *)
49 let hash1 = ((slot * 0x4983723) lsr 11) land mask in
50 let hash2 = ((slot * 0xfdea731) lsr 21) land mask in
51 if cache.cache.(hash1) = slot then
52 code_cache_hit predictor hash1 pos ncodes
53 else if cache.cache.(hash2) = slot then
54 code_cache_hit predictor hash2 pos ncodes
55 else (
56 (* cache miss *)
57 log_new_location ~index:pos;
58 let bucket =
59 if cache.cache_date.(hash1) < cache.cache_date.(hash2) then hash1
60 else hash2
61 in
62 (* Printf.printf "miss %05d %016x\n%!"
63 bucket slot; (*" %016x\n%!" bucket slot;*) *)
64 cache.cache.(bucket) <- slot;
65 cache.cache_date.(bucket) <- alloc_id;
66 cache.cache_next.(predictor) <- bucket;
67 put_16 b ((bucket lsl 2) lor 3);
68 put_64 b (Int64.of_int slot);
69 code_no_prediction bucket (pos - 1) (ncodes + 1))
70 and code_cache_hit predictor hit pos ncodes =
71 (* Printf.printf "hit %d\n" hit; *)
72 cache.cache_date.(hit) <- alloc_id;
73 cache.cache_next.(predictor) <- hit;
74 code_with_prediction hit hit 0 (pos - 1) (ncodes + 1)
75 and code_with_prediction orig_hit predictor ncorrect pos ncodes =
76 assert (ncorrect < 256);
77 if pos < callstack_pos || b.pos + 2 > limit then (
78 put_hit b orig_hit ncorrect;
79 ncodes)
80 else
81 let slot = callstack.(pos) in
82 let pred_bucket = cache.cache_next.(predictor) in
83 if cache.cache.(pred_bucket) = slot then
84 (* correct prediction *)
85 (* Printf.printf "pred %d %d\n" pred_bucket ncorrect; *)
86 if ncorrect = 255 then (
87 (* overflow: code a new prediction block *)
88 put_hit b orig_hit ncorrect;
89 code_cache_hit predictor pred_bucket pos ncodes)
90 else
91 code_with_prediction orig_hit pred_bucket (ncorrect + 1) (pos - 1)
92 ncodes
93 else (
94 (* incorrect prediction *)
95 put_hit b orig_hit ncorrect;
96 code_no_prediction predictor pos ncodes)
97 in
98 code_no_prediction 0 (callstack_len - 1) 0
99
100 let put_cache_verifier cache b =
101 let ix = cache.next_verify_ix in
102 cache.next_verify_ix <- (cache.next_verify_ix + 5413) land (cache_size - 1);
103 put_16 b ix;
104 put_16 b cache.cache_next.(ix);
105 put_64 b (Int64.of_int cache.cache.(ix))
106
107 let put_dummy_verifier b =
108 put_16 b 0xffff;
109 put_16 b 0;
110 put_64 b 0L
111end
112
113module Reader = struct
114 open Buf.Read
115
116 type t = {
117 cache_loc : int array;
118 cache_pred : int array;
119 mutable last_backtrace : int array;
120 mutable last_backtrace_len : int;
121 }
122
123 let create () =
124 {
125 cache_loc = Array.make cache_size 0;
126 cache_pred = Array.make cache_size 0;
127 last_backtrace = [||];
128 last_backtrace_len = 0;
129 }
130
131 let[@inline never] realloc_bbuf bbuf pos (x : int) =
132 assert (pos = Array.length bbuf);
133 let new_size = Array.length bbuf * 2 in
134 let new_size = if new_size < 32 then 32 else new_size in
135 let new_bbuf = Array.make new_size x in
136 Array.blit bbuf 0 new_bbuf 0 pos;
137 new_bbuf
138
139 let[@inline] put_bbuf bbuf pos (x : int) =
140 if pos < Array.length bbuf then (
141 Array.unsafe_set bbuf pos x;
142 bbuf)
143 else realloc_bbuf bbuf pos x
144
145 let get_backtrace ({ cache_loc; cache_pred; _ } as cache) b ~nencoded
146 ~common_pfx_len =
147 let rec decode pred bbuf pos = function
148 | 0 -> (bbuf, pos)
149 | i -> (
150 let codeword = get_16 b in
151 let bucket = codeword lsr 2 and tag = codeword land 3 in
152 cache_pred.(pred) <- bucket;
153 match tag with
154 | 0 ->
155 (* cache hit, 0 prediction *)
156 let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
157 predict bucket bbuf (pos + 1) (i - 1) 0
158 | 1 ->
159 (* cache hit, 1 prediction *)
160 let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
161 predict bucket bbuf (pos + 1) (i - 1) 1
162 | 2 ->
163 (* cache hit, N prediction *)
164 let ncorrect = get_8 b in
165 let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
166 predict bucket bbuf (pos + 1) (i - 1) ncorrect
167 | _ ->
168 (* cache miss *)
169 let lit = Int64.to_int (get_64 b) in
170 cache_loc.(bucket) <- lit;
171 let bbuf = put_bbuf bbuf pos lit in
172 decode bucket bbuf (pos + 1) (i - 1))
173 and predict pred bbuf pos i = function
174 | 0 -> decode pred bbuf pos i
175 | n ->
176 let pred' = cache_pred.(pred) in
177 let bbuf = put_bbuf bbuf pos cache_loc.(pred') in
178 predict pred' bbuf (pos + 1) i (n - 1)
179 in
180 if common_pfx_len <= cache.last_backtrace_len then (
181 let bbuf, pos = decode 0 cache.last_backtrace common_pfx_len nencoded in
182 cache.last_backtrace <- bbuf;
183 cache.last_backtrace_len <- pos;
184 (bbuf, pos))
185 else
186 (* This can occur if the last backtrace was truncated, and the current
187 backtrace shares a long prefix with it. Return the amount of backtrace
188 that we have. (We still go through the motions of decoding to ensure
189 that the location cache is updated correctly) *)
190 let _bbuf, _pos = decode 0 [||] 0 nencoded in
191 (cache.last_backtrace, cache.last_backtrace_len)
192
193 let skip_backtrace _cache b ~nencoded ~common_pfx_len:_ =
194 for _ = 1 to nencoded do
195 let codeword = get_16 b in
196 if codeword land 3 = 2 then ignore (get_8 b) (* hitN *)
197 else if codeword land 3 = 3 then ignore (get_64 b)
198 (* miss *)
199 done
200
201 type cache_verifier = { ix : int; pred : int; value : Int64.t }
202
203 let get_cache_verifier b =
204 let ix = get_16 b in
205 let pred = get_16 b in
206 let value = get_64 b in
207 { ix; pred; value }
208
209 let check_cache_verifier cache { ix; pred; value } =
210 if ix <> 0xffff then
211 0 <= ix
212 && ix < Array.length cache.cache_loc
213 && cache.cache_pred.(ix) = pred
214 && cache.cache_loc.(ix) = Int64.to_int value
215 else true
216end