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
module Make (F : Mirage_flow.S) = struct
module Trace = Trace
(** Use Memprof_tracer in conjunction with Trace.Writer for more manual
control over trace collection *)
module Memprof_tracer = Memprof_tracer
type tracer = Memprof_tracer.t
let getpid64 () = -1L
let default_sampling_rate = 1e-6
let start_tracing ~context ?(sampling_rate = default_sampling_rate) flow =
if Memprof_tracer.active_tracer () <> None then
failwith "Only one Memtrace instance may be active at a time";
let info : Trace.Info.t =
{ sample_rate = sampling_rate;
word_size = Sys.word_size;
executable_name = Sys.executable_name;
host_name = "mirage_unikernel";
ocaml_runtime_params = Sys.runtime_parameters ();
pid = getpid64 ();
start_time = Trace.Timestamp.now ();
context;
} in
let stream, pushf = Lwt_stream.create () in
let trace = Trace.Writer.create pushf ~getpid:getpid64 info in
let tracer = Memprof_tracer.start ~sampling_rate trace in
Lwt.async (fun () ->
let open Lwt.Infix in
let rec go () =
Lwt_stream.get stream >>= function
| None -> F.close flow
| Some ev ->
F.write flow ev >>= function
| Ok () -> go ()
| Error we ->
print_endline ("tracing stopped due to write error: " ^
Fmt.to_to_string F.pp_write_error we);
Memprof_tracer.stop tracer;
Lwt.return_unit
in
go ());
tracer
let stop_tracing t =
Memprof_tracer.stop t
let () =
at_exit (fun () -> Option.iter stop_tracing (Memprof_tracer.active_tracer ()))
module External = struct
type token = Memprof_tracer.ext_token
let alloc = Memprof_tracer.ext_alloc
let free = Memprof_tracer.ext_free
end
end
module Geometric_sampler = Geometric_sampler