gazagnaire.org
upstream: https://github.com/janestreet/memtrace
1open Memtrace.Trace
2
3module Str_tbl = Hashtbl.Make (struct
4 type t = string
5
6 let equal = String.equal
7 let hash = Hashtbl.hash
8end)
9
10type summary = { mutable samples : int; subsums : summary Str_tbl.t }
11
12let rec dedup = function
13 | [] -> []
14 | [ x ] -> [ x ]
15 | x :: x' :: xs when x = x' -> dedup (x :: xs)
16 | x :: xs -> x :: dedup xs
17
18let process_alloc_backtrace trace backtrace_buffer backtrace_length =
19 let str_of_location (l : Location.t) =
20 l.defname
21 (*Printf.sprintf "%s:%d" filename line*)
22 in
23 let _print_location ppf Location.{ filename; line; start_char; end_char; _ } =
24 Fmt.pf ppf "%s:%d:%d-%d" filename line start_char end_char
25 in
26 let filenames =
27 List.concat
28 (Array.sub backtrace_buffer 0 backtrace_length
29 |> Array.map (fun l ->
30 let locs = Reader.lookup_location_code trace l in
31 List.map
32 (fun (Location.{ filename = _; _ } as l) -> str_of_location l)
33 locs)
34 |> Array.to_list)
35 in
36 let seen = Str_tbl.create 10 in
37 let filenames = dedup filenames in
38 let first_filenames = (*List.rev*) filenames in
39 first_filenames
40 |> List.filter (fun f ->
41 if Str_tbl.mem seen f then false
42 else (
43 Str_tbl.add seen f ();
44 true))
45
46let rec dump_summary files_rev summary =
47 (if summary.samples > 0 then
48 match List.rev files_rev with
49 | [] -> ()
50 | [ _ ] -> ()
51 | x :: xs ->
52 Fmt.pr "%s" x;
53 List.iter (Fmt.pr ";%s") xs;
54 Fmt.pr " %d@\n" summary.samples);
55 let keys =
56 Str_tbl.fold (fun k _ ks -> k :: ks) summary.subsums []
57 |> List.sort String.compare
58 in
59 keys
60 |> List.iter (fun f ->
61 let s = Str_tbl.find summary.subsums f in
62 dump_summary (f :: files_rev) s)
63
64let summary filename =
65 let summary = { samples = 0; subsums = Str_tbl.create 20 } in
66 let count (filenames, nsamples) =
67 let lastsum =
68 List.fold_left
69 (fun sum f ->
70 if Str_tbl.mem sum.subsums f then Str_tbl.find sum.subsums f
71 else
72 let s = { samples = 0; subsums = Str_tbl.create 10 } in
73 Str_tbl.add sum.subsums f s;
74 s)
75 summary filenames
76 in
77 lastsum.samples <- lastsum.samples + nsamples
78 in
79 let allocs = Hashtbl.create 20 in
80 let sz = ref 0 in
81 let nallocs = ref 0 in
82 let trace = Reader.open_ ~filename in
83 Reader.iter trace (fun _time ev ->
84 match ev with
85 | Alloc
86 {
87 obj_id;
88 length = _;
89 domain = _;
90 nsamples;
91 source = _;
92 backtrace_buffer;
93 backtrace_length;
94 common_prefix = _;
95 } ->
96 let first_filenames =
97 process_alloc_backtrace trace backtrace_buffer backtrace_length
98 in
99 Hashtbl.add allocs obj_id (first_filenames, nsamples);
100 sz := !sz + backtrace_length;
101 incr nallocs;
102 if true then count (first_filenames, nsamples)
103 (* count (first_filenames, nsamples) *)
104 (* first_filenames |> List.iter (Printf.printf " %s");
105 Printf.printf "\n%!"*)
106 | Promote _ -> ()
107 (*count (Hashtbl.find allocs i)*)
108 | Collect (i, _) ->
109 assert (Hashtbl.mem allocs i);
110 Hashtbl.remove allocs i);
111 Reader.close trace;
112 dump_summary [] summary
113
114let () =
115 if Array.length Sys.argv <> 2 then
116 Fmt.epr "Usage: %s <trace file>@\n" Sys.executable_name
117 else summary Sys.argv.(1)