feat: skip recursive frames (#5)

OCaml is functional and loves recursion, but these recursive frames show up in the callstack. Pyroscope has a default limit of ~1k frames before it starts lumping them together as "other". This PR makes it so we essentially remove any duplicated recursive frames, resulting in an easier to read trace, and more function calls being explicitly recorded.

I think the con here is technically you won't be able to see say, "element # 10 to List.map takes a really long time", but I'd argue that's not really the point of continuous profiling, since we care about things en masse and how long functions overall take instead of specific instances.

I also added a .ocamlformat

## Test plan
run the example program, notice recursive calls to List.map on old pyro caml. run w/this PR and notice them all collapsed into 1.

Author: ajbt200128

.ocamlformat

@@ -0,0 +1,13 @@
+profile = conventional
+
+# Preserve begin/end or parentheses to group expressions. Discussed November
+# 2024 with mixed opinions. Some prefer the consistency of always using
+# parentheses. Others find it easier to visually parse large blocks when
+# delimited by begin/end. For now we'll relax the constraints and let people
+# experiment. We can easily move back to enforcing parens only if we want to.
+exp-grouping = preserve
+
+# Docstrings are supposed to be structured and parsable. We don't use them
+# properly, which makes ocamlformat 0.27.0 sad. Disable docstring parsing until
+# we get it together.
+parse-docstrings = false

dune-project

@@ -7,7 +7,7 @@
 (source
  (github semgrep/pyro-caml))
 
-; with ocaml linking exception
+; with ocaml linking exception?
 (license LGPL-2.1-only)
 
 (authors "Austin Theriault <austin@cutedogs.org>")
@@ -17,7 +17,7 @@
 (package
  (name pyro-caml-instruments)
  (synopsis "Pyroscope + OCaml = Pyro Caml")
- (depends ocaml logs digestif)
+ (depends ocaml logs digestif ppx_deriving)
  (tags ("profiling")))
 
 (package

lib/Stack_trace.ml

@@ -20,7 +20,11 @@
 type slot = Printexc.backtrace_slot
 
 (* What's sent via runtime events. this HAS to be marshalable*)
-type raw_stack_trace = {slots: slot array; domain_id: int; thread_name: string}
+type raw_stack_trace = {
+  slots : slot array;
+  domain_id : int;
+  thread_name : string;
+}
 
 let raw_stack_trace_of_backtrace bt : raw_stack_trace =
   (* Use the domain as the ID since runtime event sampling happens per domain *)
@@ -30,7 +34,7 @@ let raw_stack_trace_of_backtrace bt : raw_stack_trace =
   let name = if Domain.is_main_domain () then "main" else string_of_int did in
   (* if there aren't any slots then not much we can do *)
   let slots = Option.value ~default:[||] Printexc.(backtrace_slots bt) in
-  {slots; domain_id= did; thread_name= name}
+  { slots; domain_id = did; thread_name = name }
 
 (*****************************************************************************)
 (* Stack frames *)
@@ -39,39 +43,65 @@ let raw_stack_trace_of_backtrace bt : raw_stack_trace =
 (* Inlined functions are filtered out in ocaml_intf always right now, but we
    probably want to give that as an option at some point *)
 (* coupling: ocaml_intf *)
-type frame = {name: string; filename: string; line: int; inlined: bool}
+type frame = {
+  name : string;
+  filename : string;
+  line : int;
+  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 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 { 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 = "<unknown>";
+          filename = loc.filename;
+          line = loc.line_number;
+          inlined;
+        }
+  | None, None -> None
+
+(* 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
+   ~1000 stack frame limit, so if we iterate through say, 10k items there's a
+   good chance we may max out, which will cause any frames past the limit to be
+   dropped and instead replaced with a single frame that says "other"*)
+let compress frames =
+  let rec aux acc = function
+    | [] -> List.rev acc
+    | f1 :: f2 :: f3 :: (f4 :: f5 :: f6 :: _ as rest)
+      when equal_frame f1 f4 && equal_frame f2 f5 && equal_frame f3 f6 ->
+        aux acc rest
+    | f1 :: f2 :: (f3 :: f4 :: _ as rest)
+      when equal_frame f1 f3 && equal_frame f2 f4 ->
+        aux acc rest
+    | f1 :: (f2 :: _ as rest) when equal_frame f1 f2 -> aux acc rest
+    | f :: rest -> aux (f :: acc) rest
+  in
+  aux [] frames
 
 let stack_frames_of_slots slots =
-  slots
-  |> List.map (fun slot -> slot |> stack_frame_of_slot)
-  |> List.filter_map Fun.id
+  slots |> List.filter_map stack_frame_of_slot |> compress
 
 (*****************************************************************************)
 (* Stack traces *)
 (*****************************************************************************)
 (* coupling: ocaml_intf *)
-type t = {frames: frame list; thread_id: int; thread_name: string}
+type t = { frames : frame list; thread_id : int; thread_name : string }
 
 let t_of_raw_stack_trace raw_stack_trace =
   let frames = stack_frames_of_slots (Array.to_list raw_stack_trace.slots) in
-  { frames
-  ; thread_id= raw_stack_trace.domain_id
-  ; thread_name= raw_stack_trace.thread_name }
+  {
+    frames;
+    thread_id = raw_stack_trace.domain_id;
+    thread_name = raw_stack_trace.thread_name;
+  }

lib/dune

@@ -2,5 +2,7 @@
  (name pyro_caml_instruments)
  (public_name pyro-caml-instruments)
  (libraries runtime_events unix logs digestif)
+ (preprocess
+  (pps ppx_deriving.eq))
  (instrumentation.backend
   (ppx pyro-caml-ppx)))

pyro-caml-instruments.opam

@@ -12,6 +12,7 @@ depends: [
   "ocaml"
   "logs"
   "digestif"
+  "ppx_deriving"
   "odoc" {with-doc}
 ]
 build: [