diff --git a/Makefile b/Makefile index 22c91648..044ed649 100644 --- a/Makefile +++ b/Makefile @@ -37,3 +37,7 @@ shell: nix develop . release: vendor build-release + +# helpful for testing pyroscope integration +pyroscope: + docker run --rm -it -p 4040:4040 grafana/pyroscope:latest diff --git a/bindings/Pyro_caml_rust_bindings.ml b/bindings/Pyro_caml_rust_bindings.ml index 7430a049..10b5db6a 100644 --- a/bindings/Pyro_caml_rust_bindings.ml +++ b/bindings/Pyro_caml_rust_bindings.ml @@ -15,10 +15,9 @@ (* Bindings for the pyro-caml binary to the pyro caml instrumentation library *) let read_poll cursor interval = Pyro_caml_instruments.read_poll cursor interval - let create_cursor = Pyro_caml_instruments.create_cursor let () = (* Register them for binding into rust *) - Callback.register "read_poll_ml" read_poll ; + Callback.register "read_poll_ml" read_poll; Callback.register "create_cursor_ml" create_cursor diff --git a/example/Example.ml b/example/Example.ml index e3b18e21..19718c59 100644 --- a/example/Example.ml +++ b/example/Example.ml @@ -17,7 +17,7 @@ (* Prelude *) (*****************************************************************************) let example_func2 () = - My_module.do_short_thing () ; + My_module.do_short_thing (); My_module.alloc_thing () let example_func () = @@ -27,14 +27,18 @@ let example_func () = let example_func3 () = My_module.do_long_thing () let () = - Pyro_caml_instruments.with_memprof_sampler - @@ fun () -> - Printf.printf "Starting loop\n" ; - flush_all () ; + Pyro_caml_instruments.with_memprof_sampler @@ fun () -> + Printf.printf "Starting loop\n"; + flush_all (); let do_main_thing () = while true do - example_func () ; example_func3 () ; example_func () ; example_func3 () + example_func (); + example_func3 (); + example_func (); + example_func3 () done in - let domains = List.init 8 (fun _ -> Domain.spawn (fun () -> do_main_thing ())) in + let domains = + List.init 8 (fun _ -> Domain.spawn (fun () -> do_main_thing ())) + in List.iter Domain.join domains diff --git a/example/My_module.ml b/example/My_module.ml index d8150c04..c8b738df 100644 --- a/example/My_module.ml +++ b/example/My_module.ml @@ -17,7 +17,7 @@ (* Prelude *) (*****************************************************************************) -type t = {x: int; y: string} +type t = { x : int; y : string } external comp_and_callback : (unit -> unit) -> unit = "ml_comp_and_callback" @@ -27,17 +27,22 @@ let f x y z = let c = b - y in c +let rec non_tail_recursive_fold_right f lst acc = + match lst with + | [] -> acc + | x :: xs -> f x (non_tail_recursive_fold_right f xs acc) let alloc_thing () = let random_list = - List.init 1000 (fun _ -> - {x= Random.int 100000; y= string_of_int (Random.int 100000)} ) + List.init 2048 (fun _ -> + { x = Random.int 100000; y = string_of_int (Random.int 100000) }) in let _sorted = List.sort compare random_list in - List.iter - (fun x -> - if f x.x (String.length x.y) 100 mod 10 = 10000000000 then assert false ) - random_list + non_tail_recursive_fold_right + (fun x acc -> + if f x.x (String.length x.y) 100 mod 10 = 42 then assert false; + acc) + random_list () class stack_of_ints = object (_self) @@ -50,7 +55,7 @@ class stack_of_ints = method pop = (* pop method *) let result = List.hd the_list in - the_list <- List.tl the_list ; + the_list <- List.tl the_list; result method peek = @@ -66,19 +71,19 @@ let do_thing () = let stack = new stack_of_ints in for _i = 1 to 1000 do stack#push (Random.int 100000) - done ; + done; while stack#size > 0 do let _ = stack#pop in () - done ; + done; alloc_thing () let do_short_thing () = alloc_thing () let do_long_thing () = - alloc_thing () ; - alloc_thing () ; - alloc_thing () ; + alloc_thing (); + alloc_thing (); + alloc_thing (); comp_and_callback alloc_thing (* Example object *) diff --git a/flake.nix b/flake.nix index 67bd85de..50795dbf 100644 --- a/flake.nix +++ b/flake.nix @@ -31,7 +31,15 @@ }; scope = on.buildOpamProject' { repos = [ "${opam-repository}" ]; } ./. query; overlay = final: prev: { - # You can add overrides here + # For the custom temp OCaml fork + ocaml-compiler = prev.ocaml-compiler.overrideAttrs (old: { + src = pkgs.fetchFromGitHub { + owner = "semgrep"; + repo = "ocaml"; + rev = "d50385f9f68efbcf455af0c8231587ee435fe21b"; + sha256 = "sha256-UYylbIaXcF4XEGlU1wXbCHdImAKaQYdrzXCucm/dgZ8="; + }; + }); }; scope' = scope.overrideScope overlay; # Packages from devPackagesQuery diff --git a/lib/Event.ml b/lib/Event.ml index 9bb6673b..2d8cc010 100644 --- a/lib/Event.ml +++ b/lib/Event.ml @@ -26,11 +26,12 @@ module Hash = Digest.MD5 profiler *) type t = | Point of (float * Stack_trace.raw_stack_trace) - | Partial of {id: Hash.t; bytes: Bytes.t; part: int; part_count: int} + | Partial of { id : Hash.t; bytes : Bytes.t; part : int; part_count : int } type marshaled = bytes * int -let make_partial id part_count part bytes = Partial {id; bytes; part; part_count} +let make_partial id part_count part bytes = + Partial { id; bytes; part; part_count } let split_bytes bytes size = let rec aux offset parts = @@ -55,7 +56,7 @@ let marshal_event ?(max_size = 800) e = let marshaled_event, len = marshal e in (* Max size of runtime event type payload *) (* https://ocaml.org/manual/5.3/api/Runtime_events.Type.html *) - if len <= 1024 then [(marshaled_event, len)] + if len <= 1024 then [ (marshaled_event, len) ] else (* if it's bigger split it up! *) let id = Hash.bytes marshaled_event in @@ -73,7 +74,7 @@ type Runtime_events.User.tag += Perf_event_tag let perf_event_type = let encode (bytes : bytes) ((marshaled, len) : marshaled) : int = - Bytes.blit marshaled 0 bytes 0 len ; + Bytes.blit marshaled 0 bytes 0 len; len in let decode (bytes : bytes) (len : int) : marshaled = (bytes, len) in @@ -99,13 +100,11 @@ type event_buffer = (Hash.t, (int * Bytes.t) list) Hashtbl.t let event_of_perf_event buffer (marshaled, _) : t = let event = Marshal.from_bytes marshaled 0 in match event with - | Partial {id; bytes; part_count; part} -> + | Partial { id; bytes; part_count; part } -> let parts = match Hashtbl.find_opt buffer id with - | Some parts -> - (part, bytes) :: parts - | None -> - [(part, bytes)] + | Some parts -> (part, bytes) :: parts + | None -> [ (part, bytes) ] in let parts = List.sort_uniq (fun (id1, _) (id2, _) -> Int.compare id1 id2) parts @@ -118,16 +117,15 @@ let event_of_perf_event buffer (marshaled, _) : t = let new_acc = Bytes.create (Bytes.length acc + Bytes.length bytes) in - Bytes.blit acc 0 new_acc 0 (Bytes.length acc) ; + Bytes.blit acc 0 new_acc 0 (Bytes.length acc); Bytes.blit bytes 0 new_acc (Bytes.length acc) - (Bytes.length bytes) ; - new_acc ) + (Bytes.length bytes); + new_acc) (Bytes.create 0) in - Hashtbl.remove buffer id ; - Marshal.from_bytes full_bytes 0 ) + Hashtbl.remove buffer id; + Marshal.from_bytes full_bytes 0) else ( - Hashtbl.replace buffer id parts ; - event ) - | _ -> - event + Hashtbl.replace buffer id parts; + event) + | _ -> event diff --git a/lib/Pyro_caml_instruments.ml b/lib/Pyro_caml_instruments.ml index 16719c07..834bce04 100644 --- a/lib/Pyro_caml_instruments.ml +++ b/lib/Pyro_caml_instruments.ml @@ -45,18 +45,19 @@ let tracker : (unit, unit) Gc.Memprof.tracker = Printexc.get_callstack in the other functions. Plus for some reason the memprof backtraces seem way more comprehensive than those from Printexc.get_callstack *) - let alloc_minor {Gc.Memprof.callstack; _} = - emit_point_event callstack ; + let alloc_minor { Gc.Memprof.callstack; _ } = + emit_point_event callstack; (* Don't care about tacking on any data to memory *) None in - let alloc_major {Gc.Memprof.callstack; _} = - emit_point_event callstack ; None + let alloc_major { Gc.Memprof.callstack; _ } = + emit_point_event callstack; + None in let promote () = None in let dealloc_minor = Fun.id in let dealloc_major = Fun.id in - {Gc.Memprof.alloc_minor; alloc_major; promote; dealloc_minor; dealloc_major} + { Gc.Memprof.alloc_minor; alloc_major; promote; dealloc_minor; dealloc_major } (* 1e-6 is nice but chosen somewhat randomly. Too high and you end up sending too many points and overwhelming the profiler, too little and you don't get @@ -64,7 +65,9 @@ let tracker : (unit, unit) Gc.Memprof.tracker = let with_memprof_sampler ?(sampling_rate = 1e-6) f = let memprof = Gc.Memprof.start ~sampling_rate tracker in Fun.protect - ~finally:(fun () -> Gc.Memprof.stop () ; Gc.Memprof.discard memprof) + ~finally:(fun () -> + Gc.Memprof.stop (); + Gc.Memprof.discard memprof) f let maybe_with_memprof_sampler ?sampling_rate f = @@ -74,7 +77,6 @@ let maybe_with_memprof_sampler ?sampling_rate f = (* Profiler code *) (*****************************************************************************) let create_cursor path pid = Runtime_events.create_cursor (Some (path, pid)) - let empty_callbacks = Runtime_events.Callbacks.create () (* Minimize work we do in process event since the instrumented program can write @@ -83,8 +85,7 @@ let process_event now interval sample_points = function | Point (time, raw_st) -> if now -. time < interval then sample_points := (time, raw_st) :: !sample_points - | Partial _ -> - () + | Partial _ -> () let read_poll ?(max_events = None) ?(callbacks = empty_callbacks) cursor interval = @@ -97,7 +98,7 @@ let read_poll ?(max_events = None) ?(callbacks = empty_callbacks) cursor _event_t (e : marshaled) -> e |> event_of_perf_event event_buffer - |> process_event now interval sample_points ) + |> process_event now interval sample_points) callbacks in (* TODO? Multithread this? *) @@ -113,9 +114,9 @@ let read_poll ?(max_events = None) ?(callbacks = empty_callbacks) cursor don't have a sample within 1ms or some other resolution of the sample time *) List.sort (fun (a_time, _) (b_time, _) -> - Float.compare (now -. a_time) (now -. b_time) ) + Float.compare (now -. a_time) (now -. b_time)) |> List.map (fun (_, raw_st) -> Stack_trace.t_of_raw_stack_trace raw_st) |> List.sort_uniq (fun a b -> - Int.compare a.Stack_trace.thread_id b.Stack_trace.thread_id ) + Int.compare a.Stack_trace.thread_id b.Stack_trace.thread_id) in sample_points diff --git a/lib/Pyro_caml_instruments.mli b/lib/Pyro_caml_instruments.mli index 03978f37..2b6ecff5 100644 --- a/lib/Pyro_caml_instruments.mli +++ b/lib/Pyro_caml_instruments.mli @@ -22,11 +22,11 @@ val create_cursor : string -> int -> Runtime_events.cursor from the given [path] and [pid]. *) val read_poll : - ?max_events:int option - -> ?callbacks:Runtime_events.Callbacks.t - -> Runtime_events.cursor - -> float - -> Stack_trace.t list + ?max_events:int option -> + ?callbacks:Runtime_events.Callbacks.t -> + Runtime_events.cursor -> + float -> + Stack_trace.t list (** [read_poll cursor sample_interval] will read the profiling runtime events from the given cursor, and will give attempt to give a single {!Stack_trace.t} per every unique thread id, within [sample_interval] of the diff --git a/lib/Stack_trace.ml b/lib/Stack_trace.ml index fbd46a36..70517fdc 100644 --- a/lib/Stack_trace.ml +++ b/lib/Stack_trace.ml @@ -44,31 +44,26 @@ let raw_stack_trace_of_backtrace bt : raw_stack_trace = probably want to give that as an option at some point *) (* coupling: ocaml_intf *) type frame = { - name : string; - filename : string; - line : int; + name : string option; + filename : string option; + line : int option; inlined : bool; [@eq.skip] (* We really don't care about if a function is inlined for equality*) } [@@deriving eq] -let stack_frame_of_slot (slot : Printexc.backtrace_slot) : frame option = - let loc = Printexc.Slot.location slot in +let other_frame = + { name = Some "other"; filename = None; line = None; inlined = false } + +let stack_frame_of_slot (slot : Printexc.backtrace_slot) : frame = + let filename, line = + match Printexc.Slot.location slot with + | Some loc -> (Some loc.filename, Some loc.line_number) + | None -> (None, None) + in let name = Printexc.Slot.name slot in let inlined = Printexc.Slot.is_inline slot in - match (loc, name) with - | Some loc, Some name -> - Some { name; filename = loc.filename; line = loc.line_number; inlined } - | None, Some name -> Some { name; filename = ""; line = 0; inlined } - | Some loc, None -> - Some - { - name = ""; - filename = loc.filename; - line = loc.line_number; - inlined; - } - | None, None -> None + { name; filename; line; inlined } (* Looking ahead by up to 3 can be useful for recursive functions to make them much more legible. E.g. List.map can be very recursive, and pyroscope has a @@ -90,7 +85,7 @@ let compress frames = aux [] frames let stack_frames_of_slots slots = - slots |> List.filter_map stack_frame_of_slot |> compress + slots |> List.map stack_frame_of_slot |> compress (*****************************************************************************) (* Stack traces *) diff --git a/src/ocaml_intf.rs b/src/ocaml_intf.rs index fcc22abd..dde3c660 100644 --- a/src/ocaml_intf.rs +++ b/src/ocaml_intf.rs @@ -1,6 +1,6 @@ -use std::path::Path; +use std::{collections::LinkedList, path::Path}; -use ocaml::Runtime; +use ocaml::{FromValue, Runtime}; use pyroscope::{ backend::{BackendConfig, StackFrame, StackTrace}, PyroscopeError, @@ -45,9 +45,9 @@ impl From for CamlIntfError { #[derive(ocaml::ToValue, ocaml::FromValue, Debug)] struct CamlStackFrame { - name: String, - filename: String, - line: ocaml::Int, + name: Option, + filename: Option, + line: Option, inlined: bool, } @@ -56,19 +56,19 @@ impl From for StackFrame { fn from(frame: CamlStackFrame) -> Self { StackFrame { module: None, - name: Some(frame.name), - filename: Some(frame.filename), + name: frame.name, + filename: frame.filename, relative_path: None, absolute_path: None, - line: Some(frame.line as u32), + line: frame.line.map(|l| l as u32), } } } #[derive(ocaml::ToValue, ocaml::FromValue)] pub struct CamlStackTrace { - frames: ocaml::List, - thread_id: ocaml::Int, + frames: LinkedList, + thread_id: usize, thread_name: String, } @@ -76,7 +76,6 @@ impl CamlStackTrace { pub fn into_stack_trace(self, backend_config: &BackendConfig, pid: u32) -> StackTrace { let frames = self .frames - .into_vec() .into_iter() .filter(|f| !f.inlined) .map(|f| f.into()) @@ -94,7 +93,7 @@ impl CamlStackTrace { pub type Cursor = ocaml::Value; ocaml::import! { - fn read_poll_ml(cursor:Cursor, interval:ocaml::Float) -> ocaml::List; + fn read_poll_ml(cursor:Cursor, interval:ocaml::Float) -> ocaml::List; fn create_cursor_ml(path:String, pid:ocaml::Int) -> Cursor; } @@ -109,7 +108,13 @@ pub fn read_poll( // but we assume the caller must ensure the gc is valid, and we convert the // path and int for the caller, so there is no risk they coerced a bad // value into an ocaml::Value - Ok(unsafe { read_poll_ml(gc, cursor, interval as ocaml::Float) }?.into_vec()) + Ok( + unsafe { read_poll_ml(gc, cursor, interval as ocaml::Float) }? + .into_vec() + .into_iter() + .map(CamlStackTrace::from_value) + .collect(), + ) } pub fn create_cursor(gc: &Runtime, path: &Path, pid: u32) -> Cursor {