chore: formatting + cleanup types

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

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

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

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 *)

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

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

lib/Pyro_caml_instruments.ml

@@ -45,26 +45,29 @@ 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
    enough info *)
 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

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

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 = "<unknown>"; line = 0; inlined }
-  | Some loc, None ->
-      Some
-        {
-          name = "<unknown>";
-          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 *)