From 0a6759fa78632c75b2c9638574979088712b82cb Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Wed, 31 Jan 2024 16:49:01 +1100 Subject: [PATCH 1/6] Update for statmemprof in OCaml 5.3 Signed-off-by: Tim McGilchrist --- docs/internal.md | 6 +++--- dune-project | 2 +- memtrace.opam | 2 +- src/memprof_tracer.ml | 4 ++-- src/memtrace.ml | 2 +- src/trace.ml | 13 +++++++++---- 6 files changed, 17 insertions(+), 12 deletions(-) diff --git a/docs/internal.md b/docs/internal.md index 49c6f16..df4d339 100644 --- a/docs/internal.md +++ b/docs/internal.md @@ -118,16 +118,16 @@ arbitrary program is hard. There are three standard approaches, available as options in `perf record`: - `--call-graph=dwarf` uses the DWARF debugging information - + - `--call-graph=fp` follows a chain of frame pointers - + - `--call-graph=lbr` uses the Last Branch Record hardware support However, all of these have disadvantages: - DWARF exists to support debuggers, and so is designed for flexibility rather than speed. - + This flexibility is necessary to handle the hard cases of C stack frames: for instance, a C program can define a variable-length array of ints on the stack, and store its length (in ints, not diff --git a/dune-project b/dune-project index 6cc1859..20289b5 100644 --- a/dune-project +++ b/dune-project @@ -14,4 +14,4 @@ (synopsis "Streaming client for Memprof") (description "Generates compact traces of a program's memory use.") (depends - (ocaml (>= 4.11.0)))) + (ocaml (or (>= 5.3.0) (and (>= 4.11.0) (< 5.0)))))) diff --git a/memtrace.opam b/memtrace.opam index 256fa14..936da4f 100644 --- a/memtrace.opam +++ b/memtrace.opam @@ -10,7 +10,7 @@ homepage: "https://github.com/janestreet/memtrace" bug-reports: "https://github.com/janestreet/memtrace/issues" depends: [ "dune" {>= "2.3"} - "ocaml" {>= "4.11.0"} + "ocaml" {>= "5.3.0" | >= "4.11.0" & < "5.0"} ] build: [ ["dune" "subst"] {pinned} diff --git a/src/memprof_tracer.ml b/src/memprof_tracer.ml index 316bf22..757fb9d 100644 --- a/src/memprof_tracer.ml +++ b/src/memprof_tracer.ml @@ -106,10 +106,10 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace = | exception e -> mark_failed s e) } in curr_active_tracer := Some s; bytes_before_ext_sample := draw_sampler_bytes s; - Gc.Memprof.start + let _t = Gc.Memprof.start ~sampling_rate ~callstack_size:max_int - tracker; + tracker in s let stop s = diff --git a/src/memtrace.ml b/src/memtrace.ml index a40f72f..3eaf01e 100644 --- a/src/memtrace.ml +++ b/src/memtrace.ml @@ -61,7 +61,7 @@ let trace_if_requested ?context ?sampling_rate () = let sampling_rate = match Sys.getenv_opt "MEMTRACE_RATE" with | Some rate -> check_rate (float_of_string_opt rate) - | None | Some "" -> + | None -> match sampling_rate with | Some _ -> check_rate sampling_rate | None -> default_sampling_rate diff --git a/src/trace.ml b/src/trace.ml index d5e8a24..97a9569 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -348,10 +348,15 @@ let make_writer dest ?getpid (info : Info.t) = module IntTbl = Hashtbl.MakeSeeded (struct type t = int - let seeded_hash _seed (id : t) = + + let hash _seed (id : t) = let h = id * 189696287 in h lxor (h lsr 23) - let hash = seeded_hash + + (* Required for OCaml >= 5.0.0, but causes errors for older compilers + because it is an unused value declaration. *) + let [@warning "-32"] seeded_hash = hash + let equal (a : t) (b : t) = a = b end) @@ -754,7 +759,7 @@ module Writer = struct (* Unfortunately, efficient access to the backtrace is not possible with the current Printexc API, even though internally it's an int array. For now, wave the Obj.magic wand. There's a PR to fix this: - https://github.com/ocaml/ocaml/pull/9663 *) + https://github.com/ocaml/ocaml/pull/9663 *) (* TODO Fix this since 4.12*) let location_code_array_of_raw_backtrace (b : Printexc.raw_backtrace) = (Obj.magic b : Location_code.t array) @@ -768,7 +773,7 @@ module Writer = struct let slot = convert_raw_backtrace_slot slot in match Slot.location slot with | None -> tail - | Some { filename; line_number; start_char; end_char } -> + | Some { filename; line_number; start_char; end_char; _} -> let defname = match Slot.name slot with Some n -> n | _ -> "??" in { filename; line=line_number; start_char; end_char; defname }::tail in get_locations (get_raw_backtrace_slot callstack i) |> List.rev From 5419af9ef5c408893bec166e23a2afde79b643fd Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Wed, 9 Oct 2024 13:03:51 +1100 Subject: [PATCH 2/6] Synchronise access to write using Mutex and Atomics Signed-off-by: Tim McGilchrist --- src/memprof_tracer.ml | 104 ++++++++++++++++++------------------------ 1 file changed, 45 insertions(+), 59 deletions(-) diff --git a/src/memprof_tracer.ml b/src/memprof_tracer.ml index 757fb9d..b4608a8 100644 --- a/src/memprof_tracer.ml +++ b/src/memprof_tracer.ml @@ -1,53 +1,39 @@ type t = - { mutable locked : bool; - mutable locked_ext : bool; - mutable failed : bool; + { mutable failed : bool; mutable stopped : bool; + mutex : Mutex.t; report_exn : exn -> unit; trace : Trace.Writer.t; ext_sampler : Geometric_sampler.t; } -let curr_active_tracer : t option ref = ref None +let curr_active_tracer : t option Atomic.t = Atomic.make None -let active_tracer () = !curr_active_tracer +let active_tracer () = Atomic.get curr_active_tracer -let bytes_before_ext_sample = ref max_int +let bytes_before_ext_sample = Atomic.make max_int let draw_sampler_bytes t = Geometric_sampler.draw t.ext_sampler * (Sys.word_size / 8) let[@inline never] rec lock_tracer s = - if s.locked then - if s.locked_ext then false - else (Thread.yield (); lock_tracer s) + (* Try unlocking mutex returning true if success or + Thread.yield () until it can acquire the mutex successfully. + *) + if Mutex.try_lock s.mutex then + true else if s.failed then false else - (s.locked <- true; true) - -let[@inline never] rec lock_tracer_ext s = - if s.locked then - (Thread.yield (); lock_tracer_ext s) - else if s.failed then - false - else - (s.locked <- true; s.locked_ext <- true; true) + (Thread.yield (); lock_tracer s) let[@inline never] unlock_tracer s = - assert (s.locked && not s.locked_ext && not s.failed); - s.locked <- false - -let[@inline never] unlock_tracer_ext s = - assert (s.locked && s.locked_ext && not s.failed); - s.locked_ext <- false; - s.locked <- false + assert (not s.failed); + Mutex.unlock s.mutex let[@inline never] mark_failed s e = - assert (s.locked && not s.failed); s.failed <- true; - s.locked <- false; - s.locked_ext <- false; - s.report_exn e + s.report_exn e; + Mutex.unlock s.mutex let default_report_exn e = match e with @@ -63,7 +49,8 @@ let default_report_exn e = let start ?(report_exn=default_report_exn) ~sampling_rate trace = let ext_sampler = Geometric_sampler.make ~sampling_rate () in - let s = { trace; locked = false; locked_ext = false; stopped = false; failed = false; + let mutex = Mutex.create () in + let s = { trace; mutex; stopped = false; failed = false; report_exn; ext_sampler } in let tracker : (_,_) Gc.Memprof.tracker = { alloc_minor = (fun info -> @@ -75,8 +62,11 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace = ~callstack:info.callstack with | r -> unlock_tracer s; Some r - | exception e -> mark_failed s e; None - end else None); + | exception e -> + mark_failed s e; + None + end + else None); alloc_major = (fun info -> if lock_tracer s then begin match Trace.Writer.put_alloc_with_raw_backtrace trace (Trace.Timestamp.now ()) @@ -104,68 +94,64 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace = match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with | () -> unlock_tracer s | exception e -> mark_failed s e) } in - curr_active_tracer := Some s; - bytes_before_ext_sample := draw_sampler_bytes s; - let _t = Gc.Memprof.start - ~sampling_rate - ~callstack_size:max_int - tracker in + Atomic.set curr_active_tracer (Some s); + Atomic.set bytes_before_ext_sample (draw_sampler_bytes s); + ignore (Gc.Memprof.start ~sampling_rate ~callstack_size:max_int tracker); s let stop s = if not s.stopped then begin s.stopped <- true; Gc.Memprof.stop (); - if lock_tracer s then begin - try Trace.Writer.close s.trace with e -> mark_failed s e - end; - curr_active_tracer := None + Mutex.protect s.mutex (fun () -> + try Trace.Writer.close s.trace + with e -> + (s.failed <- true; s.report_exn e); + Atomic.set curr_active_tracer None + ) end let[@inline never] ext_alloc_slowpath ~bytes = - match !curr_active_tracer with - | None -> bytes_before_ext_sample := max_int; None + match Atomic.get curr_active_tracer with + | None -> Atomic.set bytes_before_ext_sample max_int; None | Some s -> - if lock_tracer_ext s then begin + if lock_tracer s then begin match let bytes_per_word = Sys.word_size / 8 in (* round up to an integer number of words *) let size_words = (bytes + bytes_per_word - 1) / bytes_per_word in - let samples = ref 0 in - while !bytes_before_ext_sample <= 0 do - bytes_before_ext_sample := - !bytes_before_ext_sample + draw_sampler_bytes s; - incr samples + let samples = Atomic.make 0 in + while Atomic.get bytes_before_ext_sample <= 0 do + ignore (Atomic.fetch_and_add bytes_before_ext_sample (draw_sampler_bytes s)); + Atomic.incr samples done; - assert (!samples > 0); + assert (Atomic.get samples > 0); let callstack = Printexc.get_callstack max_int in Some (Trace.Writer.put_alloc_with_raw_backtrace s.trace (Trace.Timestamp.now ()) ~length:size_words - ~nsamples:!samples + ~nsamples:(Atomic.get samples) ~source:External ~callstack) with - | r -> unlock_tracer_ext s; r + | r -> unlock_tracer s; r | exception e -> mark_failed s e; None end else None - type ext_token = Trace.Obj_id.t let ext_alloc ~bytes = - let n = !bytes_before_ext_sample - bytes in - bytes_before_ext_sample := n; + let n = Atomic.fetch_and_add bytes_before_ext_sample (- bytes) in if n <= 0 then ext_alloc_slowpath ~bytes else None let ext_free id = - match !curr_active_tracer with + match Atomic.get curr_active_tracer with | None -> () | Some s -> - if lock_tracer_ext s then begin + if lock_tracer s then begin match Trace.Writer.put_collect s.trace (Trace.Timestamp.now ()) id with - | () -> unlock_tracer_ext s; () + | () -> unlock_tracer s; () | exception e -> mark_failed s e; () end From 1e56edde1fa288b2acea1de021344c360d7f31eb Mon Sep 17 00:00:00 2001 From: kash Date: Wed, 7 May 2025 21:46:24 +0530 Subject: [PATCH 3/6] Fix lock_tracer logic for external allocations Signed-off-by: Tim McGilchrist --- src/memprof_tracer.ml | 55 ++++++++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/src/memprof_tracer.ml b/src/memprof_tracer.ml index b4608a8..34104d7 100644 --- a/src/memprof_tracer.ml +++ b/src/memprof_tracer.ml @@ -1,6 +1,6 @@ type t = - { mutable failed : bool; - mutable stopped : bool; + { failed : bool Atomic.t; + stopped : bool Atomic.t; mutex : Mutex.t; report_exn : exn -> unit; trace : Trace.Writer.t; @@ -15,24 +15,27 @@ let bytes_before_ext_sample = Atomic.make max_int let draw_sampler_bytes t = Geometric_sampler.draw t.ext_sampler * (Sys.word_size / 8) -let[@inline never] rec lock_tracer s = - (* Try unlocking mutex returning true if success or - Thread.yield () until it can acquire the mutex successfully. - *) - if Mutex.try_lock s.mutex then - true - else if s.failed then +let[@inline never] lock_tracer s = + if Atomic.get s.failed then false - else - (Thread.yield (); lock_tracer s) + (* During external allocations or closing, a thread may try to obtain + a lock it already holds. In that case, Mutex.lock will throw + an error and we can ignore it. *) + else begin + try + Mutex.lock s.mutex; + true + with + | Sys_error _ -> false + end let[@inline never] unlock_tracer s = - assert (not s.failed); + assert (not (Atomic.get s.failed)); Mutex.unlock s.mutex let[@inline never] mark_failed s e = - s.failed <- true; - s.report_exn e; + if (Atomic.compare_and_set s.failed false true) then + s.report_exn e; Mutex.unlock s.mutex let default_report_exn e = @@ -50,7 +53,7 @@ let default_report_exn e = let start ?(report_exn=default_report_exn) ~sampling_rate trace = let ext_sampler = Geometric_sampler.make ~sampling_rate () in let mutex = Mutex.create () in - let s = { trace; mutex; stopped = false; failed = false; + let s = { trace; mutex; stopped = Atomic.make false; failed = Atomic.make false; report_exn; ext_sampler } in let tracker : (_,_) Gc.Memprof.tracker = { alloc_minor = (fun info -> @@ -96,19 +99,23 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace = | exception e -> mark_failed s e) } in Atomic.set curr_active_tracer (Some s); Atomic.set bytes_before_ext_sample (draw_sampler_bytes s); - ignore (Gc.Memprof.start ~sampling_rate ~callstack_size:max_int tracker); + let _profile = Gc.Memprof.start ~sampling_rate ~callstack_size:max_int tracker in s let stop s = - if not s.stopped then begin - s.stopped <- true; + (* Call stop to stop sampling on the current profile. + Promotion and deallocation callbacks from a profile may run + after stop is called, however we ignore these callbacks when + stopping. + *) + if (Atomic.compare_and_set s.stopped false true) then begin Gc.Memprof.stop (); - Mutex.protect s.mutex (fun () -> - try Trace.Writer.close s.trace - with e -> - (s.failed <- true; s.report_exn e); - Atomic.set curr_active_tracer None - ) + if lock_tracer s then begin + try Trace.Writer.close s.trace with e -> + (Atomic.set s.failed true; s.report_exn e); + Mutex.unlock s.mutex + end; + Atomic.set curr_active_tracer None end let[@inline never] ext_alloc_slowpath ~bytes = From e315e2158b9e78d65cc9db86e2118d5e578fdf17 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Tue, 13 Feb 2024 11:34:03 +1100 Subject: [PATCH 4/6] Instructions for setting up multicore OCaml with statmemprof Signed-off-by: Tim McGilchrist --- README.md | 37 +++++++++++++++++++++++++++++++++++++ dune | 2 +- dune-project | 1 + examples/dune | 3 +++ examples/fib_par.ml | 28 ++++++++++++++++++++++++++++ memtrace.opam | 1 + 6 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 examples/dune create mode 100644 examples/fib_par.ml diff --git a/README.md b/README.md index 0597108..0ac7df6 100644 --- a/README.md +++ b/README.md @@ -23,3 +23,40 @@ command-line tools in bin/, but the recommended interface is the memtrace viewer, which lives at: https://github.com/janestreet/memtrace_viewer + +## Installation +These instructions are for using statmemprof with OCaml 5.3.0+trunk + +``` shell +# Setup a new Blank switch +opam switch create 5.3.0 --no-install +eval $(opam env --switch=5.3.0 --set-switch) + +# Install dune +opam install dune +``` + +Now we can get memory traces for programs, here is a multicore fibonacci program: + +``` shell +$ opam instal domainslib + +$ dune build examples + +# Run tracing on single domain +$ MEMTRACE=fib_par.ctf _build/default/examples/fib_par.exe 1 45 + +# On three domains +$ MEMTRACE=fib_par_2.ctf _build/default/examples/fib_par.exe 3 45 +``` + +these CTF files are viewable in `memtrace_viewer`. + +Install memtrace_viewer in another switch (5.1 will work since we only need to read and write trace files) + +``` shell +opam switch create 5.1.1 --no-install +opam install memtrace_viewer +memtrace-viewer ./fib_par_2.ctf +``` + diff --git a/dune b/dune index 4540083..33f11a8 100644 --- a/dune +++ b/dune @@ -1 +1 @@ -(dirs bin src test trace_ocamlopt) +(dirs bin src test trace_ocamlopt examples) diff --git a/dune-project b/dune-project index 20289b5..77cadcb 100644 --- a/dune-project +++ b/dune-project @@ -14,4 +14,5 @@ (synopsis "Streaming client for Memprof") (description "Generates compact traces of a program's memory use.") (depends + domainslib (ocaml (or (>= 5.3.0) (and (>= 4.11.0) (< 5.0)))))) diff --git a/examples/dune b/examples/dune new file mode 100644 index 0000000..cad9438 --- /dev/null +++ b/examples/dune @@ -0,0 +1,3 @@ +(executables + (libraries memtrace domainslib) + (names fib_par)) \ No newline at end of file diff --git a/examples/fib_par.ml b/examples/fib_par.ml new file mode 100644 index 0000000..0d6ce1d --- /dev/null +++ b/examples/fib_par.ml @@ -0,0 +1,28 @@ +(* fib_par.ml *) +let num_domains = try int_of_string Sys.argv.(1) with _ -> 1 +let n = try int_of_string Sys.argv.(2) with _ -> 1 + +(* Sequential Fibonacci *) +let rec fib n = + if n < 2 then 1 else fib (n - 1) + fib (n - 2) + +module T = Domainslib.Task + +let rec fib_par pool n = + let _ = Buffer.create 10000 in + if n > 20 then begin + let a = T.async pool (fun _ -> fib_par pool (n-1)) in + let b = T.async pool (fun _ -> fib_par pool (n-2)) in + T.await pool a + T.await pool b + end else + (* Call sequential Fibonacci if the available work is small *) + fib n + +let main () = + Memtrace.trace_if_requested ~context:"fib" (); + let pool = T.setup_pool ~num_domains:(num_domains - 1) () in + let res = T.run pool (fun _ -> fib_par pool n) in + T.teardown_pool pool; + Printf.printf "fib(%d) = %d\n" n res + +let _ = main () \ No newline at end of file diff --git a/memtrace.opam b/memtrace.opam index 936da4f..5d75f31 100644 --- a/memtrace.opam +++ b/memtrace.opam @@ -10,6 +10,7 @@ homepage: "https://github.com/janestreet/memtrace" bug-reports: "https://github.com/janestreet/memtrace/issues" depends: [ "dune" {>= "2.3"} + "domainslib" "ocaml" {>= "5.3.0" | >= "4.11.0" & < "5.0"} ] build: [ From 4c8955b81cc74d3e5331cf3f8c261b4e3ead0726 Mon Sep 17 00:00:00 2001 From: Dimitris Mostrous Date: Tue, 15 Sep 2026 15:10:58 +0100 Subject: [PATCH 5/6] Fix external sampling, MEMTRACE_RATE and locking defects Take a sample when an external allocation crosses the sampling threshold, rather than one allocation later. Treat an empty MEMTRACE_RATE as unset, so the rate falls back to the one given by the caller or to the default, rather than raising Invalid_argument. Re-test the failed flag after acquiring the tracer mutex. One domain can mark the tracer as failed while another is already waiting for the lock, which can cause an assertion failure in the waiting domain. Use an ordinary reference for the external sample count, which is only read and written inside the critical section. --- src/memprof_tracer.ml | 14 ++++++++------ src/memtrace.ml | 8 ++++---- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/memprof_tracer.ml b/src/memprof_tracer.ml index 34104d7..ffc15a0 100644 --- a/src/memprof_tracer.ml +++ b/src/memprof_tracer.ml @@ -24,7 +24,9 @@ let[@inline never] lock_tracer s = else begin try Mutex.lock s.mutex; - true + (* The failed flag can be set while we wait for the mutex, so test it + again once we hold the lock. *) + if Atomic.get s.failed then (Mutex.unlock s.mutex; false) else true with | Sys_error _ -> false end @@ -127,17 +129,17 @@ let[@inline never] ext_alloc_slowpath ~bytes = let bytes_per_word = Sys.word_size / 8 in (* round up to an integer number of words *) let size_words = (bytes + bytes_per_word - 1) / bytes_per_word in - let samples = Atomic.make 0 in + let samples = ref 0 in while Atomic.get bytes_before_ext_sample <= 0 do ignore (Atomic.fetch_and_add bytes_before_ext_sample (draw_sampler_bytes s)); - Atomic.incr samples + incr samples done; - assert (Atomic.get samples > 0); + assert (!samples > 0); let callstack = Printexc.get_callstack max_int in Some (Trace.Writer.put_alloc_with_raw_backtrace s.trace (Trace.Timestamp.now ()) ~length:size_words - ~nsamples:(Atomic.get samples) + ~nsamples:!samples ~source:External ~callstack) with @@ -148,7 +150,7 @@ let[@inline never] ext_alloc_slowpath ~bytes = type ext_token = Trace.Obj_id.t let ext_alloc ~bytes = - let n = Atomic.fetch_and_add bytes_before_ext_sample (- bytes) in + let n = Atomic.fetch_and_add bytes_before_ext_sample (- bytes) - bytes in if n <= 0 then ext_alloc_slowpath ~bytes else None let ext_free id = diff --git a/src/memtrace.ml b/src/memtrace.ml index 3eaf01e..d3d07fc 100644 --- a/src/memtrace.ml +++ b/src/memtrace.ml @@ -60,11 +60,11 @@ let trace_if_requested ?context ?sampling_rate () = in let sampling_rate = match Sys.getenv_opt "MEMTRACE_RATE" with - | Some rate -> check_rate (float_of_string_opt rate) - | None -> - match sampling_rate with + | None | Some "" -> + begin match sampling_rate with | Some _ -> check_rate sampling_rate - | None -> default_sampling_rate + | None -> default_sampling_rate end + | Some rate -> check_rate (float_of_string_opt rate) in let _s = start_tracing ~context ~sampling_rate ~filename in () From 874e70b283cf8bd7734d5c598dc176d0eb2547f3 Mon Sep 17 00:00:00 2001 From: Dimitris Mostrous Date: Tue, 15 Sep 2026 15:16:38 +0100 Subject: [PATCH 6/6] Allow the caller to supply the Memprof implementation Only one Memprof profile can run per domain, so a library that starts its own profile, such as memprof-limits, cannot be used together with memtrace. The caller can now pass the Memprof implementation that memtrace should use, so that both use the same profile. It defaults to the standard library's Gc.Memprof. Stopping the tracer also discards the profile, so no further callbacks arrive once tracing has ended. Starting tracing manually now takes a final unit argument. Requires OCaml 5.3 or later. domainslib is needed only for the examples. --- README.md | 7 +++++++ dune-project | 4 ++-- memtrace.opam | 4 ++-- src/memprof_tracer.ml | 17 ++++++++++++++--- src/memprof_tracer.mli | 14 +++++++++++++- src/memtrace.ml | 12 ++++++++---- src/memtrace.mli | 13 ++++++++++++- test/fork.ml | 2 +- test/trace.ml | 2 +- 9 files changed, 60 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 0ac7df6..bd7a158 100644 --- a/README.md +++ b/README.md @@ -60,3 +60,10 @@ opam install memtrace_viewer memtrace-viewer ./fib_par_2.ctf ``` + +## API changes + +- `start_tracing` and `trace_if_requested` take an optional + `?memprof:(module Memtrace.Memprof_sig)`, defaulting to `Gc.Memprof`. +- `start_tracing` takes a final `()`. +- Requires OCaml 5.3 or later. diff --git a/dune-project b/dune-project index 77cadcb..f4824e1 100644 --- a/dune-project +++ b/dune-project @@ -14,5 +14,5 @@ (synopsis "Streaming client for Memprof") (description "Generates compact traces of a program's memory use.") (depends - domainslib - (ocaml (or (>= 5.3.0) (and (>= 4.11.0) (< 5.0)))))) + (domainslib :with-test) + (ocaml (>= 5.3.0)))) diff --git a/memtrace.opam b/memtrace.opam index 5d75f31..16e3be3 100644 --- a/memtrace.opam +++ b/memtrace.opam @@ -10,8 +10,8 @@ homepage: "https://github.com/janestreet/memtrace" bug-reports: "https://github.com/janestreet/memtrace/issues" depends: [ "dune" {>= "2.3"} - "domainslib" - "ocaml" {>= "5.3.0" | >= "4.11.0" & < "5.0"} + "domainslib" {with-test} + "ocaml" {>= "5.3.0"} ] build: [ ["dune" "subst"] {pinned} diff --git a/src/memprof_tracer.ml b/src/memprof_tracer.ml index ffc15a0..cee7a55 100644 --- a/src/memprof_tracer.ml +++ b/src/memprof_tracer.ml @@ -1,7 +1,12 @@ +module type Memprof_sig = sig + include module type of Stdlib.Gc.Memprof +end + type t = { failed : bool Atomic.t; stopped : bool Atomic.t; mutex : Mutex.t; + stop_memprof : unit -> unit; report_exn : exn -> unit; trace : Trace.Writer.t; ext_sampler : Geometric_sampler.t; } @@ -52,10 +57,16 @@ let default_report_exn e = Printexc.print_backtrace stderr; flush stderr -let start ?(report_exn=default_report_exn) ~sampling_rate trace = +let default_memprof = (module Stdlib.Gc.Memprof : Memprof_sig) + +let start ?(report_exn=default_report_exn) ?(memprof = default_memprof) + ~sampling_rate trace = + let (module Memprof : Memprof_sig) = memprof in let ext_sampler = Geometric_sampler.make ~sampling_rate () in let mutex = Mutex.create () in + let profile : Memprof.t option ref = ref None in let s = { trace; mutex; stopped = Atomic.make false; failed = Atomic.make false; + stop_memprof = (fun () -> Memprof.stop (); Option.iter Memprof.discard !profile); report_exn; ext_sampler } in let tracker : (_,_) Gc.Memprof.tracker = { alloc_minor = (fun info -> @@ -101,7 +112,7 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace = | exception e -> mark_failed s e) } in Atomic.set curr_active_tracer (Some s); Atomic.set bytes_before_ext_sample (draw_sampler_bytes s); - let _profile = Gc.Memprof.start ~sampling_rate ~callstack_size:max_int tracker in + profile := Some (Memprof.start ~sampling_rate ~callstack_size:max_int tracker); s let stop s = @@ -111,7 +122,7 @@ let stop s = stopping. *) if (Atomic.compare_and_set s.stopped false true) then begin - Gc.Memprof.stop (); + s.stop_memprof (); if lock_tracer s then begin try Trace.Writer.close s.trace with e -> (Atomic.set s.failed true; s.report_exn e); diff --git a/src/memprof_tracer.mli b/src/memprof_tracer.mli index 28c1f1b..789745b 100644 --- a/src/memprof_tracer.mli +++ b/src/memprof_tracer.mli @@ -1,5 +1,17 @@ +module type Memprof_sig = sig + include module type of Stdlib.Gc.Memprof +end + type t -val start : ?report_exn:(exn -> unit) -> sampling_rate:float -> Trace.Writer.t -> t + +val default_memprof : (module Memprof_sig) + +val start : + ?report_exn:(exn -> unit) -> + ?memprof:(module Memprof_sig) -> + sampling_rate:float -> + Trace.Writer.t -> + t val stop : t -> unit val active_tracer : unit -> t option diff --git a/src/memtrace.ml b/src/memtrace.ml index d3d07fc..89fc53d 100644 --- a/src/memtrace.ml +++ b/src/memtrace.ml @@ -2,7 +2,11 @@ type tracer = Memprof_tracer.t let getpid64 () = Int64.of_int (Unix.getpid ()) -let start_tracing ~context ~sampling_rate ~filename = +module type Memprof_sig = Memprof_tracer.Memprof_sig + +let default_memprof = Memprof_tracer.default_memprof + +let start_tracing ?(memprof = default_memprof) ~context ~sampling_rate ~filename () = if Memprof_tracer.active_tracer () <> None then failwith "Only one Memtrace instance may be active at a time"; let fd = @@ -36,7 +40,7 @@ let start_tracing ~context ~sampling_rate ~filename = context; } in let trace = Trace.Writer.create fd ~getpid:getpid64 info in - Memprof_tracer.start ~sampling_rate trace + Memprof_tracer.start ~memprof ~sampling_rate trace let stop_tracing t = Memprof_tracer.stop t @@ -46,7 +50,7 @@ let () = let default_sampling_rate = 1e-6 -let trace_if_requested ?context ?sampling_rate () = +let trace_if_requested ?(memprof = default_memprof) ?context ?sampling_rate () = match Sys.getenv_opt "MEMTRACE" with | None | Some "" -> () | Some filename -> @@ -66,7 +70,7 @@ let trace_if_requested ?context ?sampling_rate () = | None -> default_sampling_rate end | Some rate -> check_rate (float_of_string_opt rate) in - let _s = start_tracing ~context ~sampling_rate ~filename in + let _s = start_tracing ~memprof ~context ~sampling_rate ~filename () in () module Trace = Trace diff --git a/src/memtrace.mli b/src/memtrace.mli index 18da678..17cdf9b 100644 --- a/src/memtrace.mli +++ b/src/memtrace.mli @@ -1,3 +1,7 @@ +module type Memprof_sig = Memprof_tracer.Memprof_sig + +val default_memprof : (module Memprof_sig) + (** If the MEMTRACE environment variable is set, begin tracing to the file it specifies, and continue tracing until the process exits. @@ -11,16 +15,23 @@ May raise Unix.Unix_error if the specified file cannot be opened, or Invalid_argument if the MEMTRACE_RATE parameter is ill-formed. *) -val trace_if_requested : ?context:string -> ?sampling_rate:float -> unit -> unit +val trace_if_requested : + ?memprof:(module Memprof_sig) -> + ?context:string -> + ?sampling_rate:float -> + unit -> + unit (** Tracing can also be manually started and stopped. *) type tracer (** Manually start tracing *) val start_tracing : + ?memprof:(module Memprof_sig) -> context:string option -> sampling_rate:float -> filename:string -> + unit -> tracer (** Manually stop tracing *) diff --git a/test/fork.ml b/test/fork.ml index 8549d70..6f2597d 100644 --- a/test/fork.ml +++ b/test/fork.ml @@ -1,7 +1,7 @@ let test_fork ~quick_exit () = let filename = Filename.temp_file "memtrace" "ctf" in Unix.putenv "MEMTRACE" filename; - let tr = Memtrace.start_tracing ~context:None ~sampling_rate:1. ~filename in + let tr = Memtrace.start_tracing ~context:None ~sampling_rate:1. ~filename () in let alloc_before = 1234 and alloc_after = 7364 and alloc_child = 42 in let _ = Sys.opaque_identity Array.make alloc_before "a" in begin match Unix.fork () with diff --git a/test/trace.ml b/test/trace.ml index 13e163d..d0cd968 100644 --- a/test/trace.ml +++ b/test/trace.ml @@ -38,7 +38,7 @@ let rec long_bt = function let go () = let filename = Filename.temp_file "memtrace" "ctf" in - let t = Memtrace.start_tracing ~context:(Some "ctx") ~sampling_rate:0.1 ~filename in + let t = Memtrace.start_tracing ~context:(Some "ctx") ~sampling_rate:0.1 ~filename () in leak (Array.make 4242 42); for _i = 1 to 10 do let n = long_bt 10_000 in