diff --git a/example/dune b/example/dune index fd689e47..adb26a94 100644 --- a/example/dune +++ b/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) diff --git a/lib/Stack_trace.ml b/lib/Stack_trace.ml index 70517fdc..e75a3c8b 100644 --- a/lib/Stack_trace.ml +++ b/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;