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
|
(************************************************************************)
(* * The Coq Proof Assistant / The Coq Development Team *)
(* v * Copyright INRIA, CNRS and contributors *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
let die fmt = Printf.kfprintf (fun _ -> exit 1) stderr (fmt^^"\n%!")
module YB = Yojson.Basic
module YBU = YB.Util
let assoc a b : YB.t = CList.assoc_f String.equal a b
(* Profile files can be large, we want to parse 1 record at a time and
only keep the info we're interested in (ie the "command" events).
We use undocumented Yojson.Basic.read_comma to detect the end.
*)
let rec find_cmds acc (lstate,lex as ch) =
let v = YB.from_lexbuf lstate ~stream:true lex in
let fname = Option.get lstate.Yojson.fname in
let lnum = lstate.Yojson.lnum in
let is_last = try YB.read_comma lstate lex; false with Yojson.Json_error _ -> true in
let acc = match v with
| `Assoc l -> begin match assoc "name" l with
| `String "command" -> (lnum,l) :: acc
| _ -> acc
end
| _ -> die "File %S line %d: unrecognised value" fname lnum
in
if is_last then acc else find_cmds acc ch
type 'ch channel = {
open_in : string -> 'ch;
close_in : 'ch -> unit;
really_input : 'ch -> Bytes.t -> int -> int -> unit;
input : 'ch -> Bytes.t -> int -> int -> int;
}
let file_channel = {
open_in = open_in;
close_in = close_in;
really_input = really_input;
input = input;
}
let gzip_channel = {
open_in = Gzip.open_in;
close_in = Gzip.close_in;
really_input = Gzip.really_input;
input = Gzip.input;
}
type any_channel = AnyChannel : 'ch channel -> any_channel
let channel_for fname =
if CString.is_suffix ".json" fname then AnyChannel file_channel
else AnyChannel gzip_channel
let input_exactly ch_fns ch expected =
let buf = Bytes.create (String.length expected) in
ch_fns.really_input ch buf 0 (String.length expected);
assert (Bytes.to_string buf = expected)
let read_file fname =
let AnyChannel ch_fns = channel_for fname in
let ch = ch_fns.open_in fname in
try
(* ignore initial line *)
let () = input_exactly ch_fns ch {|{ "traceEvents": [|} in
let lex = Lexing.from_function ~with_positions:false (fun buf n -> ch_fns.input ch buf 0 n) in
let lstate = Yojson.init_lexer ~fname ~lnum:2 () in
let cmds = find_cmds [] (lstate,lex) in
ch_fns.close_in ch;
cmds
with e -> ch_fns.close_in ch; raise e
open BenchUtil
let force_string lnum = function
| `String s -> s
| _ -> die "line %d: malformed value (expected string)" lnum
let get_ts (lnum, l) = match assoc "ts" l with
| `Int ts -> ts
| _ -> die "line %d: malformed ts" lnum
let get_src_info (lnum, l) = match assoc "args" l with
| `Assoc l ->
let hdr = force_string lnum (assoc "cmd" l) in
let line = match assoc "line" l with
| `Int l -> l
| `String l -> int_of_string l
| _ -> die "line %d: malformed line number" lnum
in
hdr, line
| _ -> die "line %d: malformed args" lnum
let hdr_regex = Str.regexp {|^Chars \([0-9]+\) - \([0-9]+\) |}
let get_src_chars ~lnum hdr =
if not (Str.string_match hdr_regex hdr 0) then die "line %d: malformed command header" lnum
else
{ start_char = int_of_string @@ Str.matched_group 1 hdr;
stop_char = int_of_string @@ Str.matched_group 2 hdr; }
let mk_memory (lnum, l) =
let args = assoc "args" l in
try Some {
major_words = YBU.(to_string @@ member "major_words" args) ;
minor_words = YBU.(to_string @@ member "minor_words" args);
major_collect = YBU.(to_int @@ member "major_collect" args);
minor_collect = YBU.(to_int @@ member "minor_collect" args);
}
with YBU.Type_error (msg,_) -> die "line %d: %s" lnum msg
let mk_time start stop =
let time = stop - start in
(* time unit is microsecond *)
let timeq = Q.(div (of_int time) (of_int 1000000)) in
let timef = (float_of_int time) /. 1e6 in
let str =
(* 3 significant digits *)
if timef > 100. then Printf.sprintf "%.0f" timef
else if timef > 10. then Printf.sprintf "%.1f" timef
else if timef > 1. then Printf.sprintf "%.2f" timef
else if timef > 0.1 then Printf.sprintf "%.3f" timef
else if timef > 0.01 then Printf.sprintf "%.4f" timef
else if timef > 0.001 then Printf.sprintf "%.5f" timef
else Printf.sprintf "%.6f" timef
in
{ str;
q = timeq; }
let rec process_cmds acc = function
| [] -> acc
| end_event :: start_event :: rest ->
let hdr, line = get_src_info start_event in
let start_ts = get_ts start_event in
let end_ts = get_ts end_event in
let src_chars = get_src_chars ~lnum:(fst start_event) hdr in
let time = mk_time start_ts end_ts in
let memory = mk_memory end_event in
process_cmds ((src_chars, { time; memory; }) :: acc) rest
| [_] -> die "ill parenthesized events"
let parse ~file =
let cmds = read_file file in
let cmds = process_cmds [] cmds in
cmds
|
