better compress location?

Author: ajbt200128

example/dune

@@ -4,8 +4,6 @@
  (public_name example)
  (libraries pyro-caml-instruments unix)
  (modes exe)
- (preprocess
-  (pps ppx_pyro_caml --auto))
  (foreign_stubs
   (language c)
   (names example_stubs)

lib/Stack_trace.ml

@@ -19,9 +19,50 @@
 
 type slot = Printexc.backtrace_slot
 
+let equal_slot s1 s2 =
+  let name_eq =
+    Option.equal String.equal (Printexc.Slot.name s1) (Printexc.Slot.name s2)
+  in
+  let loc1 = Printexc.Slot.location s1 in
+  let loc2 = Printexc.Slot.location s2 in
+  let loc_eq =
+    match (loc1, loc2) with
+    | None, None -> true
+    | Some l1, Some l2 ->
+        l1.filename = l2.filename && l1.line_number = l2.line_number
+    | _, _ -> false
+  in
+  name_eq && loc_eq
+
+(* 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".
+
+   It's also nice to do this on the client side since it reduces how much data
+   we have to turn into runtime events and reduces the overall number of events
+   since there will be less partial events needed.
+*)
+let compress_slot_array array =
+  (* TODO how to do this inline w/an array? *)
+  let array_list = Array.to_list array in
+  let rec aux acc = function
+    | [] -> List.rev acc
+    | s1 :: s2 :: s3 :: (s4 :: s5 :: s6 :: _ as rest)
+      when equal_slot s1 s4 && equal_slot s2 s5 && equal_slot s3 s6 ->
+        aux acc rest
+    | s1 :: s2 :: (s3 :: s4 :: _ as rest)
+      when equal_slot s1 s3 && equal_slot s2 s4 ->
+        aux acc rest
+    | s1 :: (s2 :: _ as rest) when equal_slot s1 s2 -> aux acc rest
+    | s :: rest -> aux (s :: acc) rest
+  in
+  aux [] array_list
+
 (* What's sent via runtime events. this HAS to be marshalable*)
 type raw_stack_trace = {
-  slots : slot array;
+  slots : slot list;
   domain_id : int;
   thread_name : string;
 }
@@ -33,7 +74,12 @@ let raw_stack_trace_of_backtrace bt : raw_stack_trace =
   (* Nice to call it main but probably not necessary *)
   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
+  let slots =
+    bt
+    |> Printexc.(backtrace_slots)
+    |> Option.map compress_slot_array
+    |> Option.value ~default:[]
+  in
   { slots; domain_id = did; thread_name = name }
 
 (*****************************************************************************)
@@ -65,27 +111,7 @@ let stack_frame_of_slot (slot : Printexc.backtrace_slot) : frame =
   let inlined = Printexc.Slot.is_inline slot in
   { 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
-   ~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 stack_frame_of_slot |> compress
+let stack_frames_of_slots = List.map stack_frame_of_slot
 
 (*****************************************************************************)
 (* Stack traces *)
@@ -94,7 +120,7 @@ let stack_frames_of_slots slots =
 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
+  let frames = stack_frames_of_slots raw_stack_trace.slots in
   {
     frames;
     thread_id = raw_stack_trace.domain_id;