feat: skip recursive frames

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 <[email protected]>")
@@ -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: [