From a829cc5d2b29fc1c115b872883ac603289ca45e6 Mon Sep 17 00:00:00 2001 From: Josiah White Date: Sat, 7 Jun 2025 20:05:00 -0500 Subject: [PATCH 01/30] Add support for ptwrite events Signed-off-by: Josiah White --- src/event.ml | 4 ++ src/event.mli | 4 ++ src/for_range.ml | 6 ++- src/perf_capabilities.ml | 15 +++++++ src/perf_capabilities.mli | 1 + src/perf_decode.ml | 88 ++++++++++++++++++++++++++++++++++++++- src/perf_tool_backend.ml | 60 +++++++++++++++----------- src/trace.ml | 5 ++- src/trace_writer.ml | 27 +++++++++++- 9 files changed, 180 insertions(+), 30 deletions(-) diff --git a/src/event.ml b/src/event.ml index 24694485c..e3c653361 100644 --- a/src/event.ml +++ b/src/event.ml @@ -83,6 +83,10 @@ module Ok = struct ; count : int ; name : Collection_mode.Event.Name.t } + | Ptwrite of + { location : Location.t + ; data : string + } [@@deriving sexp, bin_io] end diff --git a/src/event.mli b/src/event.mli index 929854d07..b906c3118 100644 --- a/src/event.mli +++ b/src/event.mli @@ -55,6 +55,10 @@ module Ok : sig ; count : int ; name : Collection_mode.Event.Name.t } (** Represents counter based events collected through sampling. *) + | Ptwrite of + { location : Location.t + ; data : string + } (** Represents ptwrite events collected through Intel PT using PTWRITE. *) [@@deriving sexp] end diff --git a/src/for_range.ml b/src/for_range.ml index 1ac527726..b0c212e9b 100644 --- a/src/for_range.ml +++ b/src/for_range.ml @@ -25,7 +25,10 @@ let range_hit_times ~decode_events ~range_symbols = let is_start symbol = String.(Symbol.display_name symbol = start_symbol) in let is_stop symbol = String.(Symbol.display_name symbol = stop_symbol) in Pipe.filter_map events ~f:(function - | Error _ | Ok { data = Power _; _ } | Ok { data = Event_sample _; _ } -> None + | Error _ + | Ok { data = Power _; _ } + | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } -> None | Ok { data = Trace trace; time; _ } -> (match trace.kind with | Some Call -> @@ -93,6 +96,7 @@ let decode_events_and_annotate ~decode_events ~range_symbols = | Ok { data = Power _; _ } | Ok { data = Stacktrace_sample _; _ } | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } | Error _ -> hits, in_filtered_region) in ( (hits, in_filtered_region) diff --git a/src/perf_capabilities.ml b/src/perf_capabilities.ml index 269b97fef..8022d871a 100644 --- a/src/perf_capabilities.ml +++ b/src/perf_capabilities.ml @@ -8,6 +8,7 @@ let kcore = bit 2 let snapshot_on_exit = bit 3 let last_branch_record = bit 4 let dlfilter = bit 5 +let ptwrite = bit 6 include Flags.Make (struct let allow_intersecting = false @@ -20,6 +21,7 @@ include Flags.Make (struct ; kcore, "kcore" ; last_branch_record, "last_branch_record" ; dlfilter, "dlfilter" + ; ptwrite, "ptwrite" ] ;; end) @@ -56,6 +58,18 @@ let supports_configurable_psb_period () = | Sys_error _ -> false ;; +let supports_ptwrite () = + try + let ptwrite_cap = + In_channel.read_all "/sys/bus/event_source/devices/intel_pt/caps/ptwrite" + in + String.( = ) ptwrite_cap "1\n" + with + (* Even if this file is not present (i.e. when Intel PT isn't present), we + don't want capability checking to fail. *) + | Sys_error _ -> false +;; + (* This checks if pdcm flag is present in /proc/cpuinfo. This is necessary for LBR to work. Although I couldn't ascertain that it is also sufficient. However it seems unlikely this would fail on most machines. *) @@ -108,6 +122,7 @@ let detect_exn () = let set_if bool flag cap = cap + if bool then flag else empty in empty |> set_if (supports_configurable_psb_period ()) configurable_psb_period + |> set_if (supports_ptwrite ()) ptwrite |> set_if (supports_tracing_kernel ()) kernel_tracing |> set_if (supports_kcore version) kcore |> set_if (supports_snapshot_on_exit version) snapshot_on_exit diff --git a/src/perf_capabilities.mli b/src/perf_capabilities.mli index 2a2d6a214..828df839e 100644 --- a/src/perf_capabilities.mli +++ b/src/perf_capabilities.mli @@ -11,4 +11,5 @@ val kcore : t val snapshot_on_exit : t val last_branch_record : t val dlfilter : t +val ptwrite : t val detect_exn : unit -> t Deferred.t diff --git a/src/perf_decode.ml b/src/perf_decode.ml index 28480f4cc..3eb2e4170 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -29,6 +29,12 @@ let perf_cbr_event_re = Re.Perl.re {|^ *([a-z )(]*)? +cbr: +([0-9]+ +freq: +([0-9]+) MHz)?(.*)$|} |> Re.compile ;; +let perf_ptwrite_event_re = + Re.Perl.re + {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +(0x[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} + |> Re.compile +;; + let trace_error_re = Re.Posix.re {|^ instruction trace error type [0-9]+ (time ([0-9]+)\.([0-9]+) )?cpu [\-0-9]+ pid ([\-0-9]+) tid ([\-0-9]+) ip (0x[0-9a-fA-F]+|0) code [0-9]+: (.*)$|} @@ -44,7 +50,15 @@ type header = { thread : Event.Thread.t ; time : Time_ns.Span.t ; period : int - ; event : [ `Branches | `Cbr | `Psb | `Cycles | `Branch_misses | `Cache_misses ] + ; event : + [ `Branches + | `Cbr + | `Psb + | `Cycles + | `Branch_misses + | `Cache_misses + | `Ptwrite + ] ; remaining_line : string } @@ -96,6 +110,7 @@ let parse_event_header line = | "cycles" -> `Cycles | "branch-misses" -> `Branch_misses | "cache-misses" -> `Cache_misses + | "ptwrite" -> `Ptwrite | _ -> raise_s [%message @@ -328,6 +343,33 @@ let parse_perf_extra_sampled_event } ;; +let parse_perf_ptwrite_event ?perf_maps (thread : Event.Thread.t) time line : Event.t = + match Re.Group.all (Re.exec perf_ptwrite_event_re line) with + | [| _ + ; _branch_kind + ; _fup_ip + ; payload + ; _payload_ascii + ; _unknown + ; instruction_pointer + ; symbol_and_offset + |] -> + let location = + parse_location ?perf_maps ~pid:thread.pid instruction_pointer symbol_and_offset + in + Ok + { thread + ; time + ; data = Ptwrite { location; data = payload } + ; in_transaction = false + } + | results -> + raise_s + [%message + "Regex of perf ptwrite event did not match expected fields" + (results : string array)] +;; + let to_event ?perf_maps lines : Event.t option = try match lines with @@ -364,7 +406,9 @@ let to_event ?perf_maps lines : Event.t option = period remaining_line lines - Cache_misses))) + Cache_misses) + | `Ptwrite -> + Some (parse_perf_ptwrite_event ?perf_maps thread time remaining_line))) with | exn -> raise_s @@ -725,6 +769,46 @@ let%test_module _ = (Trace (trace_state_change End) (kind Async) (src 0x7f6fce0b71f4) (dst 0x0)))))) |}] ;; + + let%expect_test "perf ptwrite event" = + check + {| 2769074/2769293 2592496.569782106: 1 ptwrite: call IP: 0 payload: 0x1b5 0 55c7952ad2d0 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (2769074)) (tid (2769293)))) (time 30d8m16.569782106s) + (data (Ptwrite (location 0x55c7952ad2d0) (data 0x1b5)))))) |}] + ;; + + let%expect_test "perf ptwrite event with printable payload" = + check + {|2817453/2817483 2596547.813541321: 1 ptwrite: call IP: 0 payload: 0x62 b 0 613d946b42d0 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (2817453)) (tid (2817483)))) (time 30d1h15m47.813541321s) + (data (Ptwrite (location 0x613d946b42d0) (data 0x62)))))) |}] + ;; + + let%expect_test "perf ptwrite event with jcc instruction" = + check + {|3256341/3256760 2632746.069047397: 1 ptwrite: jcc IP: 0 payload: 0x5000000000061b2 0 577bcad80555 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (3256341)) (tid (3256760)))) (time 30d11h19m6.069047397s) + (data (Ptwrite (location 0x577bcad80555) (data 0x5000000000061b2)))))) |}] + ;; + + let%expect_test "perf ptwrite event without instruction" = + check + {|3285832/3286108 2634666.172476558: 1 ptwrite: IP: 0 payload: 0xa00000000000000 0 64d20fb10432 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (3285832)) (tid (3286108)))) (time 30d11h51m6.172476558s) + (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) |}] + ;; end) ;; diff --git a/src/perf_tool_backend.ml b/src/perf_tool_backend.ml index ce10634b4..f74e25c46 100644 --- a/src/perf_tool_backend.ml +++ b/src/perf_tool_backend.ml @@ -117,29 +117,41 @@ module Recording = struct Timer_resolution.Low | _, _ -> timer_resolution in - match timer_resolution with - | Low -> Or_error.return "" - | Normal -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0" - | High -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0,noretcomp=1" - | Sample _ -> - Or_error.error_string - "[-timer-resolution Sample] can only be used in sampling mode. (Did you forget \ - [-sampling]?)" - | Custom { cyc; cyc_thresh; mtc; mtc_period; noretcomp; psb_period } -> - let make_config key = function - | None -> None - | Some value -> Some [%string "%{key}=%{value#Int}"] - in - [ make_config "cyc" (Option.map ~f:Bool.to_int cyc) - ; make_config "cyc_thresh" cyc_thresh - ; make_config "mtc" (Option.map ~f:Bool.to_int mtc) - ; make_config "mtc_period" mtc_period - ; make_config "noretcomp" (Option.map ~f:Bool.to_int noretcomp) - ; make_config "psb_period" psb_period - ] - |> List.filter_opt - |> String.concat ~sep:"," - |> Or_error.return + let ptw = + if Perf_capabilities.(do_intersect capabilities ptwrite) then "ptw" else "" + in + (* If ptwrite is not supported, we don't need to add it to the config string. *) + let config = + match timer_resolution with + | Low -> Or_error.return "" + | Normal -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0" + | High -> Or_error.return "cyc=1,cyc_thresh=1,mtc_period=0,noretcomp=1" + | Sample _ -> + Or_error.error_string + "[-timer-resolution Sample] can only be used in sampling mode. (Did you forget \ + [-sampling]?)" + | Custom { cyc; cyc_thresh; mtc; mtc_period; noretcomp; psb_period } -> + let make_config key = function + | None -> None + | Some value -> Some [%string "%{key}=%{value#Int}"] + in + [ make_config "cyc" (Option.map ~f:Bool.to_int cyc) + ; make_config "cyc_thresh" cyc_thresh + ; make_config "mtc" (Option.map ~f:Bool.to_int mtc) + ; make_config "mtc_period" mtc_period + ; make_config "noretcomp" (Option.map ~f:Bool.to_int noretcomp) + ; make_config "psb_period" psb_period + ] + |> List.filter_opt + |> String.concat ~sep:"," + |> Or_error.return + in + match config with + | Ok config -> + if String.is_empty config + then Or_error.return [%string "%{ptw}"] + else Or_error.return [%string "%{config},%{ptw}"] + | Error _ as e -> e ;; let perf_cycles_config_of_timer_resolution (timer_resolution : Timer_resolution.t) = @@ -493,7 +505,7 @@ let decode_events Deferred.List.map files ~how:`Sequential ~f:(fun perf_data_file -> let itrace_opts = match collection_mode with - | Intel_processor_trace _ -> [ "--itrace=bep" ] + | Intel_processor_trace _ -> [ "--itrace=bepw" ] | Stacktrace_sampling _ -> [] in let fields_opts = diff --git a/src/trace.ml b/src/trace.ml index da41842ea..3cd7f008b 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -170,7 +170,10 @@ let write_trace_from_events | None -> Trace_writer.end_of_trace writer | Some to_time -> Trace_writer.end_of_trace ~to_time writer); last_index := index - | Ok { data = Event_sample _; _ } | Ok { data = Power _; _ } | Error _ -> ()); + | Ok { data = Event_sample _; _ } + | Ok { data = Ptwrite _; _ } + | Ok { data = Power _; _ } + | Error _ -> ()); Trace_writer.write_event writer ?events_writer ev in let%bind () = diff --git a/src/trace_writer.ml b/src/trace_writer.ml index 6293daf4e..3c00030bf 100644 --- a/src/trace_writer.ml +++ b/src/trace_writer.ml @@ -1071,8 +1071,8 @@ and write_event' (T t) ?events_writer event = ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) ~default:[] ; Option.value_map - (Event.thread outer_event).pid - ~f:(fun pid -> [ "tid", Int (Pid.to_int pid) ]) + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) ~default:[] ]) in @@ -1083,6 +1083,29 @@ and write_event' (T t) ?events_writer event = ~name:track_name ~time ~time_end:time + | { Event.Ok.thread = _ (* Already used this to look up thread info. *) + ; time = _ + ; data = Ptwrite { location; data } + ; in_transaction = _ + } -> + let args = + Tracing.Trace.Arg.( + List.concat + [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] + ; [ "symbol", String (Symbol.display_name location.symbol) ] + ; [ "addr", Pointer location.instruction_pointer ] + ; [ "data", String data ] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) + ~default:[] + ; Option.value_map + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) + ~default:[] + ]) + in + write_duration_complete t ~thread ~args ~name:"PTWRITE" ~time ~time_end:time | { Event.Ok.thread = _ (* Already used this to look up thread info. *) ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) ; data = Power { freq } From ddfa124fcf38747e7cb6d7c6058301d769878130 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 9 Feb 2026 15:15:16 -0500 Subject: [PATCH 02/30] Add trace file formats to `.gitignore` Signed-off-by: Kevin Svetlitski --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index eb42dfd72..fb2549625 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,7 @@ _build _opam .vscode/* !.vscode/tasks.json +*.fxt +*.fxt.old +*.fxt.gz +*.fxt.gz.old From 75dfa10f5fafd583fd1540da6023384dc2351ce0 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Wed, 4 Feb 2026 13:41:46 -0500 Subject: [PATCH 03/30] Add `-filter` argument to `decode` subcommand This is useful for testing. Signed-off-by: Kevin Svetlitski --- src/trace.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/trace.ml b/src/trace.ml index 042ac22b8..e647293c4 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -772,7 +772,8 @@ module Make_commands (Backend : Backend_intf.S) = struct (optional (Arg_type.comma_separated Filename_unix.arg_type)) ~doc:"FILE for JITs, path to a perf map file, in /tmp/perf-PID.map" and collection_mode = Collection_mode.param - and debug_print_perf_commands in + and debug_print_perf_commands + and trace_filter = Trace_filter.param in fun () -> (* Doesn't use create_elf because there's no need to check that the binary has symbols if we're trying to snapshot it. *) @@ -783,8 +784,12 @@ module Make_commands (Backend : Backend_intf.S) = struct | Some files -> Perf_map.Table.load_by_files files |> Deferred.map ~f:Option.some in + let%bind.Deferred.Or_error range_symbols = + evaluate_trace_filter ~trace_filter ~elf + in decode_to_trace ?perf_maps + ?range_symbols ~elf ~trace_scope ~debug_print_perf_commands From accf21a19bb1ed925d38ba0599db33e1bab71ce5 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 9 Feb 2026 14:09:02 -0500 Subject: [PATCH 04/30] Copy `src/trace_writer.ml` to `src/new_trace_writer.ml` This is in preparation for writing the new backend. After we've made substantial changes to `src/new_trace_writer.ml`, you'll still be able to track the history by running: ```bash git blame -C -C src/new_trace_writer.ml ``` Yes, you need to pass `-C` *twice*: > -C ... when this option is given twice, the command additionally looks for copies from other files in the commit that creates the file. Signed-off-by: Kevin Svetlitski --- src/new_trace_writer.ml | 1233 +++++++++++++++++++++++ src/trace_writer.mli | 70 -- src/trace_writer_implementation_intf.ml | 72 ++ 3 files changed, 1305 insertions(+), 70 deletions(-) create mode 100644 src/new_trace_writer.ml delete mode 100644 src/trace_writer.mli create mode 100644 src/trace_writer_implementation_intf.ml diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml new file mode 100644 index 000000000..6293daf4e --- /dev/null +++ b/src/new_trace_writer.ml @@ -0,0 +1,1233 @@ +open! Core + +let debug = ref false +let is_kernel_address addr = Int64.(addr < 0L) + +(* Time spans from perf start whenever the machine booted. Perfetto uses floats to represent time + spans, which struggles with large spans when we care about small differences in them. To + compensate, the trace writer subtracts the time of the first event from all time spans, producing + what we call a "mapped time". Only mapped times may be written to the trace file. *) +module Mapped_time : sig + type t = private Time_ns.Span.t [@@deriving sexp, compare, bin_io] + + include Comparable with type t := t + + val start_of_trace : t + val create : Time_ns.Span.t -> base_time:Time_ns.Span.t -> t + val is_base_time : t -> bool + val add : t -> Time_ns.Span.t -> t + val diff : t -> t -> Time_ns.Span.t +end = struct + module T = struct + type t = Time_ns.Span.t [@@deriving sexp, compare, bin_io] + end + + let start_of_trace = Time_ns.Span.zero + let create t ~base_time = Time_ns.Span.( - ) t base_time + let is_base_time = Time_ns.Span.( = ) Time_ns.Span.zero + let add = Time_ns.Span.( + ) + let diff = Time_ns.Span.( - ) + + include T + include Comparable.Make (T) +end + +module Pending_event = struct + module Kind = struct + type t = + | Call of + { addr : Int64.Hex.t + ; offset : Int.Hex.t + ; from_untraced : bool + } + | Ret + | Ret_from_untraced of { reset_time : Mapped_time.t } + [@@deriving sexp] + end + + type t = + { symbol : Symbol.t + ; kind : Kind.t + } + [@@deriving sexp] + + let create_call location ~from_untraced = + let { Event.Location.instruction_pointer; symbol; symbol_offset } = location in + { symbol + ; kind = Call { addr = instruction_pointer; offset = symbol_offset; from_untraced } + } + ;; +end + +module Callstack = struct + type t = + { stack : Event.Location.t Stack.t + ; mutable create_time : Mapped_time.t + } + [@@deriving sexp, bin_io] + + let create ~create_time = { stack = Stack.create (); create_time } + let push t v = Stack.push t.stack v + let pop t = Stack.pop t.stack + let top t = Stack.top t.stack + let is_empty t = Stack.is_empty t.stack + let depth t = Stack.length t.stack + + let how_many_match { stack; create_time = _ } (future_callstack : Event.Location.t list) + = + let zipped_stacks, _ = + List.zip_with_remainder (Stack.to_list stack |> List.rev) future_callstack + in + let ans = + List.take_while zipped_stacks ~f:(fun (current_location, future_location) -> + Int64.(current_location.instruction_pointer = future_location.instruction_pointer)) + |> List.length + in + ans + ;; +end + +module Event_and_callstack = struct + type t = + { event : Event.t + ; callstack : Callstack_compression.compression_event + } + [@@deriving sexp, bin_io] +end + +module Thread_info = struct + type ocaml_exception_state = + | Without_exception_info of { frames_to_unwind : int ref } + | With_exception_info of + { ocaml_exception_info : (Ocaml_exception_info.t[@sexp.opaque]) + ; last_known_instruction_pointer : int64 option ref + } + [@@deriving sexp_of] + + type 'thread t = + { thread : ('thread[@sexp.opaque]) + ; (* This isn't a canonical callstack, but represents all of the information that we + know about the callstack at the point in the events up to the current event being + processed, and is reflected in the trace at that point. *) + mutable callstack : Callstack.t + ; inactive_callstacks : Callstack.t Stack.t + ; mutable last_decode_error_time : Mapped_time.t + ; ocaml_exception_state : ocaml_exception_state + ; mutable pending_events : Pending_event.t list + ; mutable pending_time : Mapped_time.t + ; start_events : (Mapped_time.t * Pending_event.t) Deque.t + (* When the last event arrived. Used to give timestamps to events lacking them. *) + ; mutable last_event_time : Mapped_time.t + ; track_group_id : int + ; extra_event_tracks : ('thread[@sexp.opaque]) Hashtbl.M(Collection_mode.Event.Name).t + } + [@@deriving sexp_of] + + let set_callstack t ~is_kernel_address ~time = + let create_time = if is_kernel_address then time else t.last_decode_error_time in + t.callstack <- Callstack.create ~create_time + ;; + + let set_callstack_from_addr t ~addr ~time = + set_callstack t ~is_kernel_address:(is_kernel_address addr) ~time + ;; +end + +module type Trace = Trace_writer_intf.S_trace + +type 'thread inner = + { debug_info : Elf.Addr_table.t + ; ocaml_exception_info : Ocaml_exception_info.t option + ; thread_info : 'thread Thread_info.t Hashtbl.M(Event.Thread).t + ; base_time : Time_ns.Span.t + ; trace_scope : Trace_scope.t + ; trace : (module Trace with type thread = 'thread) + ; annotate_inferred_start_times : bool + ; mutable in_filtered_region : bool + ; suppressed_errors : Hash_set.M(Source_code_position).t + ; mutable transaction_events : Event.With_write_info.t Deque.t + } + +type t = T : 'thread inner -> t + +let sexp_of_inner inner = + [%sexp_of: _ Thread_info.t Hashtbl.M(Event.Thread).t] inner.thread_info +;; + +let sexp_of_t (T inner) = sexp_of_inner inner + +let eprint_s_once t here sexp = + if not (Hash_set.mem t.suppressed_errors here) + then ( + Hash_set.add t.suppressed_errors here; + eprint_s sexp) +;; + +let allocate_pid (type thread) (t : thread inner) ~name : int = + let module T = (val t.trace) in + T.allocate_pid ~name +;; + +let allocate_thread (type thread) (t : thread inner) ~pid ~name : thread = + let module T = (val t.trace) in + T.allocate_thread ~pid ~name +;; + +let write_duration_begin + (type thread) + (t : thread inner) + ~args + ~thread + ~name + ~(time : Mapped_time.t) + : unit + = + let module T = (val t.trace) in + if t.in_filtered_region + then T.write_duration_begin ~args ~thread ~name ~time:(time :> Time_ns.Span.t) +;; + +let write_duration_end + (type thread) + (t : thread inner) + ~args + ~thread + ~name + ~(time : Mapped_time.t) + : unit + = + let module T = (val t.trace) in + if t.in_filtered_region + then T.write_duration_end ~args ~thread ~name ~time:(time :> Time_ns.Span.t) +;; + +let write_duration_complete + (type thread) + (t : thread inner) + ~args + ~thread + ~name + ~(time : Mapped_time.t) + ~(time_end : Mapped_time.t) + : unit + = + let module T = (val t.trace) in + if t.in_filtered_region + then + T.write_duration_complete + ~args + ~thread + ~name + ~time:(time :> Time_ns.Span.t) + ~time_end:(time_end :> Time_ns.Span.t) +;; + +let write_duration_instant + (type thread) + (t : thread inner) + ~args + ~thread + ~name + ~(time : Mapped_time.t) + : unit + = + let module T = (val t.trace) in + if t.in_filtered_region + then T.write_duration_instant ~args ~thread ~name ~time:(time :> Time_ns.Span.t) +;; + +let write_counter + (type thread) + (t : thread inner) + ~args + ~thread + ~name + ~(time : Mapped_time.t) + : unit + = + let module T = (val t.trace) in + if t.in_filtered_region + then T.write_counter ~args ~thread ~name ~time:(time :> Time_ns.Span.t) +;; + +let map_time t time = Mapped_time.create time ~base_time:t.base_time + +let write_hits (T t) hits = + if not (List.is_empty hits) + then ( + let pid = allocate_pid t ~name:"Snapshot symbol hits" in + let thread = allocate_thread t ~pid ~name:"hits" in + List.iter hits ~f:(fun (sym, (hit : Breakpoint.Hit.t)) -> + let is_default_symbol = String.( = ) sym Magic_trace.Private.stop_symbol in + let name = [%string "hit %{sym}"] in + let time = map_time t hit.timestamp in + let args = + Tracing.Trace.Arg. + [ "timestamp", Int (Time_ns.Span.to_int_ns hit.timestamp) + ; "tid", Int (Pid.to_int hit.tid) + ; "ip", Pointer hit.ip + ] + in + (* Args that are computed from captured registers are only meaningful on our + special stop symbol, we still capture them regardless, but on other symbols + they'll just have confusing broken values. *) + let args = + if is_default_symbol + then + Tracing.Trace.Arg. + [ "timestamp_passed", Int (Time_ns.Span.to_int_ns hit.passed_timestamp) + ; "arg", Int hit.passed_val + ] + @ args + else args + in + (* For the special symbol, if present the passed timestamp comes from + Magic_trace.mark_start and marks the start of a region of interest. + + We check it for validity since it's possible someone uses an older version of + [Magic_trace.take_snapshot] and that should at least produce a valid trace. *) + let valid_timestamp = + Time_ns.Span.( + hit.passed_timestamp > t.base_time && hit.passed_timestamp < hit.timestamp) + in + let start = + if is_default_symbol && valid_timestamp + then map_time t hit.passed_timestamp + else time + in + write_duration_complete t ~thread ~args ~name ~time:start ~time_end:time)) +;; + +let create_expert + ~trace_scope + ~debug_info + ~ocaml_exception_info + ~earliest_time + ~hits + ~annotate_inferred_start_times + trace + = + let base_time = + List.fold hits ~init:earliest_time ~f:(fun acc (_, (hit : Breakpoint.Hit.t)) -> + Time_ns.Span.min acc hit.timestamp) + in + let t = + T + { debug_info = Option.value debug_info ~default:(Int.Table.create ()) + ; ocaml_exception_info + ; thread_info = Hashtbl.create (module Event.Thread) + ; base_time + ; trace_scope + ; trace + ; annotate_inferred_start_times + ; in_filtered_region = true + ; suppressed_errors = Hash_set.create (module Source_code_position) + ; transaction_events = Deque.create () + } + in + write_hits t hits; + t +;; + +let create + ~trace_scope + ~debug_info + ~ocaml_exception_info + ~earliest_time + ~hits + ~annotate_inferred_start_times + trace + = + create_expert + ~trace_scope + ~debug_info + ~ocaml_exception_info + ~earliest_time + ~hits + ~annotate_inferred_start_times + (Real_trace.create trace) +;; + +let write_pending_event' + (type thread) + (t : thread inner) + (thread : thread Thread_info.t) + time + { Pending_event.symbol; kind } + = + let display_name = Symbol.display_name symbol in + match kind with + | Call { addr; offset; from_untraced } -> + (* Adding a call is always the result of seeing something new on the top of the + stack, so the base address is just the current base address. *) + let base_address = Int64.(addr - of_int offset) in + let open Tracing.Trace.Arg in + let symbol_args = + (* Using [Interned] may cause some issues with the 32k interned string limit, on + sufficiently large programs if the trace goes through a lot of different code, + but that'll also be a problem with the span names. This will just make it + happen around twice as fast. It does make the traces noticeably smaller. + + The real solution is to get around to improving the interning table management + in the trace writer library. + + --- + + [base_address] might be lie in the kernel, in which case [to_int] will fail (but + that's alright, because we wouldn't have a symbol for it in the executable's + [debug_info] anyway). *) + let address = [ "address", Pointer addr ] in + match symbol with + | From_perf_map { start_addr = _; size = _; function_ = _ } -> + address @ [ "symbol", Interned display_name ] + | _ -> + (match Option.bind (Int64.to_int base_address) ~f:(Hashtbl.find t.debug_info) with + | None -> address @ [ "symbol", Interned display_name ] + | Some (info : Elf.Location.t) -> + address + @ [ "line", Int info.line + ; "col", Int info.col + ; "symbol", Interned display_name + ] + @ + (match info.filename with + | Some x -> [ "file", Interned x ] + | None -> [])) + in + let inferred_start_time_arg = + if from_untraced then [ "inferred_start_time", Interned "true" ] else [] + in + let args = symbol_args @ inferred_start_time_arg in + let name = + if t.annotate_inferred_start_times && from_untraced + then display_name ^ " [inferred start time]" + else display_name + in + write_duration_begin t ~thread:thread.thread ~name ~time ~args + | Ret -> write_duration_end t ~name:display_name ~time ~thread:thread.thread ~args:[] + | Ret_from_untraced { reset_time } -> + write_duration_complete + t + ~time:reset_time + ~time_end:time + ~name:(Symbol.display_name Unknown) + ~thread:thread.thread + ~args:[] +;; + +(* It would be reasonable to also have returns consume time, but making them not + consume time substantially reduces the frequency where we need to use zero-duration + events. In general the traces are easier to read if returns aren't counted as consuming + time. *) +let consumes_time { Pending_event.symbol = _; kind } = + match kind with + | Call _ -> true + | Ret | Ret_from_untraced _ -> false +;; + +let write_pending_event + (t : _ inner) + (thread : _ Thread_info.t) + time + (ev : Pending_event.t) + = + match ev.kind with + | Ret_from_untraced _ | Call { from_untraced = true; _ } -> + Deque.enqueue_front thread.start_events (time, ev) + | Call _ when Mapped_time.is_base_time time -> + Deque.enqueue_back thread.start_events (time, ev) + | _ -> write_pending_event' t thread time ev +;; + +let flush (t : _ inner) ~to_time (thread : _ Thread_info.t) = + (* Try to evenly distribute the time between timestamp updates between all the + time-consuming events in the batch. *) + let count = List.count thread.pending_events ~f:consumes_time in + let total_ns = Mapped_time.diff to_time thread.pending_time |> Time_ns.Span.to_int_ns in + let ns_offset = ref 0 in + let shares_consumed = ref 0 in + List.iter (List.rev thread.pending_events) ~f:(fun ev -> + let ns_share = + if consumes_time ev + then ( + incr shares_consumed; + (total_ns - !ns_offset) / (count - !shares_consumed + 1)) + else 0 + in + let time = Mapped_time.add thread.pending_time (Time_ns.Span.of_int_ns !ns_offset) in + ns_offset := !ns_offset + ns_share; + write_pending_event t thread time ev); + thread.pending_time <- to_time; + thread.pending_events <- [] +;; + +let add_event (t : _ inner) (thread : _ Thread_info.t) time ev = + if Mapped_time.( <> ) time thread.pending_time then flush t ~to_time:time thread; + thread.pending_events <- ev :: thread.pending_events +;; + +let opt_pid_to_string opt_pid = + match opt_pid with + | None -> "?" + | Some pid -> Pid.to_string pid +;; + +(* A practical, but not perfect, fix for #155: If events happen with the exact same timestamp + as a decode error, stacks break. We implement this "#155 hack" to prevent that: + + If an event happens at exactly the same time as the previous decode error, slide it forward + by one nanosecond. Maintain the invariant that no event which follows a decode error has the + same timestamp as that decode error. + + This should have minimal impact on the timestamps displayed to the user, they're precise to at + most ~40ns anyhow. But it does make sure our stacks always come out in the right order. + + Also worth noting is that despite the fact that we're changing timestamps, this can't reorder + events. 1ns is the minimum amount of time by which timestamps can differ. So even if there were + more events exactly 1ns after the decode error, they'll be seen as having the exact same + timestamp as the events that happened during the decode error. *) +let hack_155 (thread_info : _ Thread_info.t) time = + let last_decode_error_time = thread_info.last_decode_error_time in + if Mapped_time.( = ) time last_decode_error_time + && Mapped_time.( <> ) last_decode_error_time Mapped_time.start_of_trace + then Mapped_time.add time (Time_ns.Span.of_int_ns 1) + else time +;; + +let event_time t (event : Event.t) (thread_info : _ Thread_info.t) = + let event_time = Event.time event in + let unadjusted_time = + match%optional.Time_ns_unix.Span.Option event_time with + | None -> + (* Decode errors sometimes do not have a timestamp, so we pretend they happen at the + same time as the last event. *) + thread_info.last_event_time + | Some time -> + let time = map_time t time in + thread_info.last_event_time <- time; + time + in + hack_155 thread_info unadjusted_time +;; + +let create_thread t event = + let thread = Event.thread event in + let effective_time = + match%optional.Time_ns_unix.Span.Option Event.time event with + | None -> Mapped_time.start_of_trace + | Some time -> map_time t time + in + let pid = opt_pid_to_string thread.pid in + let tid = opt_pid_to_string thread.tid in + let default_name = + if String.(pid = tid) + then [%string "[pid=%{pid}]"] + else [%string "[pid=%{pid}] [tid=%{tid}]"] + in + let name = + match thread.pid with + | None -> default_name + | Some pid -> + (match Process_info.cmdline_of_pid pid with + | None -> default_name + | Some cmdline -> + let concat_cmdline = String.concat ~sep:" " cmdline in + let name = [%string "%{concat_cmdline} %{default_name}"] in + if String.length name > Tracing_zero.Writer.max_interned_string_length + then default_name + else name) + in + let track_group_id = allocate_pid t ~name in + let thread = allocate_thread t ~pid:track_group_id ~name:"main" in + { Thread_info.thread + ; callstack = Callstack.create ~create_time:effective_time + ; inactive_callstacks = Stack.create () + ; last_decode_error_time = effective_time + ; ocaml_exception_state = + (match t.ocaml_exception_info with + | None -> Without_exception_info { frames_to_unwind = ref 0 } + | Some ocaml_exception_info -> + With_exception_info + { ocaml_exception_info; last_known_instruction_pointer = ref None }) + ; pending_events = [] + ; pending_time = Mapped_time.start_of_trace + ; start_events = Deque.create () + ; last_event_time = effective_time + ; track_group_id + ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) + } +;; + +let call t thread_info ~time ~location = + let ev = Pending_event.create_call location ~from_untraced:false in + add_event t thread_info time ev; + Callstack.push thread_info.callstack location +;; + +let ret_without_checking_for_go_hacks t (thread_info : _ Thread_info.t) ~time = + match Callstack.pop thread_info.callstack with + | Some { symbol; _ } -> add_event t thread_info time { symbol; kind = Ret } + | None -> + (* No known stackframe was popped --- could occur if the start of the snapshot + started in the middle of a tracing region *) + add_event + t + thread_info + time + { symbol = From_perf "[unknown]" + ; kind = Ret_from_untraced { reset_time = thread_info.callstack.create_time } + } +;; + +let rec clear_callstack t (thread_info : _ Thread_info.t) ~time = + let ret = ret_without_checking_for_go_hacks in + match Callstack.top thread_info.callstack with + | None -> () + | Some _ -> + ret t thread_info ~time; + clear_callstack t thread_info ~time +;; + +(* Unlike [clear_callstack], [clear_all_callstacks] also returns from all inactive + callstacks. *) +let rec clear_all_callstacks t thread_info ~time = + clear_callstack t thread_info ~time; + match Stack.pop thread_info.inactive_callstacks with + | None -> () + | Some callstack -> + thread_info.callstack <- callstack; + clear_all_callstacks t thread_info ~time +;; + +let end_of_thread t (thread_info : _ Thread_info.t) ~time ~is_kernel_address : unit = + let to_time = thread_info.pending_time in + Deque.iter' thread_info.start_events `front_to_back ~f:(fun (time, ev) -> + write_pending_event' t thread_info time ev); + Deque.clear thread_info.start_events; + clear_all_callstacks t thread_info ~time; + flush t ~to_time thread_info; + thread_info.last_decode_error_time <- time; + Thread_info.set_callstack thread_info ~is_kernel_address ~time +;; + +(* Go (the programming language) has coroutines known as goroutines. The function [gogo] jumps + from one goroutine to the next. Since [gogo] can jump anywhere, it's a shining example of what + magic-trace can't handle out of the box. So, we hack it. + + Most of the time, control flow returns parallel to (i.e. as if jumped from) the previous caller + of [runtime.mcall] or [runtime.morestack.abi0]. + + At startup (and maybe other situations?), gogo clears all callstacks and executes [main]. *) +module Go_hacks : sig + val ret_track_gogo + : 'a inner + -> 'a Thread_info.t + -> time:Mapped_time.t + -> returned_from:Symbol.t option + -> unit +end = struct + let is_gogo (symbol : Symbol.t) = + match symbol with + | From_perf "gogo" -> true + | _ -> false + ;; + + let is_known_gogo_destination (location : Event.Location.t) = + match location with + | { symbol = From_perf ("runtime.mcall" | "runtime.morestack.abi0"); _ } -> true + | _ -> false + ;; + + let current_stack_contains_known_gogo_destination (thread_info : _ Thread_info.t) = + Stack.find thread_info.callstack.stack ~f:(fun location -> + is_known_gogo_destination location) + |> Option.is_some + ;; + + let rec pop_until_gogo_destination t (thread_info : _ Thread_info.t) ~time = + let ret = ret_without_checking_for_go_hacks in + match Callstack.top thread_info.callstack with + | None -> () + | Some location -> + ret t thread_info ~time; + (* Return one past the known gogo destination. This hack is necessary because: + + - all gogo-destination functions are jumped into and out of + - magic-trace translates the jump returning from gogo-destination into a ret/call pair + - this runs on the ret, but the call is to gogo-destination's caller and we don't + want a second stack frame for that. + + This is a little janky because you see a stack frame momentarily end then start back + up again on every [gogo]. I think that's a small price to pay to keep all the Go hacks + in one place. *) + if is_known_gogo_destination location + then ret t thread_info ~time + else pop_until_gogo_destination t thread_info ~time + ;; + + let ret_track_gogo t thread_info ~time ~returned_from = + let is_ret_from_gogo = Option.value_map ~f:is_gogo returned_from ~default:false in + if is_ret_from_gogo + then + if current_stack_contains_known_gogo_destination thread_info + then pop_until_gogo_destination t thread_info ~time + else end_of_thread t thread_info ~time ~is_kernel_address:false + ;; +end + +let ret t (thread_info : _ Thread_info.t) ~time : unit = + let returned_from = + Callstack.top thread_info.callstack |> Option.map ~f:Event.Location.symbol + in + ret_without_checking_for_go_hacks t thread_info ~time; + Go_hacks.ret_track_gogo t thread_info ~time ~returned_from +;; + +let check_current_symbol + t + (thread_info : _ Thread_info.t) + ~time + (location : Event.Location.t) + = + (* After every operation, we should be in a situation where the current symbol under + the pc matches the symbol at the top of the callstack. This can go out-of-sync + with jumps between functions (e.g. tailcalls, PLT) or returns out of the highest + known function, so we have to correct the top of the stack here. *) + match Callstack.top thread_info.callstack with + | Some { symbol; _ } when not ([%compare.equal: Symbol.t] symbol location.symbol) -> + ret t thread_info ~time; + call t thread_info ~time ~location + | Some _ -> () + | None -> + (* If we have no callstack left, then we just returned out of something we didn't + see the call for. Since we're in snapshot mode, this happens with functions + called before the perf events started, so add in a call that begins at the + start of the trace for that pid. + + These shouldn't be buffered for spreading since we want them exactly at the reset + time. *) + let ev = Pending_event.create_call location ~from_untraced:true in + write_pending_event t thread_info thread_info.callstack.create_time ev; + Callstack.push thread_info.callstack location +;; + +(* OCaml-specific hacks around tracking exception control flow. Supports two + modes. + + With exception info provided by the compiler: read + [core/ocaml_exception_info.mli] for details. + + Without exception info provided by the compiler: the way this works is that + it counts the number of [caml_next_frame_descriptor] calls while an + exception is unwinding, and knows to unwind the stack that many times (+/- a + constant) when the next [caml_raise_exn] or [caml_raise_exception] return. + + This mode fails to account for [raise_notrace] exceptions. *) + +module Ocaml_hacks : sig + val ret_track_exn_data : 'a inner -> 'a Thread_info.t -> time:Mapped_time.t -> unit + + val track_executed_pushtraps_and_poptraps_in_range + : 'a inner + -> 'a Thread_info.t + -> src:Event.Location.t + -> dst:Event.Location.t + -> time:Mapped_time.t + -> unit + + val check_current_symbol_track_entertraps + : 'a inner + -> 'a Thread_info.t + -> time:Mapped_time.t + -> Event.Location.t + -> unit +end = struct + (* It's ocaml, not go. *) + let ret = ret_without_checking_for_go_hacks + + let unwind_stack t (thread_info : _ Thread_info.t) ~time ~frames_to_unwind diff = + for _ = 0 to !frames_to_unwind + diff do + ret t thread_info ~time + done; + frames_to_unwind := 0 + ;; + + let ret_track_exn_data t thread_info ~time = + let { Thread_info.callstack; ocaml_exception_state; _ } = thread_info in + (match ocaml_exception_state with + | With_exception_info _ -> () + | Without_exception_info { frames_to_unwind } -> + (match Callstack.top callstack with + | Some { symbol = From_perf symbol; _ } -> + (match symbol with + | "caml_next_frame_descriptor" -> incr frames_to_unwind + | "caml_raise_exn" -> unwind_stack t thread_info ~time ~frames_to_unwind (-2) + | "caml_stash_backtrace" -> incr frames_to_unwind + | "caml_raise_exception" -> + unwind_stack t thread_info ~time ~frames_to_unwind 1 + | _ -> ()) + | _ -> ())); + ret t thread_info ~time + ;; + + let clear_trap_stack t thread_info ~time = + clear_callstack t thread_info ~time; + match Stack.pop thread_info.inactive_callstacks with + | Some callstack -> thread_info.callstack <- callstack + | None -> thread_info.callstack <- Callstack.create ~create_time:time + ;; + + let check_current_symbol_track_entertraps + t + (thread_info : 'a Thread_info.t) + ~time + (dst : Event.Location.t) + = + match thread_info.ocaml_exception_state with + | With_exception_info { ocaml_exception_info; _ } + when Ocaml_exception_info.is_entertrap + ocaml_exception_info + ~addr:dst.instruction_pointer -> + (* CR-someday tbrindus: unwind this hack. This recreates the callstack but with the + first (synthetic) frame missing. A more principled approach would be the one + outlined in another CR-someday below, where we teach [Callstack] about traps + directly. *) + let s = thread_info.callstack.stack |> Stack.to_list in + let s = List.take s (List.length s - 1) in + Stack.clear thread_info.callstack.stack; + List.iter (List.rev s) ~f:(fun x -> Stack.push thread_info.callstack.stack x); + clear_trap_stack t thread_info ~time + | _ -> check_current_symbol t thread_info ~time dst + ;; + + let track_executed_pushtraps_and_poptraps_in_range + t + (thread_info : _ Thread_info.t) + ~(src : Event.Location.t) + ~(dst : Event.Location.t) + ~time + = + match thread_info.ocaml_exception_state with + | Without_exception_info _ -> () + | With_exception_info { ocaml_exception_info; last_known_instruction_pointer } -> + (match !last_known_instruction_pointer with + | None -> () + | Some last_known_instruction_pointer -> + Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range + ocaml_exception_info + ~from:last_known_instruction_pointer + ~to_:src.instruction_pointer + ~f:(fun (_addr, kind) -> + match kind with + | Pushtrap -> + (* CR-someday tbrindus: maybe we should have [Callstack.t] know about the + concept of trap handlers, and have e.g. [Callstack.{pushtrap,poptrap}] + insert markers into an auxiliary data structure. + + Then we could have operations like "close all frames until the last + trap", and enforce invariants like "you can't [ret] past a trap without + calling [poptrap] first" there rather than here. *) + (* Push a synthetic frame equal to the top of the existing stack, to avoid + erroneously inferring frames that shouldn't exist when execution happens + within a [try ... with] block that doesn't involve calls (and thus + generation of new frames). *) + let top = Callstack.top thread_info.callstack |> Option.value_exn in + Stack.push thread_info.inactive_callstacks thread_info.callstack; + thread_info.callstack <- Callstack.create ~create_time:time; + Callstack.push thread_info.callstack top + | Poptrap -> + (* Assuming we didn't drop anything, we should only have the synthetic + frame we created at this point. If we have more than that, we either got + confused in our state tracking somewhere, or more likely, IPT dropped + some data. *) + if Callstack.depth thread_info.callstack <> 1 + then + (* Conditional on happening once, this is likely to happen again... don't + spam the user's terminal. *) + eprint_s_once + t + [%here] + [%message + "WARNING: expected callstack depth to be the same going into a \ + [try] block as when leaving it, but it wasn't. Did Intel Processor \ + Trace drop some data? Will attempt to recover. Further errors will \ + be suppressed.\n" + ~depth:(Callstack.depth thread_info.callstack - 1 : int) + (src : Event.Location.t) + (dst : Event.Location.t) + (last_known_instruction_pointer : Int64.Hex.t)] + else ( + (* Only pop the exception callstack if we're at the same callstack + depth as we were when we saw [Pushtrap]. This should let us recover + from situations like: + + - Pushtrap 1 + - Pushtrap 2 + - Poptrap 2 + - Poptrap 1 + + where "Pushtrap 2" gets dropped. *) + ignore (Callstack.pop thread_info.callstack : _); + clear_trap_stack t thread_info ~time))); + last_known_instruction_pointer := Some dst.instruction_pointer + ;; +end + +let assert_trace_scope t event trace_scopes = + if List.find trace_scopes ~f:(Trace_scope.equal t.trace_scope) |> Option.is_none + then + (* CR-someday cgaebel: Should this raise? *) + eprint_s + [%message + "BUG: assumptions violated, saw an unexpected event for this trace mode" + ~trace_scope:(t.trace_scope : Trace_scope.t) + (event : Event.t)] +;; + +let end_of_trace ?to_time (T t) = + (* CR-someday cgaebel: I wish this iteration had a defined order; it'd make magic-trace + a little bit more deterministic. *) + Hashtbl.iter t.thread_info ~f:(fun thread_info -> + end_of_thread t thread_info ~time:thread_info.last_event_time ~is_kernel_address:false; + match to_time with + | Some time -> + let mapped_time = map_time t time in + thread_info.pending_time <- mapped_time; + thread_info.last_event_time <- mapped_time; + thread_info.callstack.create_time <- mapped_time + | None -> ()) +;; + +let rewrite_callstack t ~(callstack : Callstack.t) ~thread_info ~time = + let called_locations = callstack.stack |> Stack.to_list |> List.rev in + List.iter called_locations ~f:(fun location -> + write_pending_event' + t + thread_info + time + (Pending_event.create_call location ~from_untraced:true) + (* Not necessarily true, but setting [~from_untraced:true] causes the timestamp to be annotated as inferred *)); + callstack.create_time + <- Mapped_time.add + time + (Time_ns.Span.of_ns + (-1.) + (* Set the reset time of future untraced returns to before the rewritten callstack *)) +;; + +let rewrite_all_callstacks t ~(thread_info : _ Thread_info.t) ~time = + let inactive_callstacks = + thread_info.inactive_callstacks |> Stack.to_list |> List.rev + in + List.iter inactive_callstacks ~f:(fun callstack -> + rewrite_callstack t ~callstack ~thread_info ~time); + rewrite_callstack t ~callstack:thread_info.callstack ~thread_info ~time +;; + +let maybe_start_filtered_region t ~should_write ~time = + if (not t.in_filtered_region) && should_write + then ( + Hashtbl.iter t.thread_info ~f:(fun thread_info -> + flush t ~to_time:time thread_info; + Deque.clear thread_info.start_events); + t.in_filtered_region <- true; + Hashtbl.iter t.thread_info ~f:(fun thread_info -> + rewrite_all_callstacks t ~thread_info ~time)) +;; + +let maybe_stop_filtered_region t ~should_write = + if t.in_filtered_region && not should_write + then ( + end_of_trace (T t); + t.in_filtered_region <- false) +;; + +let write_event_and_callstack + (events_writer : Tracing_tool_output.events_writer) + event + callstack + = + let compression_event = + Callstack_compression.compress_callstack + events_writer.callstack_compression_state + (Callstack.(callstack.stack) + |> Stack.to_list + |> List.map ~f:(fun Event.Location.{ symbol; _ } -> symbol)) + in + let event_and_callstack = + Event_and_callstack.{ event; callstack = compression_event } + in + match events_writer.format with + | Sexp -> + Async.Writer.write_sexp + ~terminate_with:Newline + events_writer.writer + [%sexp (event_and_callstack : Event_and_callstack.t)] + | Binio -> + Async.Writer.write_bin_prot + events_writer.writer + Event_and_callstack.bin_writer_t + event_and_callstack +;; + +let warn_decode_error ~instruction_pointer ~message = + eprintf + "Warning: perf reported an error decoding the trace: %s\n%!" + (match instruction_pointer with + | None -> [%string "'%{message}'"] + | Some instruction_pointer -> + [%string "'%{message}' @ IP %{instruction_pointer#Int64.Hex}."]) +;; + +(* Write perf_events into a file as a Fuchsia trace (stack events). Events should be + collected with --itrace=bep or cre, and -F pid,tid,time,flags,addr,sym,symoff as per + the constants defined above. *) +let rec write_event (T t) ?events_writer original_event = + if Env_vars.skip_transaction_handling + then write_event' (T t) ?events_writer original_event + else ( + let { Event.With_write_info.event; should_write = _ } = original_event in + (* 1. If this event is within a transaction, queue it. + 2. If this event ends a transaction, deliver all queued events (then deliver it) + 3. If this event is a transaction abort, clear all queued events and discard + the [Tx_abort]. *) + match event with + | Ok { Event.Ok.thread = _; time = _; data; in_transaction } -> + let is_abort = + match data with + | Trace { kind = Some Tx_abort; _ } -> true + | _ -> false + in + if is_abort + then ( + Deque.clear t.transaction_events; + write_event' (T t) ?events_writer original_event) + else if in_transaction + then Deque.enqueue_back t.transaction_events original_event + else ( + if not (Deque.is_empty t.transaction_events) + then ( + Deque.iter' t.transaction_events `front_to_back ~f:(fun ev -> + write_event' (T t) ?events_writer ev); + Deque.clear t.transaction_events); + write_event' (T t) ?events_writer original_event) + | Error _ -> + (* Unsure how to best handle errors during a transaction. *) + if not (Deque.is_empty t.transaction_events) + then ( + eprintf + "Warning: error received during transaction, dropping all transaction events\n\ + %!"; + Deque.clear t.transaction_events); + write_event' (T t) ?events_writer original_event) + +and write_event' (T t) ?events_writer event = + let { Event.With_write_info.event; should_write } = event in + let thread = Event.thread event in + let thread_info = + Hashtbl.find_or_add t.thread_info thread ~default:(fun () -> create_thread t event) + in + let thread = thread_info.thread in + let time = event_time t event thread_info in + let outer_event = event in + maybe_start_filtered_region t ~should_write ~time; + maybe_stop_filtered_region t ~should_write; + match event with + | Error { thread = _; instruction_pointer; message; time = _ } -> + warn_decode_error ~instruction_pointer ~message; + let name = sprintf !"[decode error: %s]" message in + write_duration_instant t ~thread ~name ~time ~args:[]; + let is_kernel_address = + match instruction_pointer with + | None -> false + | Some ip -> is_kernel_address ip + in + end_of_thread t thread_info ~time ~is_kernel_address + | Ok event_value -> + if should_write + then + Option.iter events_writer ~f:(fun events_writer -> + write_event_and_callstack events_writer event thread_info.callstack); + (match event_value with + | { Event.Ok.thread = _ + ; time = _ + ; data = Event_sample { location; count; name } + ; in_transaction = _ + } -> + let track_name = Collection_mode.Event.Name.to_string name in + let track_thread = + Hashtbl.find_or_add thread_info.extra_event_tracks name ~default:(fun () -> + allocate_thread t ~pid:thread_info.track_group_id ~name:track_name) + in + let args = + Tracing.Trace.Arg.( + List.concat + [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] + ; [ "symbol", String (Symbol.display_name location.symbol) ] + ; [ "addr", Pointer location.instruction_pointer ] + ; [ "count", Int count ] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) + ~default:[] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "tid", Int (Pid.to_int pid) ]) + ~default:[] + ]) + in + write_duration_complete + t + ~thread:track_thread + ~args + ~name:track_name + ~time + ~time_end:time + | { Event.Ok.thread = _ (* Already used this to look up thread info. *) + ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) + ; data = Power { freq } + ; in_transaction = _ + } -> + write_counter + t + ~thread + ~name:"CPU" + ~time + ~args:Tracing.Trace.Arg.[ "freq (MHz)", Int freq ] + | { Event.Ok.thread = _ (* Already used this to look up thread info. *) + ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) + ; data = Stacktrace_sample { callstack } + ; in_transaction = _ + } -> + let how_many_ret = + Stack.length thread_info.callstack.stack + - Callstack.how_many_match thread_info.callstack callstack + in + List.init how_many_ret ~f:Fn.id |> List.iter ~f:(fun _ -> ret t thread_info ~time); + let calls = List.drop callstack (Stack.length thread_info.callstack.stack) in + List.iter calls ~f:(fun location -> call t thread_info ~time ~location) + | { Event.Ok.thread = _ (* Already used this to look up thread info. *) + ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) + ; data = Trace { kind; trace_state_change; src; dst } + ; in_transaction = _ + } -> + Ocaml_hacks.track_executed_pushtraps_and_poptraps_in_range + t + thread_info + ~src + ~dst + ~time; + (match kind, trace_state_change with + | Some Call, (None | Some End) -> call t thread_info ~time ~location:dst + | ( Some + ( Async + | Call + | Syscall + | Return + | Hardware_interrupt + | Iret + | Interrupt + | Sysret + | Jump + | Tx_abort ) + , Some Start ) + | Some Async, None + | Some (Hardware_interrupt | Jump | Interrupt | Tx_abort), Some End -> + raise_s + [%message + "BUG: magic-trace devs thought this event was impossible, but you just \ + proved them wrong. Please report this to \ + https://github.com/janestreet/magic-trace/issues/" + (event : Event.t)] + | (None | Some Async), Some End -> + call t thread_info ~time ~location:Event.Location.untraced + | Some Syscall, Some End -> + (* We should only be getting these under /u *) + assert_trace_scope t outer_event [ Userspace ]; + call t thread_info ~time ~location:Event.Location.syscall + | Some Return, Some End -> + call t thread_info ~time ~location:Event.Location.returned + | Some Return, None -> + Ocaml_hacks.ret_track_exn_data t thread_info ~time; + (* [caml_raise_exn], at least at the time of writing, modifies the stack + and then [ret]s when raising. The OCaml compiler's codegen uses indirect + [jmp]s instead. *) + Ocaml_hacks.check_current_symbol_track_entertraps t thread_info ~time dst + | None, Some Start -> + (* Might get this under /u, /k, and /uk, but we need to handle them all + differently. *) + if Trace_scope.equal t.trace_scope Kernel + then ( + (* We're back in the kernel after having been in userspace. We have a + brand new stack to work with. [clear_callstack] here should only be + clearing the [untraced] frame here pushed by [End (Iret | Sysret)]. *) + clear_callstack t thread_info ~time; + Thread_info.set_callstack_from_addr + thread_info + ~addr:dst.instruction_pointer + ~time) + else if Callstack.is_empty thread_info.callstack + then + (* View stopping tracing always as a call (typically the result of a call + into a special library / linker), with starting tracing again as + exiting it. The one exception is the initial start of the trace for + that process, when there is no stack and a prior end won't have pushed + a synthetic stack frame. *) + call t thread_info ~time ~location:dst + else + (* We don't call [check_current_symbol] here because stops don't change + the program location in most cases, and when a call to a symbol page + faults, the restart after the page fault at the new location would get + treated as a tail call if we did call [check_current_symbol]. *) + Ocaml_hacks.ret_track_exn_data t thread_info ~time + | Some ((Syscall | Hardware_interrupt) as kind), None -> + (* We should only be getting [Syscall] these under /uk, but we can get + [Hardware_interrupt] under /uk, /k. *) + [ [ Trace_scope.Userspace_and_kernel ] + ; (if [%compare.equal: Event.Kind.t] kind Hardware_interrupt + then [ Kernel ] + else []) + ] + |> List.concat + |> assert_trace_scope t outer_event; + (* A syscall or hardware interrupt can be modelled as operating on a new + stack, and shouldn't be allowed to modify the previous stack. + + Also, hardware interrupts can occur during syscalls, so we maintain a + "stack of callstacks" here. *) + Stack.push thread_info.inactive_callstacks thread_info.callstack; + Thread_info.set_callstack_from_addr + thread_info + ~addr:dst.instruction_pointer + ~time; + call t thread_info ~time ~location:dst + | Some (Iret | Sysret), Some End -> + (* We should only be getting these under /k *) + assert_trace_scope t outer_event [ Kernel ]; + clear_callstack t thread_info ~time; + call t thread_info ~time ~location:Event.Location.untraced + | Some ((Iret | Sysret) as kind), None -> + (* We should only get [Sysret] under /uk, but might get [Iret] under /k as + well (because the kernel can be interrupted). *) + [ [ Trace_scope.Userspace_and_kernel ] + ; (if [%compare.equal: Event.Kind.t] kind Iret then [ Kernel ] else []) + ] + |> List.concat + |> assert_trace_scope t outer_event; + clear_callstack t thread_info ~time; + (match Stack.pop thread_info.inactive_callstacks with + | Some callstack -> thread_info.callstack <- callstack + | None -> + Thread_info.set_callstack_from_addr + thread_info + ~addr:dst.instruction_pointer + ~time; + check_current_symbol t thread_info ~time dst) + | Some Tx_abort, None -> check_current_symbol t thread_info ~time dst + | Some (Jump | Interrupt), None -> + Ocaml_hacks.check_current_symbol_track_entertraps t thread_info ~time dst + (* (None, _) comes up when perf spews something magic-trace doesn't recognize. + Instead of crashing, ignore it and keep going. *) + | None, _ -> ()); + if !debug then print_s (sexp_of_inner t)) +;; diff --git a/src/trace_writer.mli b/src/trace_writer.mli deleted file mode 100644 index 43534873b..000000000 --- a/src/trace_writer.mli +++ /dev/null @@ -1,70 +0,0 @@ -open! Core - -(* Enable this in tests to see [t] after every perf event. Don't forget to disable it when - you're done! - - To take advantage of this from perf script tests, call [Perf_script.run ~debug:true]. -*) -val debug : bool ref - -type t [@@deriving sexp_of] - -val create - : trace_scope:Trace_scope.t - -> debug_info:Elf.Addr_table.t option - -> ocaml_exception_info:Ocaml_exception_info.t option - -> earliest_time:Time_ns.Span.t - -> hits:(string * Breakpoint.Hit.t) list - -> annotate_inferred_start_times:bool - -> Tracing.Trace.t - -> t - -module type Trace = Trace_writer_intf.S_trace - -module Mapped_time : sig - type t = private Time_ns.Span.t [@@deriving sexp, compare, bin_io] - - include Comparable with type t := t - - val start_of_trace : t - val create : Time_ns.Span.t -> base_time:Time_ns.Span.t -> t - val is_base_time : t -> bool - val add : t -> Time_ns.Span.t -> t - val diff : t -> t -> Time_ns.Span.t -end - -module Callstack : sig - type t = - { stack : Event.Location.t Stack.t - ; mutable create_time : Mapped_time.t - } - [@@deriving sexp, bin_io] -end - -module Event_and_callstack : sig - type t = - { event : Event.t - ; callstack : Callstack_compression.compression_event - } - [@@deriving sexp, bin_io] -end - -val create_expert - : trace_scope:Trace_scope.t - -> debug_info:Elf.Addr_table.t option - -> ocaml_exception_info:Ocaml_exception_info.t option - -> earliest_time:Time_ns.Span.t - -> hits:(string * Breakpoint.Hit.t) list - -> annotate_inferred_start_times:bool - -> (module Trace with type thread = _) - -> t - -val write_event - : t - -> ?events_writer:Tracing_tool_output.events_writer - -> Event.With_write_info.t - -> unit - -(** Updates internal data structures when trace ends. If [to_time] is passed, will shift - to new start time which is useful when writing out multiple snapshots from perf. *) -val end_of_trace : ?to_time:Time_ns.Span.t -> t -> unit diff --git a/src/trace_writer_implementation_intf.ml b/src/trace_writer_implementation_intf.ml new file mode 100644 index 000000000..ee361f415 --- /dev/null +++ b/src/trace_writer_implementation_intf.ml @@ -0,0 +1,72 @@ +open! Core + +module type S = sig + (* Enable this in tests to see [t] after every perf event. Don't forget to disable it when + you're done! + + To take advantage of this from perf script tests, call [Perf_script.run ~debug:true]. + *) + val debug : bool ref + + type t [@@deriving sexp_of] + + val create + : trace_scope:Trace_scope.t + -> debug_info:Elf.Addr_table.t option + -> ocaml_exception_info:Ocaml_exception_info.t option + -> earliest_time:Time_ns.Span.t + -> hits:(string * Breakpoint.Hit.t) list + -> annotate_inferred_start_times:bool + -> Tracing.Trace.t + -> t + + module type Trace = Trace_writer_intf.S_trace + + module Mapped_time : sig + type t = private Time_ns.Span.t [@@deriving sexp, compare, bin_io] + + include Comparable with type t := t + + val start_of_trace : t + val create : Time_ns.Span.t -> base_time:Time_ns.Span.t -> t + val is_base_time : t -> bool + val add : t -> Time_ns.Span.t -> t + val diff : t -> t -> Time_ns.Span.t + end + + module Callstack : sig + type t = + { stack : Event.Location.t Stack.t + ; mutable create_time : Mapped_time.t + } + [@@deriving sexp, bin_io] + end + + module Event_and_callstack : sig + type t = + { event : Event.t + ; callstack : Callstack_compression.compression_event + } + [@@deriving sexp, bin_io] + end + + val create_expert + : trace_scope:Trace_scope.t + -> debug_info:Elf.Addr_table.t option + -> ocaml_exception_info:Ocaml_exception_info.t option + -> earliest_time:Time_ns.Span.t + -> hits:(string * Breakpoint.Hit.t) list + -> annotate_inferred_start_times:bool + -> (module Trace with type thread = _) + -> t + + val write_event + : t + -> ?events_writer:Tracing_tool_output.events_writer + -> Event.With_write_info.t + -> unit + + (** Updates internal data structures when trace ends. If [to_time] is passed, will shift + to new start time which is useful when writing out multiple snapshots from perf. *) + val end_of_trace : ?to_time:Time_ns.Span.t -> t -> unit +end From 1b216ef153c1819c96c796870c31dc508cb03cf3 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Tue, 9 Dec 2025 15:40:00 -0500 Subject: [PATCH 05/30] Introduce new, experimental trace-writing backend The existing `Trace_writer` module works well enough (albeit not perfectly) most of the time. However, it is difficult to reason about, in large part because it writes the trace in a streaming fashion. That introduces significant additional complexity and book-keeping, and limits the ability of the trace-writer to make use of information discovered later in the trace (I believe the latter is why traces produced today often have the few frames closest to the root wrong). Because we want to extend the trace-writer in the near future, we're starting fresh with a different design that's easier to reason about. The new implementation currently exists alongside the original, but the goal is to eventually replace it entirely. Instead of writing the trace in a streaming fashion, we construct an internal representation of the trace in memory, and write out the trace in a separate, final pass once all of the events have been consumed. The module responsible for doing most of the heavy lifting is the new `Trace_segment`, which represents a continuous, **lossless, and error-free** segment of the trace; we create a new trace-segment whenever we encounter an error. **This PR does not represent a complete, finished product.** The code here does indeed work, and already produces better traces than the existing backend in several cases, but has several critical pieces missing: - [ ] Trace-segment stitching: At present we naively treat each trace-segment as disjoint. We need to add an additional "stitching" pass before the trace is written out, making a heuristic, best-effort attempt to join together adjacent trace-segments in a way that preserves control-flow continuity. - [ ] OCaml exception handling logic when OCaml-specific debug-info is *not* available - [ ] Golang support (are we keeping this?) It should also go without saying that while this code appears to work well on the traces I've tried it on, I would not at all be surprised if there are still bugs/edge-cases. Signed-off-by: Kevin Svetlitski --- magic-trace.opam | 1 + magic-trace.opam.locked | 4 + src/dune | 2 +- src/new_trace_writer.ml | 410 ++------- src/new_trace_writer.mli | 2 + src/nonempty_vec.ml | 32 + src/nonempty_vec.mli | 19 + src/ocaml_exception_info.mli | 2 +- src/timestamp.ml | 7 + src/timestamp.mli | 8 + src/trace.ml | 2 +- src/trace_segment.ml | 1080 +++++++++++++++++++++++ src/trace_segment.mli | 25 + src/trace_writer.ml | 2 + src/trace_writer.mli | 2 + src/trace_writer_implementation_intf.ml | 2 + test/perf_script.ml | 2 +- 17 files changed, 1262 insertions(+), 340 deletions(-) create mode 100644 src/new_trace_writer.mli create mode 100644 src/nonempty_vec.ml create mode 100644 src/nonempty_vec.mli create mode 100644 src/timestamp.ml create mode 100644 src/timestamp.mli create mode 100644 src/trace_segment.ml create mode 100644 src/trace_segment.mli create mode 100644 src/trace_writer.mli diff --git a/magic-trace.opam b/magic-trace.opam index 68d28a3e2..a45c9af4d 100644 --- a/magic-trace.opam +++ b/magic-trace.opam @@ -27,6 +27,7 @@ depends: [ "owee" {>= "0.8"} "re" {>= "1.8.0"} "zstandard" + "vec" ] synopsis: "Collects and displays high-resolution traces of what a process is doing" description: "https://github.com/janestreet/magic-trace" diff --git a/magic-trace.opam.locked b/magic-trace.opam.locked index 85983ac0c..901473fff 100644 --- a/magic-trace.opam.locked +++ b/magic-trace.opam.locked @@ -66,6 +66,7 @@ depends: [ "fieldslib" {= "v0.18~preview.130.83+317"} "fix" {= "20250919" & with-test} "flexible_sexp" {= "v0.18~preview.130.83+317"} + "float_array" {= "v0.18~preview.130.83+317"} "fmt" {= "0.10.0"} "fpath" {= "0.7.3" & with-test} "int_repr" {= "v0.18~preview.130.83+317"} @@ -119,6 +120,7 @@ depends: [ "ppx_expect" {= "v0.18~preview.130.83+317"} "ppx_fields_conv" {= "v0.18~preview.130.83+317"} "ppx_fixed_literal" {= "v0.18~preview.130.83+317"} + "ppx_for_loop" {= "v0.18~preview.130.83+317"} "ppx_fuelproof" {= "v0.18~preview.130.83+317"} "ppx_globalize" {= "v0.18~preview.130.83+317"} "ppx_hash" {= "v0.18~preview.130.83+317"} @@ -174,6 +176,7 @@ depends: [ "time_now" {= "v0.18~preview.130.83+317"} "topkg" {= "1.0.8+ox"} "typerep" {= "v0.18~preview.130.83+317"} + "unboxed" {= "v0.18~preview.130.83+317"} "unique" {= "v0.18~preview.130.83+317"} "univ_map" {= "v0.18~preview.130.83+317"} "uopt" {= "v0.18~preview.130.83+317"} @@ -183,6 +186,7 @@ depends: [ "uuseg" {= "16.0.0" & with-test} "uutf" {= "1.0.3+ox"} "variantslib" {= "v0.18~preview.130.83+317"} + "vec" {= "v0.18~preview.130.83+317"} "zstandard" {= "v0.18~preview.130.83+317"} ] build: ["dune" "build" "-p" name "-j" jobs] diff --git a/src/dune b/src/dune index f6976b52a..fb96d1dc1 100644 --- a/src/dune +++ b/src/dune @@ -17,7 +17,7 @@ (names breakpoint_stubs boot_time_stubs ptrace_stubs)) (libraries core async core_unix.filename_unix fzf re shell core_unix.sys_unix cohttp cohttp_static_handler core_unix.signal_unix - tracing magic_trace owee angstrom expect_test_helpers_core) + tracing magic_trace owee angstrom expect_test_helpers_core vec) (inline_tests) (preprocess (pps ppx_jane))) diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index 6293daf4e..a2216f7d9 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -1,4 +1,5 @@ open! Core +module Nonempty_vec = Nonempty_vec.Value let debug = ref false let is_kernel_address addr = Int64.(addr < 0L) @@ -70,8 +71,6 @@ module Callstack = struct let push t v = Stack.push t.stack v let pop t = Stack.pop t.stack let top t = Stack.top t.stack - let is_empty t = Stack.is_empty t.stack - let depth t = Stack.length t.stack let how_many_match { stack; create_time = _ } (future_callstack : Event.Location.t list) = @@ -120,6 +119,7 @@ module Thread_info = struct ; mutable last_event_time : Mapped_time.t ; track_group_id : int ; extra_event_tracks : ('thread[@sexp.opaque]) Hashtbl.M(Collection_mode.Event.Name).t + ; trace_segments : (Trace_segment.t Nonempty_vec.t[@sexp.opaque]) } [@@deriving sexp_of] @@ -128,8 +128,34 @@ module Thread_info = struct t.callstack <- Callstack.create ~create_time ;; - let set_callstack_from_addr t ~addr ~time = - set_callstack t ~is_kernel_address:(is_kernel_address addr) ~time + let add_event_to_trace_segment t event_data time = + Trace_segment.add_event + (Nonempty_vec.last t.trace_segments) + event_data + (Timestamp.create time) + ;; + + module New_trace_segment_kind = struct + type t = + | Independent + | Continuing_from_current + end + + let start_new_trace_segment t ~in_filtered_region ~(kind : New_trace_segment_kind.t) = + let new_trace_segment = + match kind with + | Independent -> + let ocaml_exception_info = + match t.ocaml_exception_state with + | Without_exception_info _ -> None + | With_exception_info { ocaml_exception_info; _ } -> Some ocaml_exception_info + in + Trace_segment.create ocaml_exception_info ~in_filtered_region + | Continuing_from_current -> + let current = Nonempty_vec.last t.trace_segments in + Trace_segment.create_continuing_from current ~in_filtered_region + in + Nonempty_vec.push_back t.trace_segments new_trace_segment ;; end @@ -144,7 +170,6 @@ type 'thread inner = ; trace : (module Trace with type thread = 'thread) ; annotate_inferred_start_times : bool ; mutable in_filtered_region : bool - ; suppressed_errors : Hash_set.M(Source_code_position).t ; mutable transaction_events : Event.With_write_info.t Deque.t } @@ -156,13 +181,6 @@ let sexp_of_inner inner = let sexp_of_t (T inner) = sexp_of_inner inner -let eprint_s_once t here sexp = - if not (Hash_set.mem t.suppressed_errors here) - then ( - Hash_set.add t.suppressed_errors here; - eprint_s sexp) -;; - let allocate_pid (type thread) (t : thread inner) ~name : int = let module T = (val t.trace) in T.allocate_pid ~name @@ -321,7 +339,6 @@ let create_expert ; trace ; annotate_inferred_start_times ; in_filtered_region = true - ; suppressed_errors = Hash_set.create (module Source_code_position) ; transaction_events = Deque.create () } in @@ -555,6 +572,9 @@ let create_thread t event = ; last_event_time = effective_time ; track_group_id ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) + ; trace_segments = + Trace_segment.create t.ocaml_exception_info ~in_filtered_region:t.in_filtered_region + |> Nonempty_vec.create } ;; @@ -683,205 +703,18 @@ let ret t (thread_info : _ Thread_info.t) ~time : unit = Go_hacks.ret_track_gogo t thread_info ~time ~returned_from ;; -let check_current_symbol - t - (thread_info : _ Thread_info.t) - ~time - (location : Event.Location.t) - = - (* After every operation, we should be in a situation where the current symbol under - the pc matches the symbol at the top of the callstack. This can go out-of-sync - with jumps between functions (e.g. tailcalls, PLT) or returns out of the highest - known function, so we have to correct the top of the stack here. *) - match Callstack.top thread_info.callstack with - | Some { symbol; _ } when not ([%compare.equal: Symbol.t] symbol location.symbol) -> - ret t thread_info ~time; - call t thread_info ~time ~location - | Some _ -> () - | None -> - (* If we have no callstack left, then we just returned out of something we didn't - see the call for. Since we're in snapshot mode, this happens with functions - called before the perf events started, so add in a call that begins at the - start of the trace for that pid. - - These shouldn't be buffered for spreading since we want them exactly at the reset - time. *) - let ev = Pending_event.create_call location ~from_untraced:true in - write_pending_event t thread_info thread_info.callstack.create_time ev; - Callstack.push thread_info.callstack location -;; - -(* OCaml-specific hacks around tracking exception control flow. Supports two - modes. - - With exception info provided by the compiler: read - [core/ocaml_exception_info.mli] for details. - - Without exception info provided by the compiler: the way this works is that - it counts the number of [caml_next_frame_descriptor] calls while an - exception is unwinding, and knows to unwind the stack that many times (+/- a - constant) when the next [caml_raise_exn] or [caml_raise_exception] return. - - This mode fails to account for [raise_notrace] exceptions. *) - -module Ocaml_hacks : sig - val ret_track_exn_data : 'a inner -> 'a Thread_info.t -> time:Mapped_time.t -> unit - - val track_executed_pushtraps_and_poptraps_in_range - : 'a inner - -> 'a Thread_info.t - -> src:Event.Location.t - -> dst:Event.Location.t - -> time:Mapped_time.t - -> unit - - val check_current_symbol_track_entertraps - : 'a inner - -> 'a Thread_info.t - -> time:Mapped_time.t - -> Event.Location.t - -> unit -end = struct - (* It's ocaml, not go. *) - let ret = ret_without_checking_for_go_hacks - - let unwind_stack t (thread_info : _ Thread_info.t) ~time ~frames_to_unwind diff = - for _ = 0 to !frames_to_unwind + diff do - ret t thread_info ~time - done; - frames_to_unwind := 0 - ;; - - let ret_track_exn_data t thread_info ~time = - let { Thread_info.callstack; ocaml_exception_state; _ } = thread_info in - (match ocaml_exception_state with - | With_exception_info _ -> () - | Without_exception_info { frames_to_unwind } -> - (match Callstack.top callstack with - | Some { symbol = From_perf symbol; _ } -> - (match symbol with - | "caml_next_frame_descriptor" -> incr frames_to_unwind - | "caml_raise_exn" -> unwind_stack t thread_info ~time ~frames_to_unwind (-2) - | "caml_stash_backtrace" -> incr frames_to_unwind - | "caml_raise_exception" -> - unwind_stack t thread_info ~time ~frames_to_unwind 1 - | _ -> ()) - | _ -> ())); - ret t thread_info ~time - ;; - - let clear_trap_stack t thread_info ~time = - clear_callstack t thread_info ~time; - match Stack.pop thread_info.inactive_callstacks with - | Some callstack -> thread_info.callstack <- callstack - | None -> thread_info.callstack <- Callstack.create ~create_time:time - ;; - - let check_current_symbol_track_entertraps - t - (thread_info : 'a Thread_info.t) - ~time - (dst : Event.Location.t) - = - match thread_info.ocaml_exception_state with - | With_exception_info { ocaml_exception_info; _ } - when Ocaml_exception_info.is_entertrap - ocaml_exception_info - ~addr:dst.instruction_pointer -> - (* CR-someday tbrindus: unwind this hack. This recreates the callstack but with the - first (synthetic) frame missing. A more principled approach would be the one - outlined in another CR-someday below, where we teach [Callstack] about traps - directly. *) - let s = thread_info.callstack.stack |> Stack.to_list in - let s = List.take s (List.length s - 1) in - Stack.clear thread_info.callstack.stack; - List.iter (List.rev s) ~f:(fun x -> Stack.push thread_info.callstack.stack x); - clear_trap_stack t thread_info ~time - | _ -> check_current_symbol t thread_info ~time dst - ;; - - let track_executed_pushtraps_and_poptraps_in_range - t - (thread_info : _ Thread_info.t) - ~(src : Event.Location.t) - ~(dst : Event.Location.t) - ~time - = - match thread_info.ocaml_exception_state with - | Without_exception_info _ -> () - | With_exception_info { ocaml_exception_info; last_known_instruction_pointer } -> - (match !last_known_instruction_pointer with - | None -> () - | Some last_known_instruction_pointer -> - Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range - ocaml_exception_info - ~from:last_known_instruction_pointer - ~to_:src.instruction_pointer - ~f:(fun (_addr, kind) -> - match kind with - | Pushtrap -> - (* CR-someday tbrindus: maybe we should have [Callstack.t] know about the - concept of trap handlers, and have e.g. [Callstack.{pushtrap,poptrap}] - insert markers into an auxiliary data structure. - - Then we could have operations like "close all frames until the last - trap", and enforce invariants like "you can't [ret] past a trap without - calling [poptrap] first" there rather than here. *) - (* Push a synthetic frame equal to the top of the existing stack, to avoid - erroneously inferring frames that shouldn't exist when execution happens - within a [try ... with] block that doesn't involve calls (and thus - generation of new frames). *) - let top = Callstack.top thread_info.callstack |> Option.value_exn in - Stack.push thread_info.inactive_callstacks thread_info.callstack; - thread_info.callstack <- Callstack.create ~create_time:time; - Callstack.push thread_info.callstack top - | Poptrap -> - (* Assuming we didn't drop anything, we should only have the synthetic - frame we created at this point. If we have more than that, we either got - confused in our state tracking somewhere, or more likely, IPT dropped - some data. *) - if Callstack.depth thread_info.callstack <> 1 - then - (* Conditional on happening once, this is likely to happen again... don't - spam the user's terminal. *) - eprint_s_once - t - [%here] - [%message - "WARNING: expected callstack depth to be the same going into a \ - [try] block as when leaving it, but it wasn't. Did Intel Processor \ - Trace drop some data? Will attempt to recover. Further errors will \ - be suppressed.\n" - ~depth:(Callstack.depth thread_info.callstack - 1 : int) - (src : Event.Location.t) - (dst : Event.Location.t) - (last_known_instruction_pointer : Int64.Hex.t)] - else ( - (* Only pop the exception callstack if we're at the same callstack - depth as we were when we saw [Pushtrap]. This should let us recover - from situations like: - - - Pushtrap 1 - - Pushtrap 2 - - Poptrap 2 - - Poptrap 1 - - where "Pushtrap 2" gets dropped. *) - ignore (Callstack.pop thread_info.callstack : _); - clear_trap_stack t thread_info ~time))); - last_known_instruction_pointer := Some dst.instruction_pointer - ;; -end - -let assert_trace_scope t event trace_scopes = - if List.find trace_scopes ~f:(Trace_scope.equal t.trace_scope) |> Option.is_none - then - (* CR-someday cgaebel: Should this raise? *) - eprint_s - [%message - "BUG: assumptions violated, saw an unexpected event for this trace mode" - ~trace_scope:(t.trace_scope : Trace_scope.t) - (event : Event.t)] +let write_trace_segments (type thread) (t : thread inner) = + Hashtbl.iter t.thread_info ~f:(fun thread_info -> + Nonempty_vec.iter thread_info.trace_segments ~f:(fun trace_segment -> + if Trace_segment.in_filtered_region trace_segment + then + Trace_segment.write_trace + trace_segment + t.trace + thread_info.thread + t.debug_info + ~enter_initial_callstack:true + ~exit_final_callstack:true)) ;; let end_of_trace ?to_time (T t) = @@ -898,6 +731,12 @@ let end_of_trace ?to_time (T t) = | None -> ()) ;; +let finalize t = + end_of_trace t; + let (T t) = t in + write_trace_segments t +;; + let rewrite_callstack t ~(callstack : Callstack.t) ~thread_info ~time = let called_locations = callstack.stack |> Stack.to_list |> List.rev in List.iter called_locations ~f:(fun location -> @@ -929,7 +768,11 @@ let maybe_start_filtered_region t ~should_write ~time = then ( Hashtbl.iter t.thread_info ~f:(fun thread_info -> flush t ~to_time:time thread_info; - Deque.clear thread_info.start_events); + Deque.clear thread_info.start_events; + Thread_info.start_new_trace_segment + thread_info + ~in_filtered_region:true + ~kind:Continuing_from_current); t.in_filtered_region <- true; Hashtbl.iter t.thread_info ~f:(fun thread_info -> rewrite_all_callstacks t ~thread_info ~time)) @@ -939,7 +782,12 @@ let maybe_stop_filtered_region t ~should_write = if t.in_filtered_region && not should_write then ( end_of_trace (T t); - t.in_filtered_region <- false) + t.in_filtered_region <- false; + Hashtbl.iter t.thread_info ~f:(fun thread_info -> + Thread_info.start_new_trace_segment + thread_info + ~in_filtered_region:false + ~kind:Continuing_from_current)) ;; let write_event_and_callstack @@ -1042,7 +890,11 @@ and write_event' (T t) ?events_writer event = | None -> false | Some ip -> is_kernel_address ip in - end_of_thread t thread_info ~time ~is_kernel_address + end_of_thread t thread_info ~time ~is_kernel_address; + Thread_info.start_new_trace_segment + thread_info + ~in_filtered_region:t.in_filtered_region + ~kind:Independent | Ok event_value -> if should_write then @@ -1106,128 +958,14 @@ and write_event' (T t) ?events_writer event = List.init how_many_ret ~f:Fn.id |> List.iter ~f:(fun _ -> ret t thread_info ~time); let calls = List.drop callstack (Stack.length thread_info.callstack.stack) in List.iter calls ~f:(fun location -> call t thread_info ~time ~location) - | { Event.Ok.thread = _ (* Already used this to look up thread info. *) - ; time = _ (* Already in scope. Also, this time hasn't been [map_time]'d. *) - ; data = Trace { kind; trace_state_change; src; dst } + | { Event.Ok.thread = _ + ; time = _ + ; data = Trace { kind = _; trace_state_change = _; src = _; dst = _ } ; in_transaction = _ } -> - Ocaml_hacks.track_executed_pushtraps_and_poptraps_in_range - t + (* TODO Re-add the assertion from the old trace-writer on impossible [kind, trace_state_change] combinations *) + Thread_info.add_event_to_trace_segment thread_info - ~src - ~dst - ~time; - (match kind, trace_state_change with - | Some Call, (None | Some End) -> call t thread_info ~time ~location:dst - | ( Some - ( Async - | Call - | Syscall - | Return - | Hardware_interrupt - | Iret - | Interrupt - | Sysret - | Jump - | Tx_abort ) - , Some Start ) - | Some Async, None - | Some (Hardware_interrupt | Jump | Interrupt | Tx_abort), Some End -> - raise_s - [%message - "BUG: magic-trace devs thought this event was impossible, but you just \ - proved them wrong. Please report this to \ - https://github.com/janestreet/magic-trace/issues/" - (event : Event.t)] - | (None | Some Async), Some End -> - call t thread_info ~time ~location:Event.Location.untraced - | Some Syscall, Some End -> - (* We should only be getting these under /u *) - assert_trace_scope t outer_event [ Userspace ]; - call t thread_info ~time ~location:Event.Location.syscall - | Some Return, Some End -> - call t thread_info ~time ~location:Event.Location.returned - | Some Return, None -> - Ocaml_hacks.ret_track_exn_data t thread_info ~time; - (* [caml_raise_exn], at least at the time of writing, modifies the stack - and then [ret]s when raising. The OCaml compiler's codegen uses indirect - [jmp]s instead. *) - Ocaml_hacks.check_current_symbol_track_entertraps t thread_info ~time dst - | None, Some Start -> - (* Might get this under /u, /k, and /uk, but we need to handle them all - differently. *) - if Trace_scope.equal t.trace_scope Kernel - then ( - (* We're back in the kernel after having been in userspace. We have a - brand new stack to work with. [clear_callstack] here should only be - clearing the [untraced] frame here pushed by [End (Iret | Sysret)]. *) - clear_callstack t thread_info ~time; - Thread_info.set_callstack_from_addr - thread_info - ~addr:dst.instruction_pointer - ~time) - else if Callstack.is_empty thread_info.callstack - then - (* View stopping tracing always as a call (typically the result of a call - into a special library / linker), with starting tracing again as - exiting it. The one exception is the initial start of the trace for - that process, when there is no stack and a prior end won't have pushed - a synthetic stack frame. *) - call t thread_info ~time ~location:dst - else - (* We don't call [check_current_symbol] here because stops don't change - the program location in most cases, and when a call to a symbol page - faults, the restart after the page fault at the new location would get - treated as a tail call if we did call [check_current_symbol]. *) - Ocaml_hacks.ret_track_exn_data t thread_info ~time - | Some ((Syscall | Hardware_interrupt) as kind), None -> - (* We should only be getting [Syscall] these under /uk, but we can get - [Hardware_interrupt] under /uk, /k. *) - [ [ Trace_scope.Userspace_and_kernel ] - ; (if [%compare.equal: Event.Kind.t] kind Hardware_interrupt - then [ Kernel ] - else []) - ] - |> List.concat - |> assert_trace_scope t outer_event; - (* A syscall or hardware interrupt can be modelled as operating on a new - stack, and shouldn't be allowed to modify the previous stack. - - Also, hardware interrupts can occur during syscalls, so we maintain a - "stack of callstacks" here. *) - Stack.push thread_info.inactive_callstacks thread_info.callstack; - Thread_info.set_callstack_from_addr - thread_info - ~addr:dst.instruction_pointer - ~time; - call t thread_info ~time ~location:dst - | Some (Iret | Sysret), Some End -> - (* We should only be getting these under /k *) - assert_trace_scope t outer_event [ Kernel ]; - clear_callstack t thread_info ~time; - call t thread_info ~time ~location:Event.Location.untraced - | Some ((Iret | Sysret) as kind), None -> - (* We should only get [Sysret] under /uk, but might get [Iret] under /k as - well (because the kernel can be interrupted). *) - [ [ Trace_scope.Userspace_and_kernel ] - ; (if [%compare.equal: Event.Kind.t] kind Iret then [ Kernel ] else []) - ] - |> List.concat - |> assert_trace_scope t outer_event; - clear_callstack t thread_info ~time; - (match Stack.pop thread_info.inactive_callstacks with - | Some callstack -> thread_info.callstack <- callstack - | None -> - Thread_info.set_callstack_from_addr - thread_info - ~addr:dst.instruction_pointer - ~time; - check_current_symbol t thread_info ~time dst) - | Some Tx_abort, None -> check_current_symbol t thread_info ~time dst - | Some (Jump | Interrupt), None -> - Ocaml_hacks.check_current_symbol_track_entertraps t thread_info ~time dst - (* (None, _) comes up when perf spews something magic-trace doesn't recognize. - Instead of crashing, ignore it and keep going. *) - | None, _ -> ()); - if !debug then print_s (sexp_of_inner t)) + event_value.data + (time :> Time_ns.Span.t)) ;; diff --git a/src/new_trace_writer.mli b/src/new_trace_writer.mli new file mode 100644 index 000000000..bd0e8fb1e --- /dev/null +++ b/src/new_trace_writer.mli @@ -0,0 +1,2 @@ +open! Core +include Trace_writer_implementation_intf.S diff --git a/src/nonempty_vec.ml b/src/nonempty_vec.ml new file mode 100644 index 000000000..b9409e3d6 --- /dev/null +++ b/src/nonempty_vec.ml @@ -0,0 +1,32 @@ +open! Core + +module%template [@kind k = (value, value & value & value)] T = struct + type ('a : k) t = ('a Vec.t[@kind k]) + + let create x = + let t = (Vec.create [@kind k]) () in + (Vec.push_back [@kind k]) t x; + t + ;; + + let unsafe_get = (Vec.unsafe_get [@kind k]) + let get = (Vec.get [@kind k]) + let set = (Vec.set [@kind k]) + let length = (Vec.length [@kind k]) + let first t = unsafe_get t 0 + let last t = unsafe_get t (length t - 1) + let push_back = (Vec.push_back [@kind k]) + let iter = (Vec.iter [@kind k]) + + let iter_pairs t ~f = + let mutable prev = first t in + for i = 1 to length t - 1 do + let curr = unsafe_get t i in + f #(prev, curr); + prev <- curr + done + ;; +end + +module Value = T [@kind value] +module Valuex3 = T [@kind value & value & value] diff --git a/src/nonempty_vec.mli b/src/nonempty_vec.mli new file mode 100644 index 000000000..ddb5e020b --- /dev/null +++ b/src/nonempty_vec.mli @@ -0,0 +1,19 @@ +open! Core + +module type%template [@kind k = (value, value & value & value)] S := sig + (** A [Vec.t] guaranteed to contain at least one element. *) + type ('a : k) t + + val create : 'a -> 'a t + val length : _ t -> int + val first : 'a t -> 'a + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit + val last : 'a t -> 'a + val push_back : 'a t -> 'a -> unit + val iter : 'a t -> f:local_ ('a -> unit) -> unit + val iter_pairs : 'a t -> f:local_ (#('a * 'a) -> unit) -> unit +end + +module Value : S [@kind value] +module Valuex3 : S [@kind value & value & value] diff --git a/src/ocaml_exception_info.mli b/src/ocaml_exception_info.mli index a8867fc70..61df58658 100644 --- a/src/ocaml_exception_info.mli +++ b/src/ocaml_exception_info.mli @@ -93,6 +93,6 @@ val is_entertrap : t -> addr:int64 -> bool val iter_pushtraps_and_poptraps_in_range : from:int64 -> to_:int64 - -> f:(int64 * Kind.t -> unit) + -> f:local_ (int64 * Kind.t -> unit) -> t -> unit diff --git a/src/timestamp.ml b/src/timestamp.ml new file mode 100644 index 000000000..ed711d584 --- /dev/null +++ b/src/timestamp.ml @@ -0,0 +1,7 @@ +open! Core + +type t = Time_ns.Span.t [@@deriving equal] + +let create t = t +let zero = Time_ns.Span.zero +let ( >= ) = Time_ns.Span.( >= ) diff --git a/src/timestamp.mli b/src/timestamp.mli new file mode 100644 index 000000000..0a9400574 --- /dev/null +++ b/src/timestamp.mli @@ -0,0 +1,8 @@ +open! Core + +(** A discrete point in time within a trace. *) +type t = private Time_ns.Span.t [@@deriving equal] + +val create : Time_ns.Span.t -> t +val zero : t +val ( >= ) : t -> t -> bool diff --git a/src/trace.ml b/src/trace.ml index e647293c4..831a58b9d 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -180,7 +180,7 @@ let write_trace_from_events (match events_writer with | Some Tracing_tool_output.{ format = Sexp; writer = w; _ } -> Writer.write_line w "))" | _ -> ()); - Trace_writer.end_of_trace writer; + Trace_writer.finalize writer; Option.iter trace ~f:(fun trace -> Tracing.Trace.close trace); close_result ;; diff --git a/src/trace_segment.ml b/src/trace_segment.ml new file mode 100644 index 000000000..7ba06d269 --- /dev/null +++ b/src/trace_segment.ml @@ -0,0 +1,1080 @@ +open! Core +module Location = Event.Location +module Nonempty_vec = Nonempty_vec.Valuex3 + +let debug = false + +module Frame : sig + (* These fields are actually **immutable** except for [Sentinel.t] instances. *) + type t = private + { mutable location : Event.Location.t + ; mutable parent : t Or_null.t + } + + val create : Location.t -> parent:t -> t + + (** Find the first frame whose [location.symbol] matches the provided argument. + + Returns the matching frame (if found), and that frame's distance from the initial + frame (e.g. a call to [find my_frame my_symbol] with a return value of + [#(This _, ~distance:0)] indicates that [my_frame.location.symbol] is [my_symbol]). *) + val find : t -> Symbol.t -> #(t Or_null.t * distance:int) + + (** Iterate from leaf-to-root up to the given number of frames, or until encountering + the [Sentinel.t] *) + val iter_n : t -> int -> f:local_ (t -> unit) -> unit + + (** Iterate the entire callstack from root-to-leaf. Note that this is *not* + tail-recursive, given that frames form a singly-linked list from leaf-to-root. *) + val iter_rev : t -> f:local_ (t -> unit) -> unit + + val find_ancestor : t -> ancestor:t -> int Or_null.t + + module Sentinel : sig + type frame := t + + (** The root of a callstack. A sentinel does not correspond to a real program + location, and its parent is always [Null]; it is the *only* frame allowed to have + a [Null] parent. + + Using a sentinel allows us to avoid a variety of special-cases, and lets us update + the root of all callstacks in a trace in O(1) time. *) + type t = private frame + + val create : unit -> t + + (** Mutate [t]'s contents to the provided [location] and [parent] and return [t] as a + [frame]. *) + val become_frame : t -> Location.t -> parent:frame -> frame + end + + module For_testing : sig + val to_string_list : t -> string list + val print_callstack : t -> unit + end +end = struct + type t = + { mutable location : Event.Location.t + ; mutable parent : t Or_null.t + } + + let[@inline always] create location ~parent = { location; parent = This parent } + + let rec find t target distance = + match t with + | { parent = Null; _ } -> #(Null, ~distance) + | { location = { symbol; _ }; _ } when Symbol.equal symbol target -> + #(This t, ~distance) + | { parent = This parent; _ } -> find parent target (distance + 1) + ;; + + let find t target = find t target 0 + + let rec iter_n t n ~f = + match t, n with + | { parent = Null; _ }, _ | _, 0 -> () + | { parent = This parent; _ }, n -> + f t; + iter_n parent (n - 1) ~f + ;; + + let rec iter_rev t ~f = + match t with + | { parent = Null; _ } -> () + | { parent = This parent; _ } -> + iter_rev parent ~f; + f t + ;; + + let rec find_ancestor t ~ancestor distance = + if phys_equal t ancestor + then This distance + else ( + match t with + | { parent = Null; _ } -> Null + | { parent = This parent; _ } -> find_ancestor parent ~ancestor (distance + 1)) + ;; + + let find_ancestor t ~ancestor = find_ancestor t ~ancestor 0 + + module Sentinel = struct + type nonrec t = t + + let sentinel_location : Location.t = + { instruction_pointer = 0L; symbol_offset = 0; symbol = From_perf "\x00" } + ;; + + let[@inline always] create () = { location = sentinel_location; parent = Null } + + let become_frame t location ~parent = + t.location <- location; + t.parent <- This parent; + t + ;; + end + + module For_testing = struct + let rec to_string_list acc t = + match t.parent with + | Null -> acc + | This parent -> + to_string_list (Symbol.display_name t.location.symbol :: acc) parent + ;; + + let to_string_list t = to_string_list [] t + let print_callstack leaf = to_string_list leaf |> String.concat_lines |> print_endline + end +end + +module Control_flow = struct + type t = + | Jump + | Call + | Return of { distance : int } + (** [distance] indicates how many frames this return pops off of the callstack. + [distance = 1] is the usual case of returning from the current frame to its + parent. *) +end + +module Callstack = struct + type t = + #{ time : Timestamp.t + ; leaf : Frame.t + ; control_flow : Control_flow.t + } +end + +type t = + { mutable root : Frame.Sentinel.t + ; mutable last_event_time : Timestamp.t + (** Strictly speaking maintaining [last_event_time] is not necessary, but we do so in + order to make bugs obvious. *) + ; callstacks : Callstack.t Nonempty_vec.t + (** Our reconstruction of the program's control-flow based on the input event stream. + When appending new elements to [callstacks], it's **vitally important** to maintain + the following invariants in order for [callstacks] to be correctly processed during + [write_trace]: + + 1. A callstack with [control_flow = Call] introduces **exactly** one new frame which + was not present in the callstack immediately preceding it. This new frame is its + [leaf]. + 2. A callstack with [control_flow = Return { distance }] **exits** [distance] + frames, starting from the leaf of the callstack immediately preceding it. + 3. A callstack with [control_flow = Jump] exits the [leaf] of the callstack + immediately preceding it, and enters a new frame, which is its [leaf]. *) + ; ocaml_exception_info : Ocaml_exception_info.t Or_null.t + ; exception_handlers : Frame.t Vec.t + (** The currently active OCaml exception handlers. This is used to determine which frame + to return to when [ocaml_exception_info] indicates that the current event is an + OCaml exception being raised in the traced program. + + In contrast to [callstacks] — which records the entire history of control-flow for + later examination — [exception_handlers] represents the state **as of the event we + are currently processing**, and as such is only used during the "ingestion" phase + (i.e. while calls are still being made to [add_event]). *) + ; mutable last_known_instruction_pointer : int64 + ; in_filtered_region : bool + } + +let create ocaml_exception_info ~in_filtered_region = + let root = Frame.Sentinel.create () in + { root + ; last_event_time = Timestamp.zero + ; callstacks = + Nonempty_vec.create + (#{ time = Timestamp.zero + ; leaf = (root :> Frame.t) + ; control_flow = Return { distance = 0 } + } + : Callstack.t) + ; exception_handlers = Vec.create () + ; ocaml_exception_info = Or_null.of_option ocaml_exception_info + ; last_known_instruction_pointer = Int64.max_value + ; in_filtered_region + } +;; + +let create_continuing_from existing ~in_filtered_region = + let last_callstack = Nonempty_vec.last existing.callstacks in + { existing with + callstacks = + Nonempty_vec.create + (#{ last_callstack with control_flow = Return { distance = 0 } } : Callstack.t) + ; exception_handlers = Vec.copy existing.exception_handlers + ; in_filtered_region + } +;; + +let in_filtered_region t = t.in_filtered_region +let[@inline always] current_frame t = (Nonempty_vec.last t.callstacks).#leaf + +let replace_root t location = + let new_sentinel = Frame.Sentinel.create () in + let root = + Frame.Sentinel.become_frame t.root location ~parent:(new_sentinel :> Frame.t) + in + t.root <- new_sentinel; + root +;; + +(* [handle_call] uses [src], unlike the other event handlers. The rationale for this + is that in the context of a call, [src] is the parent frame of the call to [dst] + and thus *it continues to exist*. We want our callstacks to reflect that. *) +let handle_call (t : t) (time : Timestamp.t) ~(src : Location.t) ~(dst : Location.t) = + (* First, reconcile things such that [src] matches [current_frame t] if it doesn't + already. *) + let () = + match Frame.find (current_frame t) src.symbol with + | #(This _, ~distance:0) -> (* The happy case, [src] matches [current_frame t]. *) () + | #(This src_frame, ~distance) -> + (* [src] exists, but is higher up the callstack. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = src_frame; control_flow = Return { distance } } + | #(Null, ~distance:0) -> + (* I would only ever expect this to occur at the very beginning of a trace. *) + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = Frame.create src ~parent:(t.root :> Frame.t) + ; control_flow = Call + } + | #(Null, ~distance:_) -> + (* We've somehow reached [src] without seeing the control-flow that brought us here. + + To maximize our chances of producing a coherent trace, we create a frame for + [src] as a child of the current frame. The idea here is that because we support + "long" [Return]s (i.e. [Return]s with [distance > 1]), inserting the additional + frame for [src] ( *in addition* to the frame we always create for [dst]) gives us + better odds of resynchronizing with the event stream, since now we can easily + handle a later return event to [src], [dst], or even both. *) + let src_frame = Frame.create src ~parent:(current_frame t) in + Nonempty_vec.push_back t.callstacks #{ time; leaf = src_frame; control_flow = Call } + in + (* Then create the new frame for [dst]. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = Frame.create dst ~parent:(current_frame t); control_flow = Call } +;; + +let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = + match (current_frame t).parent with + | Null -> + (* We are returning into something we did not see the call for. This can happen if + there's a series of calls like [fn1 -> fn2 -> fn3] and we started tracing during + the execution of [fn2], then we see a return into [fn1]. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = replace_root t dst; control_flow = Return { distance = 0 } } + | This parent_frame -> + (* We start our search for [dst] from the parent of the current frame because + otherwise you'd incorrectly handle non-tail recursion, and because returning to the + current frame is impossible anyway. We add 1 to [distance] in the [control_flow] to + account for the one extra frame implicitly traversed by doing this. *) + (match Frame.find parent_frame dst.symbol with + | #(This dst_frame, ~distance) -> + (* 99% of the time [distance] should be 0, indicating we are returning to + [parent_frame] as expected. We allow for the possibility of "long" returns to + account for [Sysret]/[Iret] events that return to userspace directly from deep + within their kernel/interrupt stack. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance = distance + 1 } } + | #(Null, ~distance:0) -> + (* Our [parent_frame] is the sentinel. We treat this identically to the [Null] case + in the outer match, for the same reasons stated in the comment there. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = replace_root t dst; control_flow = Return { distance = 0 + 1 } } + | #(Null, ~distance:_) -> + (* Something is probably wrong if we ever make it to this case, where the state + we're maintaining and the event we are processing seem to completely disagree. + Treating it like a tail-call seems like the least bad option, and at the very + least gets us to agree with the event stream that the current frame is [dst]. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = Frame.create dst ~parent:parent_frame; control_flow = Jump }) +;; + +let handle_jump (t : t) (time : Timestamp.t) ~(dst : Location.t) = + let current_frame = current_frame t in + if Symbol.equal current_frame.location.symbol dst.symbol + then + (* [dst] matches [current_frame t]. This is either a branch within a function, or + tail-recursion. For now we don't need to do anything in this case. That will change + once we support inlined frames. *) + () + else ( + match current_frame.parent with + | Null -> + (* This is probably a non-recursive tail-call, but we don't know anything + about the previous frame, so we treat this is a [Call] because we only + want to emit a frame-enter while writing out the trace. *) + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = Frame.create dst ~parent:(t.root :> Frame.t) + ; control_flow = Call + } + | This parent -> + (* This is probably a non-recursive tail-call. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = Frame.create dst ~parent; control_flow = Jump }) +;; + +let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = + match event with + | Trace { kind; src; dst; trace_state_change } -> + eprint_s + ~mach:() + [%message + (kind : Event.Kind.t option) + ~time:(Time_ns.Span.to_int_ns (time :> Time_ns.Span.t) % 10000000 : int) + ~src:(Symbol.display_name src.symbol) + ~dst:(Symbol.display_name dst.symbol) + (trace_state_change : Trace_state_change.t option)] + | _ -> () +;; + +let[@inline always] print (event : Event.Ok.Data.t) (time : Timestamp.t) = + if debug then print event time +;; + +let is_ocaml_exception_handler t ~(dst : Location.t) = + match t.ocaml_exception_info with + | Null -> false + | This ocaml_exception_info -> + Ocaml_exception_info.is_entertrap ocaml_exception_info ~addr:dst.instruction_pointer +;; + +let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = + match Vec.last t.exception_handlers with + | Null -> + eprintf + "Warning 1: [exception_handlers] appears to be out-of-sync with callstacks.\n%!"; + (match Frame.find (current_frame t) dst.symbol with + | #(This dst_frame, ~distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } } + | #(Null, ~distance) -> + (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = replace_root t dst; control_flow = Return { distance } }) + | This frame -> + Vec.pop_back_unit_exn t.exception_handlers; + assert (Symbol.equal frame.location.symbol dst.symbol); + (match Frame.find_ancestor (current_frame t) ~ancestor:frame with + | This distance -> + (* This is the happy case where our exception handler tracking is working as expected. *) + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = frame; control_flow = Return { distance } } + | Null -> + let message = + match Frame.find (current_frame t) dst.symbol with + | #(Null, ..) -> "This is likely to be a bug." + | #(This _, ..) -> + "This is deeply concerning because another frame with a matching symbol was \ + found. This is very likely to be a bug." + in + eprintf + "Warning 2: [exception_handlers] appears to be out-of-sync with [callstacks]. %s\n\ + %!" + message; + handle_return t time ~dst) +;; + +let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = + print event time; + assert (Timestamp.( >= ) time t.last_event_time); + t.last_event_time <- time; + (match t.ocaml_exception_info with + | Null -> () + | This ocaml_exception_info -> + (match event with + | Trace { src; dst; _ } -> + Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range + ocaml_exception_info + ~from:t.last_known_instruction_pointer + ~to_:src.instruction_pointer + ~f:(stack_ fun (_address, kind) -> + match kind with + | Pushtrap -> Vec.push_back t.exception_handlers (current_frame t) + | Poptrap -> + if phys_equal (This (current_frame t)) (Vec.last t.exception_handlers) + then Vec.pop_back_unit_exn t.exception_handlers + else + eprintf + "Warning 3: [exception_handlers] appears to be out-of-sync with \ + callstacks.\n\ + %!"); + t.last_known_instruction_pointer <- dst.instruction_pointer + | _ -> ())); + (match event with + (* TODO Get the untraced "kind" right instead of always showing [Location.untraced] for untraced time. *) + | Trace { trace_state_change = Some Start; dst; _ } -> handle_return t time ~dst + | Trace { trace_state_change = Some End; src; dst = _; _ } -> + handle_call t time ~src ~dst:Location.untraced + | Trace { trace_state_change = None; kind = Some kind; src; dst } -> + (match kind with + | Call | Syscall | Hardware_interrupt | Interrupt -> handle_call t time ~src ~dst + | (Return | Jump) when is_ocaml_exception_handler t ~dst -> + handle_ocaml_exception t time ~dst + | Return | Sysret | Iret -> handle_return t time ~dst + | Jump | Tx_abort | Async -> handle_jump t time ~dst) + | Trace { kind = None; _ } -> () + (* All of the below events are handled in [trace_writer.ml]. *) + | Power _ | Stacktrace_sample _ | Event_sample _ -> ()); + if debug + then ( + Frame.For_testing.print_callstack (current_frame t); + print_endline "-------------------------------") +;; + +module Writer : sig + type 'thread t + + val create + : (module Trace_writer_intf.S_trace with type thread = 'thread) + -> 'thread + -> Elf.Addr_table.t + -> 'thread t @ local + + val emit_frame_enter : 'thread t @ local -> Timestamp.t -> Frame.t -> unit + val emit_frame_exit : 'thread t @ local -> Timestamp.t -> Frame.t -> unit +end = struct + type 'thread t = + { mutable last_time : Timestamp.t @@ global + ; active_frames : Symbol.t Vec.t @@ global + (** Strictly speaking maintaining [last_time] and [active_frames] is not necessary + assuming the rest of the code is written correctly, but not checking our + invariants makes it *much* harder to figure out where things go wrong, because you + would just end up with a mangled Perfetto trace but the [magic-trace] invocation + would complete silently and successfully. *) + ; write_duration_begin : + args:Tracing.Trace.Arg.t list -> name:string -> time:Time_ns.Span.t -> unit + @@ global + ; write_duration_end : + args:Tracing.Trace.Arg.t list -> name:string -> time:Time_ns.Span.t -> unit + @@ global + ; debug_info : Elf.Addr_table.t @@ global + } + + let create + (type thread) + (trace : (module Trace_writer_intf.S_trace with type thread = thread)) + (thread : thread) + debug_info + = exclave_ + let module T = (val trace) in + stack_ + { last_time = Timestamp.zero + ; active_frames = Vec.create () + ; write_duration_begin = + (fun ~args ~name ~time -> T.write_duration_begin ~args ~thread ~name ~time) + ; write_duration_end = + (fun ~args ~name ~time -> T.write_duration_end ~args ~thread ~name ~time) + ; debug_info + } + ;; + + let location_args debug_info (location : Location.t) = + let display_name = Symbol.display_name location.symbol in + let base_address = + Int64.(location.instruction_pointer - of_int location.symbol_offset) + in + let open Tracing.Trace.Arg in + (* Using [Interned] may cause some issues with the 32k interned string limit, on + sufficiently large programs if the trace goes through a lot of different code, + but that'll also be a problem with the span names. This will just make it + happen around twice as fast. It does make the traces noticeably smaller. + + The real solution is to get around to improving the interning table management + in the trace writer library. + + --- + + [base_address] might be lie in the kernel, in which case [to_int] will fail (but + that's alright, because we wouldn't have a symbol for it in the executable's + [debug_info] anyway). *) + let address = "address", Pointer location.instruction_pointer in + match location.symbol with + | From_perf_map { start_addr = _; size = _; function_ = _ } -> + address :: [ "symbol", Interned display_name ] + | _ -> + (match Option.bind (Int64.to_int base_address) ~f:(Hashtbl.find debug_info) with + | None -> address :: [ "symbol", Interned display_name ] + | Some (info : Elf.Location.t) -> + (address + :: [ "line", Int info.line + ; "col", Int info.col + ; "symbol", Interned display_name + ]) + @ + (match info.filename with + | Some x -> [ "file", Interned x ] + | None -> [])) + ;; + + let emit_frame_enter (local_ (t : _ t)) (time : Timestamp.t) (frame : Frame.t) = + let location = frame.location in + assert (Timestamp.( >= ) time t.last_time); + t.last_time <- time; + Vec.push_back t.active_frames location.symbol; + if debug then eprintf "Enter %s\n" (Symbol.display_name location.symbol); + t.write_duration_begin + ~args:(location_args t.debug_info location) + ~name:(Symbol.display_name location.symbol) + ~time:(time :> Time_ns.Span.t) + ;; + + let emit_frame_exit (t : _ t) (time : Timestamp.t) (frame : Frame.t) = + let location = frame.location in + assert (Timestamp.( >= ) time t.last_time); + t.last_time <- time; + [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; + if debug then eprintf "Exit %s\n" (Symbol.display_name location.symbol); + t.write_duration_end + ~args:[] + ~name:(Symbol.display_name location.symbol) + ~time:(time :> Time_ns.Span.t) + ;; +end + +(* Intel PT may produce many events with the same timestamp due to resolution limitations. + To produce better visual traces, we "smear" time, evenly distributing time amongst runs + of consecutive events that all have the same timestamp. *) +let smear_times (callstacks : Callstack.t Nonempty_vec.t) = + (* It would be reasonable to also have [Return]s consume time, but making them not consume + time substantially reduces the frequency where we need to use zero-duration events. + In general the traces are easier to read if returns aren't counted as consuming time. *) + let[@inline always] consumes_time : Callstack.t -> bool = function + | #{ control_flow = Call | Jump; _ } -> true + | _ -> false + in + let len = Nonempty_vec.length callstacks in + let mutable i = 0 in + while i < len do + let t1 = (Nonempty_vec.get callstacks i).#time in + (* Find the end of the run of events with the same timestamp *) + let mutable run_end = i in + let mutable num_time_consuming_events = + consumes_time (Nonempty_vec.get callstacks i) |> Bool.to_int + in + while + run_end + 1 < len + && Timestamp.equal (Nonempty_vec.get callstacks (run_end + 1)).#time t1 + do + num_time_consuming_events + <- num_time_consuming_events + + (consumes_time (Nonempty_vec.get callstacks (run_end + 1)) |> Bool.to_int); + run_end <- run_end + 1 + done; + num_time_consuming_events <- Int.max 1 num_time_consuming_events; + let run_length = run_end - i + 1 in + if run_end + 1 < len + then ( + (* Smear times across this run *) + let t2 = (Nonempty_vec.get callstacks (run_end + 1)).#time in + let duration_ns = + Time_ns.Span.( - ) (t2 :> Time_ns.Span.t) (t1 :> Time_ns.Span.t) + |> Time_ns.Span.to_int_ns + in + let mutable time_consuming_events_seen = 0 in + for k = 0 to run_length - 1 do + let cs = Nonempty_vec.get callstacks (i + k) in + let offset_ns = + duration_ns * time_consuming_events_seen / num_time_consuming_events + in + let smeared_time = + Timestamp.create Time_ns.Span.((t1 :> Time_ns.Span.t) + of_int_ns offset_ns) + in + (* Rewriting the entire [Callstack.t] instead of modifying just the [time] field + in-place is sad, but I'm not sure the microoptimization is worth the hassle + it'd take to achieve it. *) + Nonempty_vec.set callstacks (i + k) #{ cs with time = smeared_time }; + time_consuming_events_seen + <- time_consuming_events_seen + (consumes_time cs |> Bool.to_int) + done + (* else: final run - keep original times *)); + i <- run_end + 1 + done +;; + +let write_trace + (type thread) + (t : t) + (trace : (module Trace_writer_intf.S_trace with type thread = thread)) + (thread : thread) + debug_info + ~enter_initial_callstack + ~exit_final_callstack + = + let writer = Writer.create trace thread debug_info in + if Nonempty_vec.length t.callstacks > 1 + then ( + smear_times t.callstacks; + if enter_initial_callstack + then ( + let first_callstack = Nonempty_vec.get t.callstacks 1 in + let () = + match first_callstack.#leaf.parent with + | Null -> () + | This parent_frame -> + (* Emit a frame enter for everything except the leaf in the initial callstack. We + need to do this because otherwise we'd be missing parent frames in the trace that + we discovered by returning into them (see the [Null] case in [handle_return]). *) + Frame.iter_rev parent_frame ~f:(stack_ fun frame -> + Writer.emit_frame_enter writer first_callstack.#time frame) + in + (* Modify [t.callstacks] so that the first pair processed in + [Nonempty_vec.iter_pairs] below calls [emit_frame_enter] for the leaf frame. *) + Nonempty_vec.set t.callstacks 1 #{ first_callstack with control_flow = Call }); + Nonempty_vec.iter_pairs + t.callstacks + ~f:(stack_ fun (#(prev, curr) : #(Callstack.t * Callstack.t)) -> + let time = curr.#time in + match curr.#control_flow with + | Jump -> + Writer.emit_frame_exit writer time prev.#leaf; + Writer.emit_frame_enter writer time curr.#leaf + | Call -> Writer.emit_frame_enter writer time curr.#leaf + | Return { distance } -> + Frame.iter_n prev.#leaf distance ~f:(stack_ fun frame -> + Writer.emit_frame_exit writer time frame) + [@nontail]); + if exit_final_callstack + then ( + (* Call [emit_frame_exit] for all remaining frames at the end of the segment. *) + let last_callstack = Nonempty_vec.last t.callstacks in + Frame.iter_n last_callstack.#leaf Int.max_value ~f:(stack_ fun frame -> + Writer.emit_frame_exit writer last_callstack.#time frame) + [@nontail])) +;; + +module%test _ = struct + (* Takes a string like "a-b-c-d-e" which describes a callstack in root-to-leaf order, + each letter being a function name. *) + let parse_frames string = + let root = Frame.Sentinel.create () in + let leaf = + String.split string ~on:'-' + |> List.fold + ~init:(root :> Frame.t) + ~f:(fun root leaf_name -> + Frame.create + Location. + { symbol_offset = 0 + ; instruction_pointer = 0L + ; symbol = From_perf leaf_name + } + ~parent:root) + in + #(~root, ~leaf) + ;; + + (* Throughout this test-suite, things are rendered vertically in the same way they'd + appear in the Perfetto viewer. *) + + let print_frame_callstack = Frame.For_testing.print_callstack + + let%expect_test "[parse_frames] utility" = + let #(~root:_, ~leaf) = parse_frames "a-b-c-d-e" in + print_frame_callstack leaf; + [%expect {| + a + b + c + d + e + |}] + ;; + + module%test Smear_times = struct + let create_callstacks_with_control_flow (items : (int * Control_flow.t) list) + : Callstack.t Nonempty_vec.t + = + let #(~root:_, ~leaf) = parse_frames "a" in + match items with + | [] -> assert false + | (first_time, first_cf) :: rest -> + let vec = + Nonempty_vec.create + (#{ time = Timestamp.create (Time_ns.Span.of_int_ns first_time) + ; leaf + ; control_flow = first_cf + } + : Callstack.t) + in + List.iter rest ~f:(fun (t, cf) -> + Nonempty_vec.push_back + vec + (#{ time = Timestamp.create (Time_ns.Span.of_int_ns t) + ; leaf + ; control_flow = cf + } + : Callstack.t)); + vec + ;; + + let create_callstacks (times : int list) : Callstack.t Nonempty_vec.t = + List.map ~f:(fun time -> time, Control_flow.Call) times + |> create_callstacks_with_control_flow + ;; + + let print_times (callstacks : Callstack.t Nonempty_vec.t) = + Nonempty_vec.iter callstacks ~f:(fun (cs : Callstack.t) -> + printf "%2d " (Time_ns.Span.to_int_ns (cs.#time :> Time_ns.Span.t))); + print_endline "" + ;; + + let%expect_test "[smear_times] with all different timestamps (no smearing needed)" = + let callstacks = create_callstacks [ 0; 10; 20; 30 ] in + print_times callstacks; + [%expect {| 0 10 20 30 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 10 20 30 |}] + ;; + + let%expect_test "[smear_times] with consecutive same timestamps" = + let callstacks = create_callstacks [ 0; 0; 0; 30 ] in + print_times callstacks; + [%expect {| 0 0 0 30 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 10 20 30 |}] + ;; + + let%expect_test "[smear_times] with multiple runs of same timestamps" = + let callstacks = create_callstacks [ 0; 0; 20; 20; 20; 50 ] in + print_times callstacks; + [%expect {| 0 0 20 20 20 50 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 10 20 30 40 50 |}] + ;; + + let%expect_test "[smear_times] final run keeps original time" = + let callstacks = create_callstacks [ 0; 0; 30; 30; 30 ] in + print_times callstacks; + [%expect {| 0 0 30 30 30 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 15 30 30 30 |}] + ;; + + let%expect_test "[smear_times] single event" = + let callstacks = create_callstacks [ 100 ] in + print_times callstacks; + [%expect {| 100 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 100 |}] + ;; + + let%expect_test "[smear_times] all same timestamp (final run)" = + let callstacks = create_callstacks [ 50; 50; 50 ] in + print_times callstacks; + [%expect {| 50 50 50 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 50 50 50 |}] + ;; + + let%expect_test "[smear_times] only Call and Jump events consume time" = + let callstacks = + create_callstacks_with_control_flow + [ 0, Return { distance = 1 } + ; 0, Call + ; 0, Return { distance = 1 } + ; 0, Jump + ; 100, Call + ] + in + print_times callstacks; + [%expect {| 0 0 0 0 100 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 0 50 50 100 |}] + ;; + + let%expect_test "[smear_times] first event is a Call" = + let callstacks = + create_callstacks_with_control_flow + [ 0, Call; 0, Return { distance = 1 }; 0, Jump; 90, Call ] + in + print_times callstacks; + [%expect {| 0 0 0 90 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 45 45 90 |}] + ;; + + let%expect_test "[smear_times] only Returns uses fallback" = + let callstacks = + create_callstacks_with_control_flow + [ 0, Return { distance = 1 } + ; 0, Return { distance = 1 } + ; 0, Return { distance = 1 } + ; 90, Call + ] + in + print_times callstacks; + [%expect {| 0 0 0 90 |}]; + smear_times callstacks; + print_times callstacks; + [%expect {| 0 0 0 90 |}] + ;; + end + + let setup_test () = + let t = create None ~in_filtered_region:true in + let ip = ref (-1) in + let time = ref Time_ns.Span.zero in + let incr_time () = time := Time_ns.Span.(!time + of_int_ns 1) in + let location (name : string) : Location.t = + incr ip; + Location. + { instruction_pointer = Int64.of_int !ip + ; symbol_offset = 0 + ; symbol = From_perf name + } + in + let call ~src ~dst = + incr_time (); + let event = + Event.Ok.Data.Trace + { kind = Some Call + ; src = location src + ; dst = location dst + ; trace_state_change = None + } + in + add_event t event (Timestamp.create !time) + in + let return ~src ~dst = + incr_time (); + let event = + Event.Ok.Data.Trace + { kind = Some Return + ; src = location src + ; dst = location dst + ; trace_state_change = None + } + in + add_event t event (Timestamp.create !time) + in + let jump ~src ~dst = + incr_time (); + let event = + Event.Ok.Data.Trace + { kind = Some Jump + ; src = location src + ; dst = location dst + ; trace_state_change = None + } + in + add_event t event (Timestamp.create !time) + in + #(~t, ~call, ~return, ~jump) + ;; + + let frames_to_list t = + let result = ref [] in + Nonempty_vec.iter t.callstacks ~f:(fun (cs : Callstack.t) -> + result := cs.#leaf :: !result); + List.rev !result + ;; + + let concat_horizontal (lists : string list list) : string = + let max_len = + List.fold lists ~init:0 ~f:(fun acc lst -> Int.max acc (List.length lst)) + in + let width = 20 in + List.init max_len ~f:(fun row_idx -> + List.map lists ~f:(fun lst -> + let s = List.nth lst row_idx |> Option.value ~default:"" in + sprintf "%-*s" width s) + |> String.concat) + |> String.concat ~sep:"\n" + ;; + + let print_callstacks (t : t) = + frames_to_list t + (* Skip the initial sentinel callstack *) + |> List.tl + |> Option.value ~default:[] + |> List.map ~f:(fun frame -> Frame.For_testing.to_string_list frame) + |> concat_horizontal + |> print_endline; + (* So that the closing |}] of the [%expect ...] block is on its own line. *) + print_endline "-" + ;; + + (* In all of the following examples, unless otherwise specified assume no + tail-call-optimization is performed. *) + + (*= + let fn2 () = () + let fn3 () = () + + let fn1 () = + fn2 () + fn3 () + ;; + + let main () = fn1 () + *) + let%expect_test "Sanity-check [add_event]" = + let #(~t, ~call, ~return, ~jump:_) = setup_test () in + call ~src:"main" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn2"; + return ~src:"fn2" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn3"; + (* Return from [fn3] *) + return ~src:"fn3" ~dst:"fn1"; + (* Return from [fn1] *) + return ~src:"fn1" ~dst:"main"; + print_callstacks t; + [%expect + {| + main main main main main main main + fn1 fn1 fn1 fn1 fn1 + fn2 fn3 + - + |}] + ;; + + (*= + Assume we started tracing during the execution of [main] so we never saw the calls to [start] or [init] + + let fn2 () = () + let fn3 () = () + + let fn1 () = + fn2 () + fn3 () + ;; + + let main () = fn1 () + + let start () = main () + let init () = start () + *) + let%expect_test "A return to a function we never saw the call for" = + let #(~t, ~call, ~return, ~jump:_) = setup_test () in + call ~src:"main" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn2"; + return ~src:"fn2" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn3"; + return ~src:"fn3" ~dst:"fn1"; + return ~src:"fn1" ~dst:"main"; + print_callstacks t; + [%expect + {| + main main main main main main main + fn1 fn1 fn1 fn1 fn1 + fn2 fn3 + - + |}]; + (* Return for a call we didn't see *) + return ~src:"main" ~dst:"start"; + print_callstacks t; + [%expect + {| + start start start start start start start start + main main main main main main main + fn1 fn1 fn1 fn1 fn1 + fn2 fn3 + - + |}]; + (* Another return for a call we didn't see *) + return ~src:"start" ~dst:"init"; + print_callstacks t; + [%expect + {| + init init init init init init init init init + start start start start start start start start + main main main main main main main + fn1 fn1 fn1 fn1 fn1 + fn2 fn3 + - + |}] + ;; + + (*= + let fn2 () = () + let fn3 () = raise Failure + + let fn1 () = + fn2 () + fn3 () + ;; + + let main () = try fn1 () with _ -> () + *) + let%expect_test "Return multiple levels up the stack" = + let #(~t, ~call, ~return, ~jump:_) = setup_test () in + call ~src:"main" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn2"; + return ~src:"fn2" ~dst:"fn1"; + call ~src:"fn1" ~dst:"fn3"; + (* Raise from [fn3] into the [try] in [main] *) + return ~src:"fn3" ~dst:"main"; + print_callstacks t; + [%expect + {| + main main main main main main + fn1 fn1 fn1 fn1 + fn2 fn3 + - + |}] + ;; + + (*= + let fn1 () = + if something then do_something else do_something_else + ;; + + let main () = fn1 () + *) + let%expect_test "Simple jumps within a function" = + let #(~t, ~call, ~return, ~jump) = setup_test () in + call ~src:"main" ~dst:"fn1"; + jump ~src:"fn1" ~dst:"fn1"; + return ~src:"fn1" ~dst:"main"; + print_callstacks t; + [%expect + {| + main main main + fn1 + - + |}] + ;; + + (*= + + let fn2 () = () + let fn1 () = fn2() [@tail] + + let main () = fn1 () + *) + let%expect_test "Tail-call" = + let #(~t, ~call, ~return, ~jump) = setup_test () in + call ~src:"main" ~dst:"fn1"; + (* Tail-call [fn2] from [fn1] *) + jump ~src:"fn1" ~dst:"fn2"; + return ~src:"fn2" ~dst:"main"; + print_callstacks t; + [%expect + {| + main main main main + fn1 fn2 + - + |}] + ;; +end diff --git a/src/trace_segment.mli b/src/trace_segment.mli new file mode 100644 index 000000000..8212df75b --- /dev/null +++ b/src/trace_segment.mli @@ -0,0 +1,25 @@ +open! Core + +(** A continuous, lossless, error-free segment of a trace corresponding to a single + thread. *) +type t + +val create : Ocaml_exception_info.t option -> in_filtered_region:bool -> t + +(** Create a new trace segment that continues from the state of an existing segment, + taking the existing segment's last callstack as the new segment's first callstack. *) +val create_continuing_from : t -> in_filtered_region:bool -> t + +val in_filtered_region : t -> bool +val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit + +val write_trace + : t + -> (module Trace_writer_intf.S_trace with type thread = 'thread) + -> 'thread + -> Elf.Addr_table.t + -> enter_initial_callstack:bool + (** Emit a frame-enter for each frame in the *first* callstack of this segment. *) + -> exit_final_callstack:bool + (** Emit a frame-exit for each frame in the *last* callstack of this segment. *) + -> unit diff --git a/src/trace_writer.ml b/src/trace_writer.ml index 6293daf4e..3fccc71eb 100644 --- a/src/trace_writer.ml +++ b/src/trace_writer.ml @@ -1231,3 +1231,5 @@ and write_event' (T t) ?events_writer event = | None, _ -> ()); if !debug then print_s (sexp_of_inner t)) ;; + +let finalize t = end_of_trace t diff --git a/src/trace_writer.mli b/src/trace_writer.mli new file mode 100644 index 000000000..bd0e8fb1e --- /dev/null +++ b/src/trace_writer.mli @@ -0,0 +1,2 @@ +open! Core +include Trace_writer_implementation_intf.S diff --git a/src/trace_writer_implementation_intf.ml b/src/trace_writer_implementation_intf.ml index ee361f415..8af19fcf5 100644 --- a/src/trace_writer_implementation_intf.ml +++ b/src/trace_writer_implementation_intf.ml @@ -69,4 +69,6 @@ module type S = sig (** Updates internal data structures when trace ends. If [to_time] is passed, will shift to new start time which is useful when writing out multiple snapshots from perf. *) val end_of_trace : ?to_time:Time_ns.Span.t -> t -> unit + + val finalize : t -> unit end diff --git a/test/perf_script.ml b/test/perf_script.ml index 798408106..f64161a88 100644 --- a/test/perf_script.ml +++ b/test/perf_script.ml @@ -100,5 +100,5 @@ let run ?(debug = false) ?events_writer ?ocaml_exception_info ~trace_scope file Trace_writer.write_event ?events_writer trace_writer event | None -> ()); printf "INPUT TRACE STREAM ENDED, any lines printed below this were deferred\n"; - Trace_writer.end_of_trace trace_writer) + Trace_writer.finalize trace_writer) ;; From a05cd324c43292d7226427c04c6d7b7ccee85b8e Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 9 Feb 2026 14:45:39 -0500 Subject: [PATCH 06/30] Add an environment variable for selecting which trace-writer implementation to use Signed-off-by: Kevin Svetlitski --- src/env_vars.ml | 3 +++ src/env_vars.mli | 1 + src/trace.ml | 5 +++++ 3 files changed, 9 insertions(+) diff --git a/src/env_vars.ml b/src/env_vars.ml index 5be6eb7d5..49ca69d6f 100644 --- a/src/env_vars.ml +++ b/src/env_vars.ml @@ -54,3 +54,6 @@ let no_ocaml_exception_debug_info = let skip_transaction_handling = Option.is_some (Unix.getenv "MAGIC_TRACE_SKIP_TX_HANDLING") ;; + +(* Use [New_trace_writer] instead of [Trace_writer]. *) +let use_new_trace_writer = Option.is_some (Unix.getenv "MAGIC_TRACE_USE_NEW_TRACE_WRITER") diff --git a/src/env_vars.mli b/src/env_vars.mli index 79121a98b..ff1020ba8 100644 --- a/src/env_vars.mli +++ b/src/env_vars.mli @@ -12,3 +12,4 @@ val no_dlfilter : bool val fzf_demangle_symbols : bool val no_ocaml_exception_debug_info : bool val skip_transaction_handling : bool +val use_new_trace_writer : bool diff --git a/src/trace.ml b/src/trace.ml index 831a58b9d..2881ad27b 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -122,6 +122,11 @@ let write_trace_from_events in Tracing.Trace.Expert.create ~base_time:(Some base_time) writer in + let (module Trace_writer : Trace_writer_implementation_intf.S) = + if Env_vars.use_new_trace_writer + then (module New_trace_writer) + else (module Trace_writer) + in let writer = match trace with | Some trace -> From 18d616021d7206a58c6d91968f93f4717b6d46b2 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 16 Feb 2026 13:35:18 -0500 Subject: [PATCH 07/30] Add support for inlined frames Use LLVM to symbolize including inlined frames, and add these to the trace. This is definitely still a work-in-progress, and also makes the traces *much* larger. Signed-off-by: Kevin Svetlitski --- .github/workflows/build.yml | 72 +- .ocamlformat | 2 + direct_backend/cinaps/dune | 1 + dune | 4 +- dune-project | 2 +- lib/magic_trace/src/dune | 1 + lib/magic_trace/test/dune | 1 + magic-trace.opam.locked | 328 +++++---- src/dune | 36 +- src/env_vars.ml | 1 + src/env_vars.mli | 1 + src/event.ml | 23 +- src/event.mli | 1 + src/interned_string.ml | 23 + src/interned_string.mli | 6 + src/llvm_symbolizer_stubs.cpp | 62 ++ src/new_trace_writer.ml | 50 +- src/nonempty_vec.ml | 3 +- src/nonempty_vec.mli | 3 +- src/perf_decode.ml | 46 +- src/slice.ml | 36 + src/slice.mli | 11 + src/symbolizer.ml | 103 +++ src/symbolizer.mli | 57 ++ src/trace_segment.ml | 966 ++++++++++++++++++++------ src/trace_segment.mli | 5 +- src/trace_writer.ml | 4 +- test/dune | 12 +- test/sample-targets/long-running/dune | 10 +- test/sample-targets/ocaml-raise/dune | 8 +- test/test.ml | 11 +- 31 files changed, 1411 insertions(+), 478 deletions(-) create mode 100644 src/interned_string.ml create mode 100644 src/interned_string.mli create mode 100644 src/llvm_symbolizer_stubs.cpp create mode 100644 src/slice.ml create mode 100644 src/slice.mli create mode 100644 src/symbolizer.ml create mode 100644 src/symbolizer.mli diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index a73b114da..203c1da1c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -14,70 +14,31 @@ jobs: - '5.2.0+ox' runs-on: ${{ matrix.os }} + container: + image: alpine:latest steps: + # This has to come first because the `actions/*` GitHub Actions require `node`, + # which isn't installed by default on this container image. + - name: "Install apk packages" + run: | + apk add autoconf bash bubblewrap build-base clang coreutils git libstdc++ \ + libstdc++-dev libunwind-static linux-headers lld llvm20 llvm20-dev llvm20-static \ + nodejs opam rsync upx zlib-static zstd-static + echo "PATH=/usr/lib/llvm20/bin:$PATH" >> "$GITHUB_ENV" + - name: Checkout code uses: actions/checkout@v6 + # This is necessary to avoid an error of the form 'fatal: detected dubious ownership in repository ...' + - run: git config --global --add safe.directory $(pwd) + - uses: actions/cache@v5 with: path: ~/.opam - key: ${{ matrix.os }}-opam-${{ matrix.ocaml-version }}-1 - - - name: Install musl-compatible kernel headers - run: | - mkdir musl-kernel - filename='v4.19.88-1.tar.gz' - wget "https://github.com/sabotage-linux/kernel-headers/archive/refs/tags/$filename" - shasum --check <(echo "44a07e9f18033cff7840dbb112fff2862c0fb8fc $filename") - tar -xzf "$filename" -C musl-kernel --strip-components=1 - echo "C_INCLUDE_PATH=$(pwd)/musl-kernel/x86/include" >> "$GITHUB_ENV" - echo "CC=musl-gcc" >> "$GITHUB_ENV" - - - name: "Install apt packages" - run: | - sudo apt-get update - sudo apt-get install -y bubblewrap musl musl-tools libucl1 rsync - - - name: Install upx - run: | - # The version that comes with focal is broken for musl binaries, so we have to download - # from another location. - filename='upx-ucl_3.96-2_amd64.deb' - wget "http://ftp.debian.org/debian/pool/main/u/upx-ucl/$filename" - shasum --check <(echo "0b3c901a6ae8db264a0e58aad9bbed4ef3e925b9 $filename") - sudo dpkg -i upx-ucl_3.96-2_amd64.deb - - - name: Build zlib with musl - run: | - mkdir musl-zlib - filename='zlib-1.3.2.tar.gz' - wget "https://zlib.net/$filename" - shasum -a 256 --check <(echo "bb329a0a2cd0274d05519d61c667c062e06990d72e125ee2dfa8de64f0119d16 $filename") - tar -xzf "$filename" -C musl-zlib --strip-components=1 - cd musl-zlib - CC=musl-gcc ./configure --libdir=/usr/lib/x86_64-linux-musl --includedir=/usr/include/x86_64-linux-musl - make -j$(nproc) - sudo make install - - - name: Build zstd with musl - run: | - mkdir musl-zstd - filename='zstd-1.5.5.tar.gz' - wget "https://github.com/facebook/zstd/releases/download/v1.5.5/$filename" - shasum --check <(echo "4479ecc74300d23391d99fbebf2fddd47aed9b28 $filename") - tar -xzf "$filename" -C musl-zstd --strip-components=1 - cd musl-zstd - CC=musl-gcc make -j$(nproc) - sudo make INCLUDEDIR=/usr/include/x86_64-linux-musl LIBDIR=/usr/lib/x86_64-linux-musl install + key: ${{ matrix.os }}-opam-${{ matrix.ocaml-version }}-2 - name: Use OCaml ${{ matrix.ocaml-version }} run: | - filename='opam-2.5.0-x86_64-linux' - wget "https://github.com/ocaml/opam/releases/download/2.5.0/$filename" - shasum --check <(echo "67fb680a785f0bc7ceb57155f21786c0680ef5fe $filename") - sudo mv "$filename" /usr/local/bin/opam - sudo chmod a+x /usr/local/bin/opam - export OPAMYES=1 export OPAMJOBS=$(($(nproc) + 2)) echo "OPAMYES=1" >> "$GITHUB_ENV" @@ -93,11 +54,12 @@ jobs: - run: opam exec -- make PROFILE=static - - run: opam exec -- dune runtest + - run: opam exec -- dune runtest --profile=static - name: Compress magic-trace executable run: | cp _build/install/default/bin/magic-trace . + chmod u+w magic-trace ls -l magic-trace strip magic-trace upx -9 magic-trace diff --git a/.ocamlformat b/.ocamlformat index 3b217634a..c07affe0f 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1 +1,3 @@ profile=janestreet +wrap-comments=false +parse-docstrings=false diff --git a/direct_backend/cinaps/dune b/direct_backend/cinaps/dune index bf7580311..e983e06c5 100644 --- a/direct_backend/cinaps/dune +++ b/direct_backend/cinaps/dune @@ -1,5 +1,6 @@ (library (name magic_trace_lib_cinaps_helpers) + (no_dynlink) (libraries core) (preprocess (pps ppx_jane))) diff --git a/dune b/dune index 04df9caac..e5b7b1cc0 100644 --- a/dune +++ b/dune @@ -1,6 +1,8 @@ (env (static (flags - (:standard -cclib -static)))) + (:standard -cclib -static -cclib -no-pie)) + (link_flags + (:standard -cclib -static -cclib -no-pie)))) (vendored_dirs vendor) diff --git a/dune-project b/dune-project index 929c696e5..37f995d64 100644 --- a/dune-project +++ b/dune-project @@ -1 +1 @@ -(lang dune 2.0) +(lang dune 3.0) diff --git a/lib/magic_trace/src/dune b/lib/magic_trace/src/dune index e4f4bb693..df14633b1 100644 --- a/lib/magic_trace/src/dune +++ b/lib/magic_trace/src/dune @@ -1,6 +1,7 @@ (library (name magic_trace) (public_name magic-trace.magic_trace) + (no_dynlink) (foreign_stubs (language c) (names stop_stubs)) diff --git a/lib/magic_trace/test/dune b/lib/magic_trace/test/dune index 6f5684b2e..ea9a9a37e 100644 --- a/lib/magic_trace/test/dune +++ b/lib/magic_trace/test/dune @@ -1,5 +1,6 @@ (library (name magic_trace_test) + (no_dynlink) (libraries core expect_test_helpers_core magic_trace) (preprocess (pps ppx_jane))) diff --git a/magic-trace.opam.locked b/magic-trace.opam.locked index 901473fff..35b7831b3 100644 --- a/magic-trace.opam.locked +++ b/magic-trace.opam.locked @@ -13,12 +13,12 @@ bug-reports: "https://github.com/janestreet/magic-trace/issues" depends: [ "angstrom" {= "0.16.1"} "astring" {= "0.8.5"} - "async" {= "v0.18~preview.130.83+317"} - "async_kernel" {= "v0.18~preview.130.83+317"} - "async_log" {= "v0.18~preview.130.83+317"} - "async_rpc_kernel" {= "v0.18~preview.130.83+317"} - "async_unix" {= "v0.18~preview.130.83+317"} - "base" {= "v0.18~preview.130.83+317"} + "async" {= "v0.18~preview.130.91+190"} + "async_kernel" {= "v0.18~preview.130.91+190"} + "async_log" {= "v0.18~preview.130.91+190"} + "async_rpc_kernel" {= "v0.18~preview.130.91+190"} + "async_unix" {= "v0.18~preview.130.91+190"} + "base" {= "v0.18~preview.130.91+190"} "base-bigarray" {= "base"} "base-bytes" {= "base"} "base-domains" {= "base"} @@ -26,21 +26,20 @@ depends: [ "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.2"} - "base_bigstring" {= "v0.18~preview.130.83+317"} - "base_quickcheck" {= "v0.18~preview.130.83+317"} - "basement" {= "v0.18~preview.130.83+317"} - "bigarray-compat" {= "1.1.0"} + "base_bigstring" {= "v0.18~preview.130.91+190"} + "base_quickcheck" {= "v0.18~preview.130.91+190"} + "basement" {= "v0.18~preview.130.91+190"} "bigstringaf" {= "0.10.0"} - "bin_prot" {= "v0.18~preview.130.83+317"} + "bin_prot" {= "v0.18~preview.130.91+190"} "camlp-streams" {= "5.0.1"} "camlzip" {= "1.14"} - "capitalization" {= "v0.18~preview.130.83+317"} - "capsule" {= "v0.18~preview.130.83+317"} - "capsule0" {= "v0.18~preview.130.83+317"} + "capitalization" {= "v0.18~preview.130.91+190"} + "capsule" {= "v0.18~preview.130.91+190"} + "capsule0" {= "v0.18~preview.130.91+190"} "cmdliner" {= "1.3.0"} "cohttp" {= "5.3.1"} "cohttp-async" {= "5.3.0"} - "cohttp_static_handler" {= "v0.18~preview.130.83+317"} + "cohttp_static_handler" {= "v0.18~preview.130.91+190"} "conduit" {= "8.0.0"} "conduit-async" {= "8.0.0"} "conf-autoconf" {= "0.2"} @@ -48,42 +47,42 @@ depends: [ "conf-which" {= "1"} "conf-zlib" {= "1"} "conf-zstd" {= "1.3.8"} - "core" {= "v0.18~preview.130.83+317"} - "core_extended" {= "v0.18~preview.130.83+317"} - "core_kernel" {= "v0.18~preview.130.83+317"} - "core_unix" {= "v0.18~preview.130.83+317"} + "core" {= "v0.18~preview.130.91+190"} + "core_extended" {= "v0.18~preview.130.91+190"} + "core_kernel" {= "v0.18~preview.130.91+190"} + "core_unix" {= "v0.18~preview.130.91+190"} "crunch" {= "4.0.0"} "csexp" {= "1.5.2"} "cstruct" {= "6.2.0"} - "ctypes" {= "0.23.0+ox"} + "ctypes" {= "0.24.0+ox"} "domain-name" {= "0.5.0"} - "dune" {= "3.21.1"} - "dune-build-info" {= "3.21.1" & with-test} - "dune-configurator" {= "3.21.1"} - "either" {= "1.0.0" & with-test} - "expect_test_helpers_async" {= "v0.18~preview.130.83+317"} - "expect_test_helpers_core" {= "v0.18~preview.130.83+317"} - "fieldslib" {= "v0.18~preview.130.83+317"} - "fix" {= "20250919" & with-test} - "flexible_sexp" {= "v0.18~preview.130.83+317"} - "float_array" {= "v0.18~preview.130.83+317"} - "fmt" {= "0.10.0"} - "fpath" {= "0.7.3" & with-test} - "int_repr" {= "v0.18~preview.130.83+317"} + "dune" {= "3.20.2+ox1"} + "dune-build-info" {= "3.20.2"} + "dune-configurator" {= "3.20.2+ox"} + "either" {= "1.0.0"} + "expect_test_helpers_async" {= "v0.18~preview.130.91+190"} + "expect_test_helpers_core" {= "v0.18~preview.130.91+190"} + "fieldslib" {= "v0.18~preview.130.91+190"} + "fix" {= "20250919"} + "flexible_sexp" {= "v0.18~preview.130.91+190"} + "float_array" {= "v0.18~preview.130.91+190"} + "fmt" {= "0.11.0"} + "fpath" {= "0.7.3"} + "int_repr" {= "v0.18~preview.130.91+190"} "integers" {= "0.7.0"} "ipaddr" {= "5.6.2"} "ipaddr-sexp" {= "5.6.2"} - "jane-street-headers" {= "v0.18~preview.130.83+317"} + "jane-street-headers" {= "v0.18~preview.130.91+190"} "jsonm" {= "1.0.2"} - "jst-config" {= "v0.18~preview.130.83+317"} - "logs" {= "0.9.0"} + "jst-config" {= "v0.18~preview.130.91+190"} + "logs" {= "0.10.0"} "macaddr" {= "5.6.2"} "magic-mime" {= "1.3.1"} - "menhir" {= "20260209" & with-test} - "menhirCST" {= "20260209" & with-test} - "menhirGLR" {= "20260209" & with-test} - "menhirLib" {= "20260209" & with-test} - "menhirSdk" {= "20260209" & with-test} + "menhir" {= "20260209"} + "menhirCST" {= "20260209"} + "menhirGLR" {= "20260209"} + "menhirLib" {= "20260209"} + "menhirSdk" {= "20260209"} "num" {= "1.6"} "ocaml" {= "5.2.0"} "ocaml-compiler-libs" {= "v0.17.0+ox"} @@ -91,107 +90,178 @@ depends: [ "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} "ocaml-variants" {= "5.2.0+ox"} - "ocaml-version" {= "4.0.4" & with-test} - "ocaml_intrinsics" {= "v0.18~preview.130.83+317"} - "ocaml_intrinsics_kernel" {= "v0.18~preview.130.83+317"} - "ocamlbuild" {= "0.15.0+ox"} + "ocaml-version" {= "4.1.0"} + "ocaml_intrinsics" {= "v0.18~preview.130.91+190"} + "ocaml_intrinsics_kernel" {= "v0.18~preview.130.91+190"} + "ocamlbuild" {= "0.16.1+ox"} "ocamlfind" {= "1.9.8+ox"} - "ocamlformat" {= "0.26.2+ox" & with-test} - "ocamlformat-lib" {= "0.26.2+ox" & with-test} - "ocp-indent" {= "1.9.0" & with-test} + "ocamlformat" {= "0.26.2+ox1" & with-test} + "ocamlformat-lib" {= "0.26.2+ox1"} + "ocp-indent" {= "1.9.0"} "odoc-parser" {= "3.1.0+ox"} "owee" {= "0.8"} - "parsexp" {= "v0.18~preview.130.83+317"} - "pipe_with_writer_error" {= "v0.18~preview.130.83+317"} - "portable" {= "v0.18~preview.130.83+317"} - "ppx_array_base" {= "v0.18~preview.130.83+317"} - "ppx_assert" {= "v0.18~preview.130.83+317"} - "ppx_base" {= "v0.18~preview.130.83+317"} - "ppx_bench" {= "v0.18~preview.130.83+317"} - "ppx_bin_prot" {= "v0.18~preview.130.83+317"} - "ppx_cold" {= "v0.18~preview.130.83+317"} - "ppx_compare" {= "v0.18~preview.130.83+317"} - "ppx_custom_printf" {= "v0.18~preview.130.83+317"} - "ppx_debug_assert" {= "v0.18~preview.130.83+317"} + "oxcaml" {= "latest"} + "oxcaml-alcotest" {= "guard"} + "oxcaml-backoff" {= "guard"} + "oxcaml-chrome-trace" {= "guard"} + "oxcaml-cmarkit" {= "guard"} + "oxcaml-compiler" {= "5.2.0minus31"} + "oxcaml-ctypes-foreign" {= "guard"} + "oxcaml-ctypes-patches" {= "enabled"} + "oxcaml-dot-merlin-reader" {= "guard"} + "oxcaml-dune-action-plugin" {= "guard"} + "oxcaml-dune-build-info" {= "guard"} + "oxcaml-dune-configurator-patches" {= "enabled"} + "oxcaml-dune-glob" {= "guard"} + "oxcaml-dune-patches" {= "enabled"} + "oxcaml-dune-private-libs" {= "guard"} + "oxcaml-dune-rpc" {= "guard"} + "oxcaml-dune-rpc-lwt" {= "guard"} + "oxcaml-dune-site" {= "guard"} + "oxcaml-dyn" {= "guard"} + "oxcaml-eio" {= "guard"} + "oxcaml-eio_linux" {= "guard"} + "oxcaml-eio_main" {= "guard"} + "oxcaml-eio_posix" {= "guard"} + "oxcaml-fs-io" {= "guard"} + "oxcaml-gen_js_api" {= "guard"} + "oxcaml-js_of_ocaml" {= "guard"} + "oxcaml-js_of_ocaml-compiler" {= "guard"} + "oxcaml-js_of_ocaml-ppx" {= "guard"} + "oxcaml-js_of_ocaml-toplevel" {= "guard"} + "oxcaml-jsonrpc" {= "guard"} + "oxcaml-lsp" {= "guard"} + "oxcaml-lwt" {= "guard"} + "oxcaml-lwt_direct" {= "guard"} + "oxcaml-lwt_ppx" {= "guard"} + "oxcaml-lwt_runtime_events" {= "guard"} + "oxcaml-mdx" {= "guard"} + "oxcaml-merlin" {= "guard"} + "oxcaml-merlin-lib" {= "guard"} + "oxcaml-notty-community" {= "guard"} + "oxcaml-ocaml-compiler-libs-patches" {= "enabled"} + "oxcaml-ocaml-index" {= "guard"} + "oxcaml-ocaml-lsp-server" {= "guard"} + "oxcaml-ocamlbuild-patches" {= "enabled"} + "oxcaml-ocamlc-loc" {= "guard"} + "oxcaml-ocamlfind-patches" {= "enabled"} + "oxcaml-ocamlformat-lib-patches" {= "enabled"} + "oxcaml-ocamlformat-patches" {= "enabled"} + "oxcaml-odoc" {= "guard"} + "oxcaml-odoc-driver" {= "guard"} + "oxcaml-odoc-md" {= "guard"} + "oxcaml-odoc-parser-patches" {= "enabled"} + "oxcaml-ojs" {= "guard"} + "oxcaml-omd" {= "guard"} + "oxcaml-opam-core" {= "guard"} + "oxcaml-opam-format" {= "guard"} + "oxcaml-ordering" {= "guard"} + "oxcaml-patch-guards" {= "ox"} + "oxcaml-ppx_deriving" {= "guard"} + "oxcaml-ppxlib-patches" {= "enabled"} + "oxcaml-ppxlib_ast-patches" {= "enabled"} + "oxcaml-re-patches" {= "enabled"} + "oxcaml-sedlex" {= "guard"} + "oxcaml-sherlodoc" {= "guard"} + "oxcaml-spawn-patches" {= "enabled"} + "oxcaml-stdune" {= "guard"} + "oxcaml-top-closure" {= "guard"} + "oxcaml-topkg-patches" {= "enabled"} + "oxcaml-utop" {= "guard"} + "oxcaml-uutf-patches" {= "enabled"} + "oxcaml-wasm_of_ocaml-compiler" {= "guard"} + "oxcaml-xdg" {= "guard"} + "oxcaml-yojson" {= "guard"} + "oxcaml-zarith" {= "guard"} + "parsexp" {= "v0.18~preview.130.91+190"} + "pipe_with_writer_error" {= "v0.18~preview.130.91+190"} + "portable" {= "v0.18~preview.130.91+190"} + "ppx_array_base" {= "v0.18~preview.130.91+190"} + "ppx_assert" {= "v0.18~preview.130.91+190"} + "ppx_base" {= "v0.18~preview.130.91+190"} + "ppx_bench" {= "v0.18~preview.130.91+190"} + "ppx_bin_prot" {= "v0.18~preview.130.91+190"} + "ppx_box" {= "v0.18~preview.130.91+190"} + "ppx_builtin" {= "v0.18~preview.130.91+190"} + "ppx_cold" {= "v0.18~preview.130.91+190"} + "ppx_compare" {= "v0.18~preview.130.91+190"} + "ppx_custom_printf" {= "v0.18~preview.130.91+190"} + "ppx_debug_assert" {= "v0.18~preview.130.91+190"} "ppx_derivers" {= "1.2.1"} - "ppx_diff" {= "v0.18~preview.130.83+317"} - "ppx_disable_unused_warnings" {= "v0.18~preview.130.83+317"} - "ppx_enumerate" {= "v0.18~preview.130.83+317"} - "ppx_expect" {= "v0.18~preview.130.83+317"} - "ppx_fields_conv" {= "v0.18~preview.130.83+317"} - "ppx_fixed_literal" {= "v0.18~preview.130.83+317"} - "ppx_for_loop" {= "v0.18~preview.130.83+317"} - "ppx_fuelproof" {= "v0.18~preview.130.83+317"} - "ppx_globalize" {= "v0.18~preview.130.83+317"} - "ppx_hash" {= "v0.18~preview.130.83+317"} - "ppx_helpers" {= "v0.18~preview.130.83+317"} - "ppx_here" {= "v0.18~preview.130.83+317"} - "ppx_ignore_instrumentation" {= "v0.18~preview.130.83+317"} - "ppx_inline_test" {= "v0.18~preview.130.83+317"} - "ppx_int63_literal" {= "v0.18~preview.130.83+317"} - "ppx_jane" {= "v0.18~preview.130.83+317"} - "ppx_js_style" {= "v0.18~preview.130.83+317"} - "ppx_let" {= "v0.18~preview.130.83+317"} - "ppx_log" {= "v0.18~preview.130.83+317"} - "ppx_module_timer" {= "v0.18~preview.130.83+317"} - "ppx_optcomp" {= "v0.18~preview.130.83+317"} - "ppx_optional" {= "v0.18~preview.130.83+317"} - "ppx_pipebang" {= "v0.18~preview.130.83+317"} - "ppx_portable" {= "v0.18~preview.130.83+317"} - "ppx_sexp_conv" {= "v0.18~preview.130.83+317"} - "ppx_sexp_message" {= "v0.18~preview.130.83+317"} - "ppx_sexp_value" {= "v0.18~preview.130.83+317"} - "ppx_shorthand" {= "v0.18~preview.130.83+317"} - "ppx_stable" {= "v0.18~preview.130.83+317"} - "ppx_stable_witness" {= "v0.18~preview.130.83+317"} - "ppx_string" {= "v0.18~preview.130.83+317"} - "ppx_string_conv" {= "v0.18~preview.130.83+317"} - "ppx_template" {= "v0.18~preview.130.83+317"} - "ppx_tydi" {= "v0.18~preview.130.83+317"} - "ppx_typed_fields" {= "v0.18~preview.130.83+317"} - "ppx_typerep_conv" {= "v0.18~preview.130.83+317"} - "ppx_var_name" {= "v0.18~preview.130.83+317"} - "ppx_variants_conv" {= "v0.18~preview.130.83+317"} - "ppxlib" {= "0.33.0+ox"} - "ppxlib_ast" {= "0.33.0+ox"} - "ppxlib_jane" {= "v0.18~preview.130.83+317"} - "protocol_version_header" {= "v0.18~preview.130.83+317"} + "ppx_diff" {= "v0.18~preview.130.91+190"} + "ppx_disable_unused_warnings" {= "v0.18~preview.130.91+190"} + "ppx_enumerate" {= "v0.18~preview.130.91+190"} + "ppx_expect" {= "v0.18~preview.130.91+190"} + "ppx_fields_conv" {= "v0.18~preview.130.91+190"} + "ppx_fixed_literal" {= "v0.18~preview.130.91+190"} + "ppx_for_loop" {= "v0.18~preview.130.91+190"} + "ppx_fuelproof" {= "v0.18~preview.130.91+190"} + "ppx_globalize" {= "v0.18~preview.130.91+190"} + "ppx_hash" {= "v0.18~preview.130.91+190"} + "ppx_helpers" {= "v0.18~preview.130.91+190"} + "ppx_here" {= "v0.18~preview.130.91+190"} + "ppx_ignore_instrumentation" {= "v0.18~preview.130.91+190"} + "ppx_inline_test" {= "v0.18~preview.130.91+190"} + "ppx_int63_literal" {= "v0.18~preview.130.91+190"} + "ppx_jane" {= "v0.18~preview.130.91+190"} + "ppx_js_style" {= "v0.18~preview.130.91+190"} + "ppx_let" {= "v0.18~preview.130.91+190"} + "ppx_log" {= "v0.18~preview.130.91+190"} + "ppx_module_timer" {= "v0.18~preview.130.91+190"} + "ppx_optcomp" {= "v0.18~preview.130.91+190"} + "ppx_optional" {= "v0.18~preview.130.91+190"} + "ppx_pipebang" {= "v0.18~preview.130.91+190"} + "ppx_portable" {= "v0.18~preview.130.91+190"} + "ppx_sexp_conv" {= "v0.18~preview.130.91+190"} + "ppx_sexp_message" {= "v0.18~preview.130.91+190"} + "ppx_sexp_value" {= "v0.18~preview.130.91+190"} + "ppx_shorthand" {= "v0.18~preview.130.91+190"} + "ppx_stable" {= "v0.18~preview.130.91+190"} + "ppx_stable_witness" {= "v0.18~preview.130.91+190"} + "ppx_string" {= "v0.18~preview.130.91+190"} + "ppx_string_conv" {= "v0.18~preview.130.91+190"} + "ppx_template" {= "v0.18~preview.130.91+190"} + "ppx_tydi" {= "v0.18~preview.130.91+190"} + "ppx_typed_fields" {= "v0.18~preview.130.91+190"} + "ppx_typerep_conv" {= "v0.18~preview.130.91+190"} + "ppx_var_name" {= "v0.18~preview.130.91+190"} + "ppx_variants_conv" {= "v0.18~preview.130.91+190"} + "ppxlib" {= "0.33.0+ox1"} + "ppxlib_ast" {= "0.33.0+ox1"} + "ppxlib_jane" {= "v0.18~preview.130.91+190"} + "protocol_version_header" {= "v0.18~preview.130.91+190"} "ptime" {= "1.2.0"} "re" {= "1.14.0+ox"} - "record_builder" {= "v0.18~preview.130.83+317"} + "record_builder" {= "v0.18~preview.130.91+190"} "result" {= "1.5"} "seq" {= "base"} - "sexp_pretty" {= "v0.18~preview.130.83+317"} - "sexp_type" {= "v0.18~preview.130.83+317"} - "sexplib" {= "v0.18~preview.130.83+317"} - "sexplib0" {= "v0.18~preview.130.83+317"} - "shell" {= "v0.18~preview.130.83+317"} + "sexp_pretty" {= "v0.18~preview.130.91+190"} + "sexp_type" {= "v0.18~preview.130.91+190"} + "sexplib" {= "v0.18~preview.130.91+190"} + "sexplib0" {= "v0.18~preview.130.91+190"} + "shell" {= "v0.18~preview.130.91+190"} "spawn" {= "v0.15.1+ox"} - "splittable_random" {= "v0.18~preview.130.83+317"} - "stdio" {= "v0.18~preview.130.83+317"} + "splittable_random" {= "v0.18~preview.130.91+190"} + "stdio" {= "v0.18~preview.130.91+190"} "stdlib-shims" {= "0.3.0"} - "string_dict" {= "v0.18~preview.130.83+317"} + "string_dict" {= "v0.18~preview.130.91+190"} "stringext" {= "1.6.0"} - "textutils" {= "v0.18~preview.130.83+317"} - "time_now" {= "v0.18~preview.130.83+317"} - "topkg" {= "1.0.8+ox"} - "typerep" {= "v0.18~preview.130.83+317"} - "unboxed" {= "v0.18~preview.130.83+317"} - "unique" {= "v0.18~preview.130.83+317"} - "univ_map" {= "v0.18~preview.130.83+317"} - "uopt" {= "v0.18~preview.130.83+317"} + "textutils" {= "v0.18~preview.130.91+190"} + "time_now" {= "v0.18~preview.130.91+190"} + "topkg" {= "1.1.1+ox"} + "typerep" {= "v0.18~preview.130.91+190"} + "unboxed" {= "v0.18~preview.130.91+190"} + "unique" {= "v0.18~preview.130.91+190"} + "univ_map" {= "v0.18~preview.130.91+190"} + "uopt" {= "v0.18~preview.130.91+190"} "uri" {= "4.4.0"} "uri-sexp" {= "4.4.0"} - "uucp" {= "16.0.0" & with-test} - "uuseg" {= "16.0.0" & with-test} - "uutf" {= "1.0.3+ox"} - "variantslib" {= "v0.18~preview.130.83+317"} - "vec" {= "v0.18~preview.130.83+317"} - "zstandard" {= "v0.18~preview.130.83+317"} + "uucp" {= "17.0.0"} + "uuseg" {= "17.0.0"} + "uutf" {= "1.0.4+ox"} + "variantslib" {= "v0.18~preview.130.91+190"} + "vec" {= "v0.18~preview.130.91+190"} + "zstandard" {= "v0.18~preview.130.91+190"} ] build: ["dune" "build" "-p" name "-j" jobs] dev-repo: "git+https://github.com/janestreet/magic-trace.git" -pin-depends: [ - "dune.3.21.1" - "https://github.com/ocaml/dune/releases/download/3.21.1/dune-3.21.1.tbz" -] diff --git a/src/dune b/src/dune index fb96d1dc1..ee9979877 100644 --- a/src/dune +++ b/src/dune @@ -9,15 +9,45 @@ (run %{bin:gcc} -shared -o dlfilter/perf_dlfilter.so perf_dlfilter.o) (run %{bin:ocaml-crunch} -m plain dlfilter -o perf_dlfilter.ml)))) +(rule + (target libLLVM.a) + (deps llvm_symbolizer_stubs.cpp) + (action + (progn + (bash + "clang++ -std=c++20 -Wall -Wextra -Werror -Wno-unused-parameter -DCAML_NAME_SPACE -I %{ocaml_where} $(llvm-config --cxxflags) -O3 -march=broadwell -mtune=skylake -ffunction-sections -c llvm_symbolizer_stubs.cpp") + (bash + "ld.lld --gc-sections -static -r -plugin-opt=mcpu=broadwell -plugin-opt=O3 --hash-style=gnu --build-id --start-lib $(llvm-config --link-static --libfiles Symbolize) --end-lib llvm_symbolizer_stubs.o -o libLLVM.o") + (run llvm-strip --strip-debug libLLVM.o) + (run llvm-ar Drcs %{target} libLLVM.o)))) + (library (name magic_trace_lib) (public_name magic-trace.magic_trace_lib) + (no_dynlink) + (flags + (:standard -cclib -lstdc++)) + (foreign_archives LLVM) (foreign_stubs (language c) (names breakpoint_stubs boot_time_stubs ptrace_stubs)) - (libraries core async core_unix.filename_unix fzf re shell - core_unix.sys_unix cohttp cohttp_static_handler core_unix.signal_unix - tracing magic_trace owee angstrom expect_test_helpers_core vec) + (libraries + core + async + core_unix.filename_unix + fzf + re + shell + core_unix.sys_unix + cohttp + cohttp_static_handler + core_unix.signal_unix + tracing + magic_trace + owee + angstrom + expect_test_helpers_core + vec) (inline_tests) (preprocess (pps ppx_jane))) diff --git a/src/env_vars.ml b/src/env_vars.ml index 49ca69d6f..e87055b7e 100644 --- a/src/env_vars.ml +++ b/src/env_vars.ml @@ -57,3 +57,4 @@ let skip_transaction_handling = (* Use [New_trace_writer] instead of [Trace_writer]. *) let use_new_trace_writer = Option.is_some (Unix.getenv "MAGIC_TRACE_USE_NEW_TRACE_WRITER") +let check_invariants = Option.is_some (Unix.getenv "MAGIC_TRACE_CHECK_INVARIANTS") diff --git a/src/env_vars.mli b/src/env_vars.mli index ff1020ba8..2df1e1213 100644 --- a/src/env_vars.mli +++ b/src/env_vars.mli @@ -13,3 +13,4 @@ val fzf_demangle_symbols : bool val no_ocaml_exception_debug_info : bool val skip_transaction_handling : bool val use_new_trace_writer : bool +val check_invariants : bool diff --git a/src/event.ml b/src/event.ml index 24694485c..67697a11a 100644 --- a/src/event.ml +++ b/src/event.ml @@ -25,29 +25,39 @@ end module Location = struct type t = - { instruction_pointer : Int64.Hex.t + { (* TODO Use [i64] everywhere. *) + instruction_pointer : Int64.Hex.t ; symbol : Symbol.t ; symbol_offset : Int.Hex.t + ; dso : Interned_string.t } [@@deriving sexp, fields, bin_io] module Ignore_symbol = struct (* Ignoring symbol strings when serializing to save space. This reduces the size of events file by ~50% based on small tests. The symbol information is still available implicitly by looking at the top - of the callstack that optionally is exported together with the events. Symbol offset will be missing.*) + of the callstack that optionally is exported together with the events. Symbol offset will be missing. *) type nonrec t = t let to_sexpable { instruction_pointer; _ } = instruction_pointer let of_sexpable instruction_pointer = - { instruction_pointer; symbol = Symbol.Unknown; symbol_offset = 0 } + { instruction_pointer + ; symbol = Symbol.Unknown + ; symbol_offset = 0 + ; dso = Interned_string.empty + } ;; let to_binable { instruction_pointer; _ } = instruction_pointer let of_binable instruction_pointer = - { instruction_pointer; symbol = Symbol.Unknown; symbol_offset = 0 } + { instruction_pointer + ; symbol = Symbol.Unknown + ; symbol_offset = 0 + ; dso = Interned_string.empty + } ;; let caller_identity = @@ -60,7 +70,10 @@ module Location = struct (* magic-trace has some things that aren't functions but look like they are in the trace (like "[untraced]" and "[syscall]") *) - let locationless symbol = { instruction_pointer = 0L; symbol; symbol_offset = 0 } + let locationless symbol = + { instruction_pointer = 0L; symbol; symbol_offset = 0; dso = Interned_string.empty } + ;; + let unknown = locationless Unknown let untraced = locationless Untraced let returned = locationless Returned diff --git a/src/event.mli b/src/event.mli index 929854d07..0ba93f72b 100644 --- a/src/event.mli +++ b/src/event.mli @@ -28,6 +28,7 @@ module Location : sig { instruction_pointer : int64 ; symbol : Symbol.t ; symbol_offset : int + ; dso : Interned_string.t } [@@deriving sexp, fields, bin_io] diff --git a/src/interned_string.ml b/src/interned_string.ml new file mode 100644 index 000000000..4bb8b33b1 --- /dev/null +++ b/src/interned_string.ml @@ -0,0 +1,23 @@ +open! Core + +type t = string [@@deriving sexp_of] + +let equal = phys_equal +let compare t1 t2 = Int.compare (Obj.magic t1) (Obj.magic t2) +let hash t = Int.hash (Obj.magic t) +let hash_fold_t hash_state t = Int.hash_fold_t hash_state (Obj.magic t) +let empty = "" +let cache = String.Hash_set.of_list [ empty ] +let intern t = Hash_set.get_or_add cache t + +let t_of_sexp = function + | Sexp.Atom string -> intern string + | _ -> assert false +;; + +let of_string = intern +let to_string t = t +let uuid = "6c0bf9f4-3378-11f1-ae24-c84bd6ab9c33" +let caller_identity = Bin_prot.Shape.Uuid.of_string uuid + +include functor Binable.Of_stringable_with_uuid diff --git a/src/interned_string.mli b/src/interned_string.mli new file mode 100644 index 000000000..3f04df3ff --- /dev/null +++ b/src/interned_string.mli @@ -0,0 +1,6 @@ +open! Core + +type t = private string [@@deriving equal, hash, compare, sexp, bin_io] + +val intern : string -> t +val empty : t diff --git a/src/llvm_symbolizer_stubs.cpp b/src/llvm_symbolizer_stubs.cpp new file mode 100644 index 000000000..d98942933 --- /dev/null +++ b/src/llvm_symbolizer_stubs.cpp @@ -0,0 +1,62 @@ +#include +#include + +#include "caml/alloc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "llvm/DebugInfo/Symbolize/Symbolize.h" + +namespace { +value ocaml_string_of_cpp_string(std::string_view string) { + return caml_alloc_initialized_string(string.length(), string.data()); +} +} // namespace + +extern "C" { +CAMLprim llvm::symbolize::LLVMSymbolizer *__attribute__((used, retain)) +magic_trace_llvm_symbolizer_create() { + llvm::symbolize::LLVMSymbolizer::Options options{}; + // We need this for now to work around the fact the OCaml compiler inverts + // `DW_AT_name` and `DW_AT_linkage_name`, which breaks LLVM's assumptions when + // it tries to use the symbol table. + options.UseSymbolTable = false; + return new llvm::symbolize::LLVMSymbolizer(options); +} + +CAMLprim void __attribute__((used, retain)) +magic_trace_llvm_symbolizer_destroy(llvm::symbolize::LLVMSymbolizer *symbolizer) { + delete symbolizer; +} + +CAMLprim value __attribute__((used, retain)) +magic_trace_llvm_symbolize_address(llvm::symbolize::LLVMSymbolizer *symbolizer, + value v_executable_file, uintptr_t address) { + CAMLparam1(v_executable_file); + CAMLlocal2(inlined_frames, demangled_name); + std::string_view executable_file{String_val(v_executable_file), + caml_string_length(v_executable_file)}; + llvm::object::SectionedAddress sectioned_address{ + address, llvm::object::SectionedAddress::UndefSection}; + auto result = symbolizer->symbolizeInlinedCode(executable_file, sectioned_address); + if (auto _ = result.takeError()) { + CAMLreturn((value)NULL); + } + const auto &frames = result.get(); + const uint32_t num_frames = frames.getNumberOfFrames(); + if (num_frames == 0) { + CAMLreturn((value)NULL); + } + if (num_frames <= Max_young_wosize) [[likely]] { + inlined_frames = caml_alloc_small(/*wosize=*/num_frames, /*tag=*/0); + } else { + inlined_frames = caml_alloc_shr(/*wosize=*/num_frames, /*tag=*/0); + } + memset((uint8_t *)inlined_frames, 0xFF, Bsize_wsize(num_frames)); + for (uint32_t i = 0; i < num_frames; i++) { + const auto &frame = frames.getFrame(i); + demangled_name = ocaml_string_of_cpp_string(frame.FunctionName); + caml_modify(&Field(inlined_frames, num_frames - 1 - i), demangled_name); + } + CAMLreturn(inlined_frames); +} +} diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index a2216f7d9..f5e05afe2 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -1,5 +1,5 @@ open! Core -module Nonempty_vec = Nonempty_vec.Value +module Nonempty_vec = Nonempty_vec.Valuex2 let debug = ref false let is_kernel_address addr = Int64.(addr < 0L) @@ -53,7 +53,9 @@ module Pending_event = struct [@@deriving sexp] let create_call location ~from_untraced = - let { Event.Location.instruction_pointer; symbol; symbol_offset } = location in + let { Event.Location.instruction_pointer; symbol; symbol_offset; dso = _ } = + location + in { symbol ; kind = Call { addr = instruction_pointer; offset = symbol_offset; from_untraced } } @@ -119,7 +121,8 @@ module Thread_info = struct ; mutable last_event_time : Mapped_time.t ; track_group_id : int ; extra_event_tracks : ('thread[@sexp.opaque]) Hashtbl.M(Collection_mode.Event.Name).t - ; trace_segments : (Trace_segment.t Nonempty_vec.t[@sexp.opaque]) + ; trace_segments : + (#(Trace_segment.t * in_filtered_region:bool) Nonempty_vec.t[@sexp.opaque]) } [@@deriving sexp_of] @@ -129,10 +132,8 @@ module Thread_info = struct ;; let add_event_to_trace_segment t event_data time = - Trace_segment.add_event - (Nonempty_vec.last t.trace_segments) - event_data - (Timestamp.create time) + let #(trace_segment, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in + Trace_segment.add_event trace_segment event_data (Timestamp.create time) ;; module New_trace_segment_kind = struct @@ -150,12 +151,12 @@ module Thread_info = struct | Without_exception_info _ -> None | With_exception_info { ocaml_exception_info; _ } -> Some ocaml_exception_info in - Trace_segment.create ocaml_exception_info ~in_filtered_region + Trace_segment.create ocaml_exception_info | Continuing_from_current -> - let current = Nonempty_vec.last t.trace_segments in - Trace_segment.create_continuing_from current ~in_filtered_region + let #(current, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in + Trace_segment.create_continuing_from current in - Nonempty_vec.push_back t.trace_segments new_trace_segment + Nonempty_vec.push_back t.trace_segments #(new_trace_segment, ~in_filtered_region) ;; end @@ -573,8 +574,9 @@ let create_thread t event = ; track_group_id ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) ; trace_segments = - Trace_segment.create t.ocaml_exception_info ~in_filtered_region:t.in_filtered_region - |> Nonempty_vec.create + Nonempty_vec.create + #( Trace_segment.create t.ocaml_exception_info + , ~in_filtered_region:t.in_filtered_region ) } ;; @@ -705,16 +707,18 @@ let ret t (thread_info : _ Thread_info.t) ~time : unit = let write_trace_segments (type thread) (t : thread inner) = Hashtbl.iter t.thread_info ~f:(fun thread_info -> - Nonempty_vec.iter thread_info.trace_segments ~f:(fun trace_segment -> - if Trace_segment.in_filtered_region trace_segment - then - Trace_segment.write_trace - trace_segment - t.trace - thread_info.thread - t.debug_info - ~enter_initial_callstack:true - ~exit_final_callstack:true)) + Nonempty_vec.iter + thread_info.trace_segments + ~f:(fun #(trace_segment, ~in_filtered_region) -> + if in_filtered_region + then + Trace_segment.write_trace + trace_segment + t.trace + thread_info.thread + t.debug_info + ~enter_initial_callstack:true + ~exit_final_callstack:true)) ;; let end_of_trace ?to_time (T t) = diff --git a/src/nonempty_vec.ml b/src/nonempty_vec.ml index b9409e3d6..c3b7e1c34 100644 --- a/src/nonempty_vec.ml +++ b/src/nonempty_vec.ml @@ -1,6 +1,6 @@ open! Core -module%template [@kind k = (value, value & value & value)] T = struct +module%template [@kind k = (value, value & value, value & value & value)] T = struct type ('a : k) t = ('a Vec.t[@kind k]) let create x = @@ -29,4 +29,5 @@ module%template [@kind k = (value, value & value & value)] T = struct end module Value = T [@kind value] +module Valuex2 = T [@kind value & value] module Valuex3 = T [@kind value & value & value] diff --git a/src/nonempty_vec.mli b/src/nonempty_vec.mli index ddb5e020b..e3b2e7223 100644 --- a/src/nonempty_vec.mli +++ b/src/nonempty_vec.mli @@ -1,6 +1,6 @@ open! Core -module type%template [@kind k = (value, value & value & value)] S := sig +module type%template [@kind k = (value, value & value, value & value & value)] S := sig (** A [Vec.t] guaranteed to contain at least one element. *) type ('a : k) t @@ -16,4 +16,5 @@ module type%template [@kind k = (value, value & value & value)] S := sig end module Value : S [@kind value] +module Valuex2 : S [@kind value & value] module Valuex3 : S [@kind value & value & value] diff --git a/src/perf_decode.ml b/src/perf_decode.ml index 433932039..1e4335c3b 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -21,7 +21,7 @@ let perf_callstack_entry_re = Re.Perl.re "^\t *([0-9a-f]+) (.*)$" |> Re.compile let perf_branches_event_re = Re.Perl.re - {|^ *(call|return|tr strt(?: jmp)?|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc) +(\(x\) +)?([0-9a-f]+) (.*) => +([0-9a-f]+) (.*)$|} + {|^ *(call|return|tr strt(?: jmp)?|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret|int)|jmp|jcc) +(\(x\) +)?([0-9a-f]+) (.*) => +([0-9a-f]+) (.*)$|} |> Re.compile ;; @@ -35,7 +35,10 @@ let trace_error_re = |> Re.compile ;; -let symbol_and_offset_re = Re.Perl.re {|^(.*)\+(0x[0-9a-f]+)\s+\(.*\)$|} |> Re.compile +let symbol_and_offset_and_dso_re = + Re.Perl.re {|^(.*)\+(0x[0-9a-f]+)\s+\((.*)\)$|} |> Re.compile +;; + let unknown_symbol_dso_re = Re.Perl.re {|^\[unknown\]\s+\((.*)\)|} |> Re.compile type header = @@ -109,9 +112,12 @@ let parse_event_header line = "Regex of perf output did not match expected fields" (results : string array)]) ;; -let parse_symbol_and_offset ?perf_maps pid str ~addr : Symbol.t * int = - match Re.Group.all (Re.exec symbol_and_offset_re str) with - | [| _; symbol; offset |] -> +let parse_symbol_and_offset_and_dso ?perf_maps pid str ~addr + : Symbol.t * int * Interned_string.t + = + match Re.Group.all (Re.exec symbol_and_offset_and_dso_re str) with + | [| _; symbol; offset; dso |] -> + let dso = Interned_string.intern dso in let offset = (* Sometimes [perf] reports symbols and offsets like [memcpy@plt+0xffffffffff22f000], which are definitely wrong (the implied @@ -124,16 +130,18 @@ let parse_symbol_and_offset ?perf_maps pid str ~addr : Symbol.t * int = avoid the extra allocation. *) Util.int_trunc_of_hex_string ~remove_hex_prefix:true offset in - From_perf symbol, offset + From_perf symbol, offset, dso | _ | (exception _) -> - let failed = Symbol.Unknown, 0 in + let failed = Symbol.Unknown, 0, Interned_string.empty in (match perf_maps, pid with | None, _ | _, None -> (match Re.Group.all (Re.exec unknown_symbol_dso_re str) with | [| _; dso |] -> (* CR-someday tbrindus: ideally, we would subtract the DSO base offset from [offset] here. *) - From_perf [%string "[unknown @ %{addr#Int64.Hex} (%{dso})]"], 0 + ( From_perf [%string "[unknown @ %{addr#Int64.Hex} (%{dso})]"] + , 0 + , Interned_string.intern dso ) | _ | (exception _) -> failed) | Some perf_map, Some pid -> (match Perf_map.Table.symbol ~pid perf_map ~addr with @@ -142,7 +150,7 @@ let parse_symbol_and_offset ?perf_maps pid str ~addr : Symbol.t * int = (* It's strange that perf isn't resolving these symbols. It says on the tin that it supports perf map files! *) let offset = saturating_sub_i64 addr location.start_addr in - From_perf_map location, offset)) + From_perf_map location, offset, Interned_string.empty)) ;; let trace_error_to_event line : Event.Decode_error.t = @@ -182,10 +190,14 @@ let parse_location ?perf_maps ~pid instruction_pointer symbol_and_offset : Event.Location.t = let instruction_pointer = Util.int64_of_hex_string instruction_pointer in - let symbol, symbol_offset = - parse_symbol_and_offset ?perf_maps pid symbol_and_offset ~addr:instruction_pointer + let symbol, symbol_offset, dso = + parse_symbol_and_offset_and_dso + ?perf_maps + pid + symbol_and_offset + ~addr:instruction_pointer in - { instruction_pointer; symbol; symbol_offset } + { instruction_pointer; symbol; symbol_offset; dso } ;; let parse_callstack_entry ?perf_maps (thread : Event.Thread.t) line : Event.Location.t = @@ -218,15 +230,15 @@ let parse_perf_branches_event ?perf_maps (thread : Event.Thread.t) time line : E |] -> let src_instruction_pointer = Util.int64_of_hex_string src_instruction_pointer in let dst_instruction_pointer = Util.int64_of_hex_string dst_instruction_pointer in - let src_symbol, src_symbol_offset = - parse_symbol_and_offset + let src_symbol, src_symbol_offset, src_dso = + parse_symbol_and_offset_and_dso ?perf_maps thread.pid src_symbol_and_offset ~addr:src_instruction_pointer in - let dst_symbol, dst_symbol_offset = - parse_symbol_and_offset + let dst_symbol, dst_symbol_offset, dst_dso = + parse_symbol_and_offset_and_dso ?perf_maps thread.pid dst_symbol_and_offset @@ -290,11 +302,13 @@ let parse_perf_branches_event ?perf_maps (thread : Event.Thread.t) time line : E { instruction_pointer = src_instruction_pointer ; symbol = src_symbol ; symbol_offset = src_symbol_offset + ; dso = src_dso } ; dst = { instruction_pointer = dst_instruction_pointer ; symbol = dst_symbol ; symbol_offset = dst_symbol_offset + ; dso = dst_dso } } ; in_transaction diff --git a/src/slice.ml b/src/slice.ml new file mode 100644 index 000000000..a5653900e --- /dev/null +++ b/src/slice.ml @@ -0,0 +1,36 @@ +open! Core + +type ('a : value mod non_float) t = + #{ len : int + ; pos : int + ; data : 'a iarray + } + +let empty = #{ len = 0; pos = 0; data = [::] } + +let create ~pos ~len data = + assert (pos >= 0 && len >= 0 && pos + len <= Iarray.length data); + #{ len; pos; data } +;; + +let[@inline always] length t = t.#len +let[@inline always] unsafe_get t i = Iarray.unsafe_get t.#data (t.#pos + i) + +let get t i = + assert (i >= 0 && i < t.#len); + unsafe_get t i +;; + +let iter t ~f = + for i = 0 to t.#len - 1 do + f (unsafe_get t i) + done +;; + +let map_to_list t ~f = + let list = ref [] in + for i = 0 to t.#len - 1 do + list := f (unsafe_get t i) :: !list + done; + List.rev !list +;; diff --git a/src/slice.mli b/src/slice.mli new file mode 100644 index 000000000..871372538 --- /dev/null +++ b/src/slice.mli @@ -0,0 +1,11 @@ +open! Core + +type (+'a : value mod non_float) t : immediate & immediate & value + +val empty : 'a t +val create : ('a : value mod non_float). pos:int -> len:int -> 'a iarray -> 'a t +val length : ('a : value mod non_float). 'a t -> int +val unsafe_get : ('a : value mod non_float). 'a t -> int -> 'a +val get : ('a : value mod non_float). 'a t -> int -> 'a +val iter : ('a : value mod non_float). 'a t -> f:('a -> unit) @ local -> unit +val map_to_list : ('a : value mod non_float). 'a t -> f:('a -> 'b) @ local -> 'b list diff --git a/src/symbolizer.ml b/src/symbolizer.ml new file mode 100644 index 000000000..cb6846b1b --- /dev/null +++ b/src/symbolizer.ml @@ -0,0 +1,103 @@ +open! Core +open Unboxed + +(* TODO Nearly everything about the way this module is implemented is slow, and adds + measurable overhead. We should do something less naive here. *) + +module Request = struct + type t = + { addr : I64.t + ; executable : Interned_string.t + } + [@@deriving compare, sexp_of, hash] +end + +module Info = struct + type t = { demangled_name : string } + [@@unboxed] [@@deriving equal, compare, hash, sexp_of] + + let display_name { demangled_name } = demangled_name ^ " (inlined)" + + let to_location t : Event.Location.t = + (* TODO Creating dummy locations for inlined frames like this is gross, but + with inlined frames our traces are already so large we can't really + afford to add more information until we optimize for trace size, and + not all of these have valid values anyway (e.g. [symbol_offset] for + an inlined function call is meaningless). *) + { symbol = From_perf (display_name t) + ; symbol_offset = 0 + ; instruction_pointer = 0L + ; dso = Interned_string.empty + } + ;; +end + +module Response = struct + (** This is ordered root-to-leaf such that the entry at index 0 is the physical frame, + and the subsequent entries are the inlined frames. *) + type t = Info.t iarray [@@deriving sexp_of, equal, hash, compare] + + let physical_frame t = Iarray.unsafe_get t 0 + let inlined_frames t = Slice.create t ~pos:1 ~len:(Iarray.length t - 1) +end + +module Llvm_symbolizer = struct + type t = Iptr.t + + external create + : unit + -> t + = "caml_no_bytecode_impl" "magic_trace_llvm_symbolizer_create" + [@@noalloc] + + external destroy + : t + -> unit + = "caml_no_bytecode_impl" "magic_trace_llvm_symbolizer_destroy" + [@@noalloc] + + external symbolize + : t + -> executable:Interned_string.t + -> addr:i64 + -> Response.t or_null + = "caml_no_bytecode_impl" "magic_trace_llvm_symbolize_address" +end + +type t = + { symbolization_cache : (Request.t, Response.t Uopt.t) Hashtbl.t + ; response_cache : Response.t Hash_set.t + ; llvm_symbolizer : Llvm_symbolizer.t + } + +let finalize (t : t) = Llvm_symbolizer.destroy t.llvm_symbolizer + +let create () = + let t = + { symbolization_cache = Hashtbl.create (module Request) + ; response_cache = Hash_set.create (module Response) + ; llvm_symbolizer = Llvm_symbolizer.create () + } + in + Gc.Expert.add_finalizer_exn t finalize; + t +;; + +let symbolize t ~executable ~addr = + let addr = I64.of_int64 addr in + (* LLVM can't symbolize things in the Kernel; checking for this explicitly + avoids us polluting our cache with many [Null] responses. *) + if I64.O.(addr <= #0L) + then Null + else ( + let result = + Hashtbl.find_or_add + t.symbolization_cache + { addr; executable } + ~default:(stack_ fun () -> + match Llvm_symbolizer.symbolize t.llvm_symbolizer ~executable ~addr with + | Null -> Uopt.none + | This response -> Uopt.some (Hash_set.get_or_add t.response_cache response)) + in + Bool.select (Uopt.is_some result) (This (Uopt.unsafe_value result)) Null) +;; diff --git a/src/symbolizer.mli b/src/symbolizer.mli new file mode 100644 index 000000000..e003b5ad9 --- /dev/null +++ b/src/symbolizer.mli @@ -0,0 +1,57 @@ +open! Core + +module Info : sig + type t = private { demangled_name : string } + [@@unboxed] [@@deriving equal, compare, hash, sexp_of] + + val display_name : t -> string + + (** This is currently a gross hack, to be used solely for inlined frames. *) + val to_location : t -> Event.Location.t +end + +module Response : sig + type t [@@deriving sexp_of] + + val physical_frame : t -> Info.t + + (*= [inlined_frames] is ordered root-to-leaf, such that the "root" is at index 0, + and "leaf" is at index [length - 1]. [inlined_frames] does *not* contain the + enclosing physical (i.e. non-inlined) frame. + + For example, if you had the following pseudocode: + + ``` + function baz(x) { + return x * 5; + } + + function bar(x) { + return baz(x) / 3; + } + + function foo(x) { + return bar(x) + 27; + } + ``` + + If the calls to [bar] and [baz] are both inlined, and you called [symbolize] on an address within [foo], + the [inlined_frames] you would receive would be: + ``` + [: "bar"; "baz" :] + ``` + (but with [Info.t] objects instead of the simple strings I've shown for the sake of explanation). + *) + val inlined_frames : t -> Info.t Slice.t +end + +type t + +val create : unit -> t + +(** Symbolizes the given address. Returns [Null] if the address is unrecognized. *) +val symbolize + : t + -> executable:Interned_string.t + -> addr:Int64.t @ local + -> Response.t or_null diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 7ba06d269..7ab12ff08 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -1,34 +1,107 @@ open! Core +open Unboxed module Location = Event.Location module Nonempty_vec = Nonempty_vec.Valuex3 let debug = false module Frame : sig - (* These fields are actually **immutable** except for [Sentinel.t] instances. *) + module Kind : sig + type t = + | Physical + (** A physical stack frame, attributable directly to information given to us by + [perf] in an [Event.t]. *) + | Inlined (** An inlined function call, known to us solely via debug-info. *) + end + + (* The [location], [parent], and [kind] fields are actually **immutable** except for on [Sentinel.t] instances. *) type t = private { mutable location : Event.Location.t - ; mutable parent : t Or_null.t + ; mutable parent : t or_null + ; mutable kind : Kind.t + ; (* TODO Make this an [i64] *) + mutable instruction_pointer : int64 } - val create : Location.t -> parent:t -> t - - (** Find the first frame whose [location.symbol] matches the provided argument. - - Returns the matching frame (if found), and that frame's distance from the initial - frame (e.g. a call to [find my_frame my_symbol] with a return value of - [#(This _, ~distance:0)] indicates that [my_frame.location.symbol] is [my_symbol]). *) - val find : t -> Symbol.t -> #(t Or_null.t * distance:int) + val create : Location.t -> parent:t -> kind:Kind.t -> t + val set_instruction_pointer : t -> int64 -> unit + + (** Find the first [Physical] frame whose [location.symbol] matches the provided + argument. + + Returns the matching frame (if found) along with: + - [distance]: the number of frames between the frame provided as an argument, and + the returned frame (e.g. a call to [find my_frame my_symbol] with a return value + of [#(This _, ~distance:0, ..)] indicates that [my_frame.location.symbol] is + [my_symbol]). + - [physical_distance]: like [distance] but only counting [kind = Physical] frames. + - [leaf_of_inlined_stack]: the leaf of the stack of [kind = Inlined] frames attached + to the returned frame (which is always physical), along with its distance from the + frame provided as an argument. *) + val find + : t + -> Symbol.t + -> #(t or_null + * distance:int + * physical_distance:int + * leaf_of_inlined_stack:#(t or_null * int)) (** Iterate from leaf-to-root up to the given number of frames, or until encountering - the [Sentinel.t] *) + the [Sentinel.t]. *) val iter_n : t -> int -> f:local_ (t -> unit) -> unit - (** Iterate the entire callstack from root-to-leaf. Note that this is *not* - tail-recursive, given that frames form a singly-linked list from leaf-to-root. *) - val iter_rev : t -> f:local_ (t -> unit) -> unit - - val find_ancestor : t -> ancestor:t -> int Or_null.t + (** Like [iter_n], this iterates from **leaf-to-root**. The "rev" here signifies that + the callback [f] is invoked in the reverse order of iteration (i.e. root-to-leaf). + Note that this is *not* tail-recursive, given that frames form a singly-linked list + from leaf-to-root. *) + val iter_n_rev : t -> int -> f:local_ (t -> unit) -> unit + + (* If you're still confused between [iter_n] and [iter_n_rev], here's a small example: + + {v + ┌────────┬────────┐ + root: │ fn1 │ Null │ + └────────┴────────┘ + ▲ + │ + ┌────────┬────────┐ + │ fn2 │ │ + └────────┴────────┘ + ▲ + │ + ┌────────┬────────┐ + │ fn3 │ │ + └────────┴────────┘ + ▲ + │ + ┌────────┬────────┐ + │ fn4 │ │ + └────────┴────────┘ + ▲ + │ + ┌────────┬────────┐ + leaf: │ fn5 │ │ + └────────┴────────┘ + v} + + {[ + Frame.iter_n leaf 3 ~f:(fun frame -> printf "%s; " (Symbol.display_name frame.location.symbol)); + > fn5; fn4; fn3 + Frame.iter_n_rev leaf 3 ~f:(fun frame -> printf "%s; " (Symbol.display_name frame.location.symbol)); + > fn3; fn4; fn5 + ]} + *) + + val find_ancestor + : t + -> ancestor:t + -> #(distance:int or_null * leaf_of_inlined_stack:#(t or_null * int)) + + (** Unlike the other functions, this *can* return a [Sentinel.t]. This is probably a bad + idea. *) + val find_first_physical : t -> #(t * distance:int) + + val nth_ancestor_exn : t -> int -> t module Sentinel : sig type frame := t @@ -43,9 +116,8 @@ module Frame : sig val create : unit -> t - (** Mutate [t]'s contents to the provided [location] and [parent] and return [t] as a - [frame]. *) - val become_frame : t -> Location.t -> parent:frame -> frame + (** Mutate [t]'s fields to the provided arguments and return [t] as a [frame]. *) + val become_frame : t -> Location.t -> parent:frame -> kind:Kind.t -> frame end module For_testing : sig @@ -53,22 +125,61 @@ module Frame : sig val print_callstack : t -> unit end end = struct + module Kind = struct + type t = + | Physical + | Inlined + end + type t = { mutable location : Event.Location.t - ; mutable parent : t Or_null.t + ; mutable parent : t or_null + ; mutable kind : Kind.t + ; mutable instruction_pointer : int64 } - let[@inline always] create location ~parent = { location; parent = This parent } + let create location ~parent ~kind = + { location + ; parent = This parent + ; kind + ; instruction_pointer = location.instruction_pointer + } + ;; - let rec find t target distance = + let[@inline always] set_instruction_pointer t instruction_pointer = + t.instruction_pointer <- instruction_pointer + ;; + + let rec find t target ~distance ~physical_distance ~leaf_of_inlined_stack = match t with - | { parent = Null; _ } -> #(Null, ~distance) - | { location = { symbol; _ }; _ } when Symbol.equal symbol target -> - #(This t, ~distance) - | { parent = This parent; _ } -> find parent target (distance + 1) + | { parent = Null; _ } -> + #(Null, ~distance, ~physical_distance, ~leaf_of_inlined_stack) + | { kind = Physical; location = { symbol; _ }; _ } when Symbol.equal symbol target -> + #(This t, ~distance, ~physical_distance, ~leaf_of_inlined_stack) + | { parent = This parent; kind = Physical; _ } -> + find + parent + target + ~distance:(distance + 1) + ~physical_distance:(physical_distance + 1) + ~leaf_of_inlined_stack:#(Null, distance) + | { parent = This parent; kind = Inlined; _ } -> + let leaf_of_inlined_stack = + match leaf_of_inlined_stack with + | #(Null, _) -> #(This t, distance) + | leaf_of_inlined_stack -> leaf_of_inlined_stack + in + find + parent + target + ~distance:(distance + 1) + ~physical_distance + ~leaf_of_inlined_stack ;; - let find t target = find t target 0 + let find t target = + find t target ~distance:0 ~physical_distance:0 ~leaf_of_inlined_stack:#(Null, 0) + ;; let rec iter_n t n ~f = match t, n with @@ -78,37 +189,86 @@ end = struct iter_n parent (n - 1) ~f ;; - let rec iter_rev t ~f = - match t with - | { parent = Null; _ } -> () - | { parent = This parent; _ } -> - iter_rev parent ~f; + let rec iter_n_rev t n ~f = + match t, n with + | { parent = Null; _ }, _ | _, 0 -> () + | { parent = This parent; _ }, n -> + iter_n_rev parent (n - 1) ~f; f t ;; - let rec find_ancestor t ~ancestor distance = + let rec find_ancestor t ~ancestor ~distance ~leaf_of_inlined_stack = if phys_equal t ancestor - then This distance + then #(~distance:(This distance), ~leaf_of_inlined_stack) else ( match t with - | { parent = Null; _ } -> Null - | { parent = This parent; _ } -> find_ancestor parent ~ancestor (distance + 1)) + | { parent = Null; _ } -> #(~distance:Null, ~leaf_of_inlined_stack:#(Null, distance)) + | { parent = This parent; kind = Physical; _ } -> + find_ancestor + parent + ~ancestor + ~distance:(distance + 1) + ~leaf_of_inlined_stack:#(Null, distance) + | { parent = This parent; kind = Inlined; _ } -> + let leaf_of_inlined_stack = + match leaf_of_inlined_stack with + | #(Null, _) -> #(This t, distance) + | leaf_of_inlined_stack -> leaf_of_inlined_stack + in + find_ancestor parent ~ancestor ~distance:(distance + 1) ~leaf_of_inlined_stack) + ;; + + let find_ancestor t ~ancestor = + find_ancestor t ~ancestor ~distance:0 ~leaf_of_inlined_stack:#(Null, 0) ;; - let find_ancestor t ~ancestor = find_ancestor t ~ancestor 0 + let rec find_first_physical t ~distance = + match t with + | { kind = Physical; _ } -> #(t, ~distance) + | { parent = This parent; _ } -> find_first_physical parent ~distance:(distance + 1) + | { parent = Null; kind = Inlined; _ } -> + (* [Sentinel.t]s cannot have [kind = Inlined]. *) + assert false + ;; + + let find_first_physical t = find_first_physical t ~distance:0 + + let nth_ancestor_exn t n = + let mutable t = t in + for _ = 1 to n do + t <- Or_null.value_exn t.parent + done; + t + ;; module Sentinel = struct type nonrec t = t let sentinel_location : Location.t = - { instruction_pointer = 0L; symbol_offset = 0; symbol = From_perf "\x00" } + { instruction_pointer = 0L + ; symbol_offset = 0 + ; (* For the sake of being defensive, we define a special symbol for the sentinel which is *impossible* + to confuse with a real symbol, because ELF symbol names are NULL-terminated strings. + + See https://refspecs.linuxbase.org/elf/gabi4+/ch4.strtab.html *) + symbol = From_perf "\x00_" + ; dso = Interned_string.empty + } ;; - let[@inline always] create () = { location = sentinel_location; parent = Null } + let[@inline always] create () = + { location = sentinel_location + ; parent = Null + ; kind = Physical + ; instruction_pointer = 0L + } + ;; - let become_frame t location ~parent = + let become_frame t location ~parent ~kind = t.location <- location; t.parent <- This parent; + t.kind <- kind; + t.instruction_pointer <- location.instruction_pointer; t ;; end @@ -118,22 +278,33 @@ end = struct match t.parent with | Null -> acc | This parent -> - to_string_list (Symbol.display_name t.location.symbol :: acc) parent + let kind = + if not debug + then "" + else ( + match t.kind with + | Physical -> " PHYSICAL" + | Inlined -> " INLINED") + in + to_string_list + ([%string "%{Symbol.display_name t.location.symbol}%{kind}"] :: acc) + parent ;; let to_string_list t = to_string_list [] t - let print_callstack leaf = to_string_list leaf |> String.concat_lines |> print_endline + let print_callstack leaf = to_string_list leaf |> String.concat_lines |> printf "%s" end end module Control_flow = struct type t = - | Jump - | Call + | Call of { depth : int } + (** [depth] indicates how many new frames were introduced. *) | Return of { distance : int } (** [distance] indicates how many frames this return pops off of the callstack. [distance = 1] is the usual case of returning from the current frame to its parent. *) + [@@deriving sexp_of] end module Callstack = struct @@ -155,14 +326,13 @@ type t = the following invariants in order for [callstacks] to be correctly processed during [write_trace]: - 1. A callstack with [control_flow = Call] introduces **exactly** one new frame which - was not present in the callstack immediately preceding it. This new frame is its - [leaf]. + 1. A callstack with [control_flow = Call { depth }] introduces [depth] new frames + which were not present in the callstack immediately preceding it. These new + frames are the first [depth] frames starting from this callstack's [leaf]. 2. A callstack with [control_flow = Return { distance }] **exits** [distance] - frames, starting from the leaf of the callstack immediately preceding it. - 3. A callstack with [control_flow = Jump] exits the [leaf] of the callstack - immediately preceding it, and enters a new frame, which is its [leaf]. *) - ; ocaml_exception_info : Ocaml_exception_info.t Or_null.t + frames, starting from the [leaf] of the callstack immediately preceding it. *) + ; symbolizer : Symbolizer.t + ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an @@ -172,11 +342,10 @@ type t = later examination — [exception_handlers] represents the state **as of the event we are currently processing**, and as such is only used during the "ingestion" phase (i.e. while calls are still being made to [add_event]). *) - ; mutable last_known_instruction_pointer : int64 - ; in_filtered_region : bool + ; mutable last_known_location : Location.t } -let create ocaml_exception_info ~in_filtered_region = +let create ocaml_exception_info = let root = Frame.Sentinel.create () in { root ; last_event_time = Timestamp.zero @@ -187,59 +356,199 @@ let create ocaml_exception_info ~in_filtered_region = ; control_flow = Return { distance = 0 } } : Callstack.t) + ; symbolizer = Symbolizer.create () ; exception_handlers = Vec.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info - ; last_known_instruction_pointer = Int64.max_value - ; in_filtered_region + ; last_known_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; instruction_pointer = Int64.max_value + ; dso = Interned_string.empty + } } ;; -let create_continuing_from existing ~in_filtered_region = +let create_continuing_from existing = let last_callstack = Nonempty_vec.last existing.callstacks in { existing with callstacks = Nonempty_vec.create (#{ last_callstack with control_flow = Return { distance = 0 } } : Callstack.t) ; exception_handlers = Vec.copy existing.exception_handlers - ; in_filtered_region } ;; -let in_filtered_region t = t.in_filtered_region let[@inline always] current_frame t = (Nonempty_vec.last t.callstacks).#leaf +let[@inline always] current_physical_frame t = Frame.find_first_physical (current_frame t) -let replace_root t location = +let replace_root t location ~kind = let new_sentinel = Frame.Sentinel.create () in let root = - Frame.Sentinel.become_frame t.root location ~parent:(new_sentinel :> Frame.t) + Frame.Sentinel.become_frame t.root location ~parent:(new_sentinel :> Frame.t) ~kind in t.root <- new_sentinel; root ;; +let diff_inlined_frames' + (t : t) + time + ~dso:_ + ~(before : Symbolizer.Info.t Slice.t) + ~(after : Symbolizer.Info.t Slice.t) + = + let length = Int.min (Slice.length before) (Slice.length after) in + let mutable first_different_index = 0 in + while + first_different_index < length + && Symbolizer.Info.equal + (Slice.unsafe_get before first_different_index) + (Slice.unsafe_get after first_different_index) + do + first_different_index <- first_different_index + 1 + done; + let return_distance = Slice.length before - first_different_index in + if return_distance <> 0 + then + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = Frame.nth_ancestor_exn (current_frame t) return_distance + ; control_flow = Return { distance = return_distance } + }; + let mutable parent = current_frame t in + for i = first_different_index to Slice.length after - 1 do + let inlined_frame_info = Slice.unsafe_get after i in + let inlined_frame = + Frame.create (Symbolizer.Info.to_location inlined_frame_info) ~parent ~kind:Inlined + in + parent <- inlined_frame + done; + let frames_created = Slice.length after - first_different_index in + if frames_created > 0 + then + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = parent; control_flow = Call { depth = frames_created } } +;; + +let symbolize_inlined_frames t ~dso ~addr = + match Symbolizer.symbolize t.symbolizer ~executable:dso ~addr with + | Null -> Slice.empty + | This result -> Symbolizer.Response.inlined_frames result +;; + +let diff_inlined_frames (t : t) time ~dso ~(before : int64) ~(after : int64) = + if Env_vars.check_invariants + then ( + let #(current_physical_frame, ~distance:_) = current_physical_frame t in + [%test_eq: Interned_string.t] current_physical_frame.location.dso dso); + diff_inlined_frames' + t + time + ~dso + ~before:(symbolize_inlined_frames t ~dso ~addr:before) + ~after:(symbolize_inlined_frames t ~dso ~addr:after) +;; + +let append_inlined_frames t time ~(physical_frame : Frame.t) ~physical_frame_is_new = + assert (phys_equal physical_frame.kind Physical); + match + Symbolizer.symbolize + t.symbolizer + ~executable:physical_frame.location.dso + ~addr:physical_frame.instruction_pointer + with + | Null -> + if physical_frame_is_new + then + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = physical_frame; control_flow = Call { depth = 1 } } + | This response -> + let parent = stack_ (ref physical_frame) in + let inlined_frames = Symbolizer.Response.inlined_frames response in + Slice.iter inlined_frames ~f:(stack_ fun inlined_frame_info -> + let inlined_leaf_frame = + Frame.create + ~kind:Inlined + (Symbolizer.Info.to_location inlined_frame_info) + ~parent:!parent + in + parent := inlined_leaf_frame); + if physical_frame_is_new || Slice.length inlined_frames > 0 + then + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = !parent + ; control_flow = + Call + { depth = Bool.to_int physical_frame_is_new + Slice.length inlined_frames } + } +;; + +(** This is intended to mark code we hope is *unreachable*, not merely uncommon. Hopefully + over time we can strengthen its callsites to assertions. *) +let[@cold] log_unexpected_case ~(here : [%call_pos]) sexp = + eprintf + "Warning, unexpected case reached [%s:%d:%d]: %s\n" + here.pos_fname + here.pos_lnum + (here.pos_cnum - here.pos_bol) + (Sexp.to_string_mach sexp) +;; + (* [handle_call] uses [src], unlike the other event handlers. The rationale for this is that in the context of a call, [src] is the parent frame of the call to [dst] and thus *it continues to exist*. We want our callstacks to reflect that. *) +(* TODO I think now that we have inlined frames the [src] reconciliation logic wouldn't + work because we run the "straightline-execution inline frames" logic in [add_event] + before we ever get here. *) let handle_call (t : t) (time : Timestamp.t) ~(src : Location.t) ~(dst : Location.t) = - (* First, reconcile things such that [src] matches [current_frame t] if it doesn't + (* First, reconcile things such that [src] matches [current_physical_frame t] if it doesn't already. *) let () = match Frame.find (current_frame t) src.symbol with - | #(This _, ~distance:0) -> (* The happy case, [src] matches [current_frame t]. *) () - | #(This src_frame, ~distance) -> - (* [src] exists, but is higher up the callstack. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = src_frame; control_flow = Return { distance } } - | #(Null, ~distance:0) -> + | #(This _, ~physical_distance:0, ..) -> + (* The happy case, [src] matches [current_physical_frame t]. The inlined frames + should already be correct on account of the straightline-execution + inlined frames logic at the start of [add_event]. *) + () + | #(Null, ~physical_distance:0, ..) -> (* I would only ever expect this to occur at the very beginning of a trace. *) - Nonempty_vec.push_back - t.callstacks - #{ time - ; leaf = Frame.create src ~parent:(t.root :> Frame.t) - ; control_flow = Call - } - | #(Null, ~distance:_) -> + let src_frame = Frame.create src ~parent:(t.root :> Frame.t) ~kind:Physical in + append_inlined_frames t time ~physical_frame:src_frame ~physical_frame_is_new:true + | #(This src_frame, ~physical_distance:_, ~distance, ~leaf_of_inlined_stack) -> + log_unexpected_case + [%message "call [src] exists, but is higher up the callstack." (src : Location.t)]; + (match leaf_of_inlined_stack with + | #(Null, _) -> + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = src_frame; control_flow = Return { distance } }; + diff_inlined_frames + t + time + ~dso:src.dso + ~before:src_frame.instruction_pointer + ~after:src.instruction_pointer + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:src.dso + ~before:src_frame.instruction_pointer + ~after:src.instruction_pointer) + | #(Null, ~physical_distance:_, ..) -> + log_unexpected_case + [%message "call [src] does not match known trace state." (src : Location.t)]; (* We've somehow reached [src] without seeing the control-flow that brought us here. To maximize our chances of producing a coherent trace, we create a frame for @@ -248,97 +557,138 @@ let handle_call (t : t) (time : Timestamp.t) ~(src : Location.t) ~(dst : Locatio frame for [src] ( *in addition* to the frame we always create for [dst]) gives us better odds of resynchronizing with the event stream, since now we can easily handle a later return event to [src], [dst], or even both. *) - let src_frame = Frame.create src ~parent:(current_frame t) in - Nonempty_vec.push_back t.callstacks #{ time; leaf = src_frame; control_flow = Call } + let src_frame = Frame.create src ~parent:(current_frame t) ~kind:Physical in + append_inlined_frames t time ~physical_frame:src_frame ~physical_frame_is_new:true in + let #(src_frame, ~distance:_) = current_physical_frame t in + assert (not (Or_null.is_null src_frame.parent)); + Frame.set_instruction_pointer src_frame src.instruction_pointer; (* Then create the new frame for [dst]. *) + let dst_frame = Frame.create dst ~parent:(current_frame t) ~kind:Physical in + append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:true +;; + +(** We are returning into something we did not see the call for. This can happen if + there's a series of calls like [fn1 -> fn2 -> fn3] and we started tracing during the + execution of [fn2], then we see a return into [fn1]. *) +let return_to_unseen (t : t) (time : Timestamp.t) ~(dst : Location.t) ~(distance : int) = + (* We symbolize at one byte before the return address because the callstack we want to + see reflected as roots of the whole trace corresponds to the code as of the [call] + instruction we are returning from, *not* whatever comes immediately after it. *) + let addr = Int64.O.(dst.instruction_pointer - 1L) in + let inlined_frames = symbolize_inlined_frames t ~dso:dst.dso ~addr in + let mutable inlined_leaf = Null in + for i = Slice.length inlined_frames - 1 downto 0 do + let%tydi inlined_frame_info = Slice.unsafe_get inlined_frames i in + let inlined_frame = + replace_root t (Symbolizer.Info.to_location inlined_frame_info) ~kind:Inlined + in + if Or_null.is_null inlined_leaf then inlined_leaf <- This inlined_frame + done; + let (physical_root : Frame.t) = + replace_root t { dst with instruction_pointer = addr } ~kind:Physical + in Nonempty_vec.push_back t.callstacks - #{ time; leaf = Frame.create dst ~parent:(current_frame t); control_flow = Call } + #{ time + ; leaf = Or_null.value inlined_leaf ~default:physical_root + ; control_flow = Return { distance } + }; + diff_inlined_frames t time ~dso:dst.dso ~before:addr ~after:dst.instruction_pointer; + Frame.set_instruction_pointer physical_root dst.instruction_pointer ;; let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = - match (current_frame t).parent with - | Null -> - (* We are returning into something we did not see the call for. This can happen if - there's a series of calls like [fn1 -> fn2 -> fn3] and we started tracing during - the execution of [fn2], then we see a return into [fn1]. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = replace_root t dst; control_flow = Return { distance = 0 } } - | This parent_frame -> - (* We start our search for [dst] from the parent of the current frame because + match current_physical_frame t with + | #({ parent = Null; _ }, ~distance:_) -> return_to_unseen t time ~dst ~distance:0 + | #({ parent = This parent_frame; _ }, ~distance:distance_to_current_frame) -> + (* We start our search for [dst] from the parent of the current physical frame because otherwise you'd incorrectly handle non-tail recursion, and because returning to the - current frame is impossible anyway. We add 1 to [distance] in the [control_flow] to + current frame is impossible anyway. We add 1 to the distance here to account for the one extra frame implicitly traversed by doing this. *) + let distance_to_parent_frame = distance_to_current_frame + 1 in (match Frame.find parent_frame dst.symbol with - | #(This dst_frame, ~distance) -> - (* 99% of the time [distance] should be 0, indicating we are returning to + | #(This dst_frame, ~distance, ~leaf_of_inlined_stack, ..) -> + (* 99% of the time [physical_distance] should be 0, indicating we are returning to [parent_frame] as expected. We allow for the possibility of "long" returns to account for [Sysret]/[Iret] events that return to userspace directly from deep within their kernel/interrupt stack. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = dst_frame; control_flow = Return { distance = distance + 1 } } - | #(Null, ~distance:0) -> - (* Our [parent_frame] is the sentinel. We treat this identically to the [Null] case - in the outer match, for the same reasons stated in the comment there. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = replace_root t dst; control_flow = Return { distance = 0 + 1 } } - | #(Null, ~distance:_) -> + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = dst_frame + ; control_flow = Return { distance = distance + distance_to_parent_frame } + }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = + Return { distance = inlined_leaf_distance + distance_to_parent_frame } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer) + | #(Null, ~physical_distance:0, ~distance, ..) -> + (* Our [parent_frame] is the sentinel. *) + return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) + | #(Null, ~physical_distance:_, ..) -> + log_unexpected_case + [%message "return [dst] does not match known trace state." (dst : Location.t)]; (* Something is probably wrong if we ever make it to this case, where the state we're maintaining and the event we are processing seem to completely disagree. Treating it like a tail-call seems like the least bad option, and at the very least gets us to agree with the event stream that the current frame is [dst]. *) Nonempty_vec.push_back t.callstacks - #{ time; leaf = Frame.create dst ~parent:parent_frame; control_flow = Jump }) + #{ time + ; leaf = parent_frame + ; control_flow = Return { distance = distance_to_parent_frame } + }; + let dst_frame = Frame.create dst ~parent:parent_frame ~kind:Physical in + append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:true) ;; -let handle_jump (t : t) (time : Timestamp.t) ~(dst : Location.t) = - let current_frame = current_frame t in - if Symbol.equal current_frame.location.symbol dst.symbol - then - (* [dst] matches [current_frame t]. This is either a branch within a function, or - tail-recursion. For now we don't need to do anything in this case. That will change - once we support inlined frames. *) - () +let handle_jump (t : t) (time : Timestamp.t) ~(src : Location.t) ~(dst : Location.t) = + let #(current_physical_frame, ~distance) = current_physical_frame t in + if Symbol.equal current_physical_frame.location.symbol dst.symbol + then ( + (* [dst] matches [current_frame t]. This is either a branch within a function, or tail-recursion. *) + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:src.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer current_physical_frame dst.instruction_pointer) else ( - match current_frame.parent with + match current_physical_frame.parent with | Null -> (* This is probably a non-recursive tail-call, but we don't know anything about the previous frame, so we treat this is a [Call] because we only want to emit a frame-enter while writing out the trace. *) - Nonempty_vec.push_back - t.callstacks - #{ time - ; leaf = Frame.create dst ~parent:(t.root :> Frame.t) - ; control_flow = Call - } + let dst_frame = Frame.create dst ~parent:(t.root :> Frame.t) ~kind:Physical in + append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:true | This parent -> (* This is probably a non-recursive tail-call. *) Nonempty_vec.push_back t.callstacks - #{ time; leaf = Frame.create dst ~parent; control_flow = Jump }) -;; - -let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = - match event with - | Trace { kind; src; dst; trace_state_change } -> - eprint_s - ~mach:() - [%message - (kind : Event.Kind.t option) - ~time:(Time_ns.Span.to_int_ns (time :> Time_ns.Span.t) % 10000000 : int) - ~src:(Symbol.display_name src.symbol) - ~dst:(Symbol.display_name dst.symbol) - (trace_state_change : Trace_state_change.t option)] - | _ -> () -;; - -let[@inline always] print (event : Event.Ok.Data.t) (time : Timestamp.t) = - if debug then print event time + #{ time; leaf = parent; control_flow = Return { distance = distance + 1 } }; + let dst_frame = Frame.create dst ~parent ~kind:Physical in + append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:true) ;; let is_ocaml_exception_handler t ~(dst : Location.t) = @@ -350,29 +700,38 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with - | Null -> - eprintf - "Warning 1: [exception_handlers] appears to be out-of-sync with callstacks.\n%!"; - (match Frame.find (current_frame t) dst.symbol with - | #(This dst_frame, ~distance) -> - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = dst_frame; control_flow = Return { distance } } - | #(Null, ~distance) -> - (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = replace_root t dst; control_flow = Return { distance } }) - | This frame -> + | This dst_frame -> Vec.pop_back_unit_exn t.exception_handlers; - assert (Symbol.equal frame.location.symbol dst.symbol); - (match Frame.find_ancestor (current_frame t) ~ancestor:frame with - | This distance -> + assert (Symbol.equal dst_frame.location.symbol dst.symbol); + (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with + | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = frame; control_flow = Return { distance } } - | Null -> + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer) + | #(~distance:Null, ..) -> let message = match Frame.find (current_frame t) dst.symbol with | #(Null, ..) -> "This is likely to be a bug." @@ -380,39 +739,149 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = "This is deeply concerning because another frame with a matching symbol was \ found. This is very likely to be a bug." in - eprintf - "Warning 2: [exception_handlers] appears to be out-of-sync with [callstacks]. %s\n\ - %!" - message; + log_unexpected_case + [%message + [%string + "[exception_handlers] appears to be out-of-sync with [callstacks]; active \ + exception handler was not found in [callstacks]. %{message}"] + (dst : Location.t)]; + (* TODO Decide if maybe we should just raise in this case? The trace is probably going to be pretty broken if we make it here. *) handle_return t time ~dst) + | Null -> + (match Frame.find (current_frame t) dst.symbol with + | #(Null, ~distance, ..) -> + (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) + let dst_frame = replace_root t dst ~kind:Physical in + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + (* Unlike [handle_return] we do *not* make the inlined frames at [dst] (or [dst.instruction_pointer - 1]) + the parents of the existing frames. The rationale is that unlike [handle_return], we have no idea + where we might've been within the frame for [dst] that we just inferred. *) + append_inlined_frames + t + time + ~physical_frame:dst_frame + (* This is subtle; Yes the frame is new, but we *don't* want to reflect that in a + [Call], because discovered roots are handled separately. *) + ~physical_frame_is_new:false + | #(This dst_frame, ~distance, ~leaf_of_inlined_stack, ..) -> + log_unexpected_case + [%message + "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ + no active exception handler, but a frame with a matching symbol was found." + (dst : Location.t)]; + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) +;; + +let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = + match event with + | Trace { kind; src; dst; trace_state_change } -> + eprint_s + ~mach:() + [%message + (kind : Event.Kind.t option) + ~time:(Time_ns.Span.to_int_ns (time :> Time_ns.Span.t) % 10000000 : int) + ~src:(Symbol.display_name src.symbol) + ~src_ip:(src.instruction_pointer : Int64.Hex.t) + ~dst:(Symbol.display_name dst.symbol) + ~dst_ip:(dst.instruction_pointer : Int64.Hex.t) + (trace_state_change : Trace_state_change.t option)] + | _ -> () +;; + +let[@inline always] print (event : Event.Ok.Data.t) (time : Timestamp.t) = + if debug then print event time ;; let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = print event time; assert (Timestamp.( >= ) time t.last_event_time); t.last_event_time <- time; - (match t.ocaml_exception_info with - | Null -> () - | This ocaml_exception_info -> - (match event with - | Trace { src; dst; _ } -> + (match event with + | Trace { src; dst; _ } -> + if Interned_string.equal t.last_known_location.dso src.dso + && Int64.( <> ) t.last_known_location.instruction_pointer 0L + && Int64.( <> ) src.instruction_pointer 0L + then ( + let mutable prev_inlined_frames = + symbolize_inlined_frames + t + ~dso:t.last_known_location.dso + ~addr:t.last_known_location.instruction_pointer + in + (* TODO I fear symbolizing at every byte like this is likely to be *very* expensive, but let's focus on just getting things working for now. *) + let mutable addr = I64.of_int64 t.last_known_location.instruction_pointer in + let src_addr = I64.of_int64 src.instruction_pointer in + (* There are no [i64] for-loops yet :( *) + while I64.O.(addr <= src_addr) do + let addr_inlined_frames = + symbolize_inlined_frames t ~dso:src.dso ~addr:(I64.box addr) + in + diff_inlined_frames' + t + time + ~dso:src.dso + ~before:prev_inlined_frames + ~after:addr_inlined_frames; + prev_inlined_frames <- addr_inlined_frames; + addr <- I64.O.(addr + #1L) + done); + let #(current_physical_frame, ~distance:_) = current_physical_frame t in + (match t.ocaml_exception_info with + | Null -> () + | This ocaml_exception_info -> Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info - ~from:t.last_known_instruction_pointer + ~from:t.last_known_location.instruction_pointer ~to_:src.instruction_pointer ~f:(stack_ fun (_address, kind) -> match kind with - | Pushtrap -> Vec.push_back t.exception_handlers (current_frame t) + | Pushtrap -> Vec.push_back t.exception_handlers current_physical_frame | Poptrap -> - if phys_equal (This (current_frame t)) (Vec.last t.exception_handlers) - then Vec.pop_back_unit_exn t.exception_handlers - else - eprintf - "Warning 3: [exception_handlers] appears to be out-of-sync with \ - callstacks.\n\ - %!"); - t.last_known_instruction_pointer <- dst.instruction_pointer - | _ -> ())); + (match Vec.last t.exception_handlers with + | This current_exception_handler + when phys_equal current_exception_handler current_physical_frame -> + Vec.pop_back_unit_exn t.exception_handlers + | Null -> + (* Hitting this case a couple of times early in the trace is not unusual. *) + () + | This current_exception_handler -> + log_unexpected_case + [%message + "[exception_handlers] appears to be out-of-sync with [callstacks]; \ + the active exception handler does not match the current physical \ + frame." + ~current_exception_handler: + (current_exception_handler.location : Location.t) + ~current_physical_frame: + (current_physical_frame.location : Location.t)]))); + t.last_known_location <- dst + | _ -> ()); (match event with (* TODO Get the untraced "kind" right instead of always showing [Location.untraced] for untraced time. *) | Trace { trace_state_change = Some Start; dst; _ } -> handle_return t time ~dst @@ -424,14 +893,48 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | (Return | Jump) when is_ocaml_exception_handler t ~dst -> handle_ocaml_exception t time ~dst | Return | Sysret | Iret -> handle_return t time ~dst - | Jump | Tx_abort | Async -> handle_jump t time ~dst) + | Jump | Tx_abort | Async -> handle_jump t time ~src ~dst) | Trace { kind = None; _ } -> () - (* All of the below events are handled in [trace_writer.ml]. *) + (* All of the below events are handled in [new_trace_writer.ml]. *) | Power _ | Stacktrace_sample _ | Event_sample _ -> ()); if debug then ( Frame.For_testing.print_callstack (current_frame t); - print_endline "-------------------------------") + print_endline "-------------------------------"); + if Env_vars.check_invariants + then ( + let #(current_physical_frame, ~distance) = current_physical_frame t in + (* Maintaining [t.last_known_location] separately is a minor optimization so that + we don't have to walk from [current_frame t] to find the current physical frame + at the start of processing each event. The corollary is that updating the [instruction_pointer] + on the current physical frame on each event **is truly necessary**; maintaining *only* + [t.last_known_location] would be insufficient to accurately process traces. + In particular this comes up when handling returns (and by extension, exceptions), + where you need to know what the instruction-pointer was in the physical frame you + are returning to the last time the program was there, so that you can + [diff_inlined_frames] in order to return to *the correct inlined child* of that + physical frame. *) + [%test_eq: Int64.Hex.t] + ~message: + "Recorded [last_known_location] does not match the current physical frame after \ + processing this event" + t.last_known_location.instruction_pointer + current_physical_frame.instruction_pointer; + let actual_inlined_frames = ref [] in + Frame.iter_n (current_frame t) distance ~f:(fun { location = { symbol; _ }; _ } -> + actual_inlined_frames := Symbol.display_name symbol :: !actual_inlined_frames); + let expected_inlined_frames = + symbolize_inlined_frames + t + ~dso:t.last_known_location.dso + ~addr:t.last_known_location.instruction_pointer + |> Slice.map_to_list ~f:(fun inlined_frame_info -> + Symbolizer.Info.display_name inlined_frame_info) + in + [%test_result: string list] + ~message:"Inlined frames in callstacks did not match expectation" + !actual_inlined_frames + ~expect:expected_inlined_frames) ;; module Writer : sig @@ -481,6 +984,8 @@ end = struct } ;; + (* TODO We should probably scrap Owee entirely and get this information directly from + LLVM instead given that we're already using it to resolve inlined frames. *) let location_args debug_info (location : Location.t) = let display_name = Symbol.display_name location.symbol in let base_address = @@ -552,7 +1057,7 @@ let smear_times (callstacks : Callstack.t Nonempty_vec.t) = time substantially reduces the frequency where we need to use zero-duration events. In general the traces are easier to read if returns aren't counted as consuming time. *) let[@inline always] consumes_time : Callstack.t -> bool = function - | #{ control_flow = Call | Jump; _ } -> true + | #{ control_flow = Call _; _ } -> true | _ -> false in let len = Nonempty_vec.length callstacks in @@ -614,45 +1119,35 @@ let write_trace ~exit_final_callstack = let writer = Writer.create trace thread debug_info in - if Nonempty_vec.length t.callstacks > 1 + smear_times t.callstacks; + if enter_initial_callstack then ( - smear_times t.callstacks; - if enter_initial_callstack - then ( - let first_callstack = Nonempty_vec.get t.callstacks 1 in - let () = - match first_callstack.#leaf.parent with - | Null -> () - | This parent_frame -> - (* Emit a frame enter for everything except the leaf in the initial callstack. We - need to do this because otherwise we'd be missing parent frames in the trace that - we discovered by returning into them (see the [Null] case in [handle_return]). *) - Frame.iter_rev parent_frame ~f:(stack_ fun frame -> - Writer.emit_frame_enter writer first_callstack.#time frame) - in - (* Modify [t.callstacks] so that the first pair processed in - [Nonempty_vec.iter_pairs] below calls [emit_frame_enter] for the leaf frame. *) - Nonempty_vec.set t.callstacks 1 #{ first_callstack with control_flow = Call }); - Nonempty_vec.iter_pairs - t.callstacks - ~f:(stack_ fun (#(prev, curr) : #(Callstack.t * Callstack.t)) -> - let time = curr.#time in - match curr.#control_flow with - | Jump -> - Writer.emit_frame_exit writer time prev.#leaf; - Writer.emit_frame_enter writer time curr.#leaf - | Call -> Writer.emit_frame_enter writer time curr.#leaf - | Return { distance } -> - Frame.iter_n prev.#leaf distance ~f:(stack_ fun frame -> - Writer.emit_frame_exit writer time frame) - [@nontail]); - if exit_final_callstack - then ( - (* Call [emit_frame_exit] for all remaining frames at the end of the segment. *) - let last_callstack = Nonempty_vec.last t.callstacks in - Frame.iter_n last_callstack.#leaf Int.max_value ~f:(stack_ fun frame -> - Writer.emit_frame_exit writer last_callstack.#time frame) - [@nontail])) + (* Call [emit_frame_enter] for everything in the initial callstack. This takes care of + entering any root frames that we discovered by returning into them (i.e. the places + where we call [replace_root]). *) + let%tydi #{ leaf; time; _ } = Nonempty_vec.first t.callstacks in + Frame.iter_n_rev leaf Int.max_value ~f:(stack_ fun frame -> + Writer.emit_frame_enter writer time frame)); + Nonempty_vec.iter_pairs + t.callstacks + ~f:(stack_ fun (#(prev, curr) : #(Callstack.t * Callstack.t)) -> + let time = curr.#time in + match curr.#control_flow with + | Call { depth } -> + Frame.iter_n_rev curr.#leaf depth ~f:(stack_ fun frame -> + Writer.emit_frame_enter writer time frame) + [@nontail] + | Return { distance } -> + Frame.iter_n prev.#leaf distance ~f:(stack_ fun frame -> + Writer.emit_frame_exit writer time frame) + [@nontail]); + if exit_final_callstack + then ( + (* Call [emit_frame_exit] for all remaining frames at the end of the segment. *) + let last_callstack = Nonempty_vec.last t.callstacks in + Frame.iter_n last_callstack.#leaf Int.max_value ~f:(stack_ fun frame -> + Writer.emit_frame_exit writer last_callstack.#time frame) + [@nontail]) ;; module%test _ = struct @@ -670,8 +1165,10 @@ module%test _ = struct { symbol_offset = 0 ; instruction_pointer = 0L ; symbol = From_perf leaf_name + ; dso = Interned_string.empty } - ~parent:root) + ~parent:root + ~kind:Physical) in #(~root, ~leaf) ;; @@ -721,7 +1218,7 @@ module%test _ = struct ;; let create_callstacks (times : int list) : Callstack.t Nonempty_vec.t = - List.map ~f:(fun time -> time, Control_flow.Call) times + List.map ~f:(fun time -> time, Control_flow.Call { depth = 1 }) times |> create_callstacks_with_control_flow ;; @@ -785,14 +1282,14 @@ module%test _ = struct [%expect {| 50 50 50 |}] ;; - let%expect_test "[smear_times] only Call and Jump events consume time" = + let%expect_test "[smear_times] only Call events consume time" = let callstacks = create_callstacks_with_control_flow [ 0, Return { distance = 1 } - ; 0, Call + ; 0, Call { depth = 1 } ; 0, Return { distance = 1 } - ; 0, Jump - ; 100, Call + ; 0, Call { depth = 1 } + ; 100, Call { depth = 1 } ] in print_times callstacks; @@ -805,7 +1302,11 @@ module%test _ = struct let%expect_test "[smear_times] first event is a Call" = let callstacks = create_callstacks_with_control_flow - [ 0, Call; 0, Return { distance = 1 }; 0, Jump; 90, Call ] + [ 0, Call { depth = 1 } + ; 0, Return { distance = 1 } + ; 0, Call { depth = 1 } + ; 90, Call { depth = 1 } + ] in print_times callstacks; [%expect {| 0 0 0 90 |}]; @@ -820,7 +1321,7 @@ module%test _ = struct [ 0, Return { distance = 1 } ; 0, Return { distance = 1 } ; 0, Return { distance = 1 } - ; 90, Call + ; 90, Call { depth = 1 } ] in print_times callstacks; @@ -832,7 +1333,7 @@ module%test _ = struct end let setup_test () = - let t = create None ~in_filtered_region:true in + let t = create None in let ip = ref (-1) in let time = ref Time_ns.Span.zero in let incr_time () = time := Time_ns.Span.(!time + of_int_ns 1) in @@ -842,6 +1343,7 @@ module%test _ = struct { instruction_pointer = Int64.of_int !ip ; symbol_offset = 0 ; symbol = From_perf name + ; dso = Interned_string.empty } in let call ~src ~dst = @@ -1070,10 +1572,12 @@ module%test _ = struct jump ~src:"fn1" ~dst:"fn2"; return ~src:"fn2" ~dst:"main"; print_callstacks t; + (* TODO Showing a return to [main] and subsequent call into [fn2] is a bug that was + introduced when adding support for inlined frames. We need to fix this. *) [%expect {| - main main main main - fn1 fn2 + main main main main main + fn1 fn2 - |}] ;; diff --git a/src/trace_segment.mli b/src/trace_segment.mli index 8212df75b..0cf99ca19 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -4,13 +4,12 @@ open! Core thread. *) type t -val create : Ocaml_exception_info.t option -> in_filtered_region:bool -> t +val create : Ocaml_exception_info.t option -> t (** Create a new trace segment that continues from the state of an existing segment, taking the existing segment's last callstack as the new segment's first callstack. *) -val create_continuing_from : t -> in_filtered_region:bool -> t +val create_continuing_from : t -> t -val in_filtered_region : t -> bool val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit val write_trace diff --git a/src/trace_writer.ml b/src/trace_writer.ml index 3fccc71eb..198ac02c4 100644 --- a/src/trace_writer.ml +++ b/src/trace_writer.ml @@ -52,7 +52,9 @@ module Pending_event = struct [@@deriving sexp] let create_call location ~from_untraced = - let { Event.Location.instruction_pointer; symbol; symbol_offset } = location in + let { Event.Location.instruction_pointer; symbol; symbol_offset; dso = _ } = + location + in { symbol ; kind = Call { addr = instruction_pointer; offset = symbol_offset; from_untraced } } diff --git a/test/dune b/test/dune index 69d9af82b..79bf312d0 100644 --- a/test/dune +++ b/test/dune @@ -1,7 +1,13 @@ (library (name magic_trace_app_test) - (inline_tests) - (libraries async core expect_test_helpers_core expect_test_helpers_async - magic_trace_lib) + (no_dynlink) + (inline_tests + (deps sample-targets/ocaml-raise/sample.exe)) + (libraries + async + core + expect_test_helpers_core + expect_test_helpers_async + magic_trace_lib) (preprocess (pps ppx_jane))) diff --git a/test/sample-targets/long-running/dune b/test/sample-targets/long-running/dune index 64e13c395..614ef2f0a 100644 --- a/test/sample-targets/long-running/dune +++ b/test/sample-targets/long-running/dune @@ -1,6 +1,12 @@ (executables (names long_running) - (libraries core core_unix core_unix.core_thread core_unix.command_unix - magic_trace core_unix.time_ns_unix core_unix.time_stamp_counter) + (libraries + core + core_unix + core_unix.core_thread + core_unix.command_unix + magic_trace + core_unix.time_ns_unix + core_unix.time_stamp_counter) (preprocess (pps ppx_jane))) diff --git a/test/sample-targets/ocaml-raise/dune b/test/sample-targets/ocaml-raise/dune index 118f07bf9..36b9152fa 100644 --- a/test/sample-targets/ocaml-raise/dune +++ b/test/sample-targets/ocaml-raise/dune @@ -1,6 +1,10 @@ (executables (names sample) - (libraries core core_unix core_unix.command_unix magic_trace - core_unix.time_stamp_counter) + (libraries + core + core_unix + core_unix.command_unix + magic_trace + core_unix.time_stamp_counter) (preprocess (pps ppx_jane))) diff --git a/test/test.ml b/test/test.ml index 3ec670e09..bcf9272b4 100644 --- a/test/test.ml +++ b/test/test.ml @@ -8,6 +8,7 @@ include struct module Event = Event module Symbol = Symbol module Trace_filter = Trace_filter + module Interned_string = Interned_string end module Trace_helpers : sig @@ -38,7 +39,14 @@ end = struct let addr () = Random.State.int64_incl !rng 0L 0x7fffffffffffL let offset () = Random.State.int_incl !rng 0 0x1000 let unknown = Symbol.From_perf "unknown" - let loc symbol = { Event.Location.instruction_pointer = 0L; symbol; symbol_offset = 0 } + + let loc symbol = + { Event.Location.instruction_pointer = 0L + ; symbol + ; symbol_offset = 0 + ; dso = Interned_string.empty + } + ;; let symbol () = Symbol.From_perf @@ -50,6 +58,7 @@ end = struct { instruction_pointer = addr () ; symbol = Option.value symbol ~default:(Symbol.From_perf "") ; symbol_offset = offset () + ; dso = Interned_string.empty } ;; From 7fecc44325e4a901d463e7d50c89b229e823830e Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Wed, 15 Apr 2026 14:36:26 -0400 Subject: [PATCH 08/30] Accept test changes Signed-off-by: Kevin Svetlitski --- test/test.ml | 180 +++++++++++++++++++++++++++++---------------------- 1 file changed, 101 insertions(+), 79 deletions(-) diff --git a/test/test.ml b/test/test.ml index bcf9272b4..f5fbd44d4 100644 --- a/test/test.ml +++ b/test/test.ml @@ -62,15 +62,33 @@ end = struct } ;; + let start_location : Event.Location.t = + { instruction_pointer = 0x900000L + ; symbol = From_perf "_start" + ; symbol_offset = 4 + ; dso = Interned_string.empty + } + ;; + + let last_dst_location = ref start_location + let random_ok_event ?kind ?symbol () : Event.Ok.t = + let src = + { !last_dst_location with + instruction_pointer = Int64.succ !last_dst_location.instruction_pointer + ; symbol_offset = !last_dst_location.symbol_offset + 1 + } + in + let dst = random_location ?symbol () in + last_dst_location := dst; { thread ; time = time () ; data = Trace { trace_state_change = None ; kind = Some (Option.value kind ~default:Event.Kind.Call) - ; src = random_location () - ; dst = random_location ?symbol () + ; src + ; dst } ; in_transaction = false } @@ -131,6 +149,7 @@ end = struct Stack.clear stack; cur_time := start_time; rng := Random.State.make make_rng_array; + last_dst_location := start_location; ret ;; @@ -211,17 +230,17 @@ let%expect_test "random perfs" = ((pid 1) (tid 2) (process_name ("[pid=1234] [tid=456]")) (thread_name (main))))) (Interned_string (index 104) (value address)) - (Interned_string (index 105) (value "+O\002B~h")) + (Interned_string (index 105) (value "B~h\031T")) (Interned_string (index 106) (value symbol)) (Interned_string (index 107) (value "")) (Event - ((timestamp 13ns) (thread 1) (category 107) (name 105) - (arguments ((104 (Pointer 0x38df7fb74073)) (106 (String 105)))) + ((timestamp 71ns) (thread 1) (category 107) (name 105) + (arguments ((104 (Pointer 0x40a09d024a7)) (106 (String 105)))) (event_type Duration_begin))) - (Interned_string (index 108) (value "\017c\004dl\\")) + (Interned_string (index 108) (value "\020\012\024f")) (Event - ((timestamp 87ns) (thread 1) (category 107) (name 108) - (arguments ((104 (Pointer 0x70b30bb76ae5)) (106 (String 108)))) + ((timestamp 140ns) (thread 1) (category 107) (name 108) + (arguments ((104 (Pointer 0x4b46c9ab792e)) (106 (String 108)))) (event_type Duration_begin))) (Interned_string (index 109) (value [unknown])) (Event @@ -236,21 +255,21 @@ let%expect_test "random perfs" = ((104 (Pointer 0xd39111cc0c)) (106 (String 110)) (112 (String 111)))) (event_type Duration_begin))) (Event - ((timestamp 166ns) (thread 1) (category 107) (name 108) (arguments ()) + ((timestamp 190ns) (thread 1) (category 107) (name 108) (arguments ()) (event_type Duration_end))) - (Interned_string (index 113) (value "\0188\020")) + (Interned_string (index 113) (value "\017c\004")) (Event - ((timestamp 166ns) (thread 1) (category 107) (name 113) - (arguments ((104 (Pointer 0x4c43bd1036db)) (106 (String 113)))) + ((timestamp 190ns) (thread 1) (category 107) (name 113) + (arguments ((104 (Pointer 0x70b30bb76ae5)) (106 (String 113)))) (event_type Duration_begin))) (Event - ((timestamp 166ns) (thread 1) (category 107) (name 113) (arguments ()) + ((timestamp 190ns) (thread 1) (category 107) (name 113) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 166ns) (thread 1) (category 107) (name 105) (arguments ()) + ((timestamp 190ns) (thread 1) (category 107) (name 105) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 166ns) (thread 1) (category 107) (name 110) (arguments ()) + ((timestamp 190ns) (thread 1) (category 107) (name 110) (arguments ()) (event_type Duration_end))) (Error No_more_words) |}]; @@ -299,14 +318,14 @@ let%expect_test "random perfs" = (Interned_string (index 104) (value "\026/")) (Interned_string (index 105) (value "")) (Event - ((timestamp 13ns) (thread 1) (category 105) (name 104) (arguments ()) + ((timestamp 71ns) (thread 1) (category 105) (name 104) (arguments ()) (event_type Duration_end))) (Interned_string (index 106) (value address)) - (Interned_string (index 107) (value "+O\002B~h")) + (Interned_string (index 107) (value "B~h\031T")) (Interned_string (index 108) (value symbol)) (Event - ((timestamp 13ns) (thread 1) (category 105) (name 107) - (arguments ((106 (Pointer 0x38df7fb74073)) (108 (String 107)))) + ((timestamp 71ns) (thread 1) (category 105) (name 107) + (arguments ((106 (Pointer 0x40a09d024a7)) (108 (String 107)))) (event_type Duration_begin))) (Interned_string (index 109) (value [unknown])) (Event @@ -319,16 +338,16 @@ let%expect_test "random perfs" = (arguments ((106 (Pointer 0xd39111cc0c)) (108 (String 104)) (111 (String 110)))) (event_type Duration_begin))) - (Interned_string (index 112) (value "\017c\004dl\\")) + (Interned_string (index 112) (value "\020\012\024f")) (Event - ((timestamp 87ns) (thread 1) (category 105) (name 112) - (arguments ((106 (Pointer 0x70b30bb76ae5)) (108 (String 112)))) + ((timestamp 140ns) (thread 1) (category 105) (name 112) + (arguments ((106 (Pointer 0x4b46c9ab792e)) (108 (String 112)))) (event_type Duration_begin))) (Event - ((timestamp 87ns) (thread 1) (category 105) (name 112) (arguments ()) + ((timestamp 140ns) (thread 1) (category 105) (name 112) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 87ns) (thread 1) (category 105) (name 107) (arguments ()) + ((timestamp 140ns) (thread 1) (category 105) (name 107) (arguments ()) (event_type Duration_end))) (Error No_more_words) |}]; @@ -346,56 +365,56 @@ let%expect_test "random perfs" = ((pid 1) (tid 2) (process_name ("[pid=1234] [tid=456]")) (thread_name (main))))) (Interned_string (index 104) (value address)) - (Interned_string (index 105) (value "+O\002B~h")) + (Interned_string (index 105) (value "B~h\031T")) (Interned_string (index 106) (value symbol)) (Interned_string (index 107) (value "")) (Event - ((timestamp 13ns) (thread 1) (category 107) (name 105) - (arguments ((104 (Pointer 0x38df7fb74073)) (106 (String 105)))) + ((timestamp 71ns) (thread 1) (category 107) (name 105) + (arguments ((104 (Pointer 0x40a09d024a7)) (106 (String 105)))) (event_type Duration_begin))) (Event - ((timestamp 18ns) (thread 1) (category 107) (name 105) (arguments ()) + ((timestamp 160ns) (thread 1) (category 107) (name 105) (arguments ()) (event_type Duration_end))) (Interned_string (index 108) (value "\026/")) (Event - ((timestamp 18ns) (thread 1) (category 107) (name 108) (arguments ()) + ((timestamp 160ns) (thread 1) (category 107) (name 108) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 18ns) (thread 1) (category 107) (name 105) - (arguments ((104 (Pointer 0x4b46c9ab792e)) (106 (String 105)))) + ((timestamp 160ns) (thread 1) (category 107) (name 105) + (arguments ((104 (Pointer 0x38df7fb74073)) (106 (String 105)))) (event_type Duration_begin))) (Event - ((timestamp 68ns) (thread 1) (category 107) (name 105) (arguments ()) + ((timestamp 220ns) (thread 1) (category 107) (name 105) (arguments ()) (event_type Duration_end))) - (Interned_string (index 109) (value "w7&\0188\020x\\")) + (Interned_string (index 109) (value "\017c\004dl")) (Event - ((timestamp 78ns) (thread 1) (category 107) (name 109) - (arguments ((104 (Pointer 0x76ae90948b21)) (106 (String 109)))) + ((timestamp 270ns) (thread 1) (category 107) (name 109) + (arguments ((104 (Pointer 0x70b30bb76ae5)) (106 (String 109)))) (event_type Duration_begin))) (Interned_string (index 110) (value true)) (Interned_string (index 111) (value inferred_start_time)) (Event ((timestamp 0s) (thread 1) (category 107) (name 108) (arguments - ((104 (Pointer 0x68bf42fc6148)) (106 (String 108)) (111 (String 110)))) + ((104 (Pointer 0x2e982c5c3c4a)) (106 (String 108)) (111 (String 110)))) (event_type Duration_begin))) (Event ((timestamp 0s) (thread 1) (category 107) (name 108) (arguments ((104 (Pointer 0xd39111cc0c)) (106 (String 108)))) (event_type Duration_begin))) - (Interned_string (index 112) (value "\011X\024")) + (Interned_string (index 112) (value "w7&\0188\020x\\")) (Event - ((timestamp 124ns) (thread 1) (category 107) (name 112) - (arguments ((104 (Pointer 0x3bafd6d24276)) (106 (String 112)))) + ((timestamp 358ns) (thread 1) (category 107) (name 112) + (arguments ((104 (Pointer 0x76ae90948b21)) (106 (String 112)))) (event_type Duration_begin))) (Event - ((timestamp 124ns) (thread 1) (category 107) (name 112) (arguments ()) + ((timestamp 358ns) (thread 1) (category 107) (name 112) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 124ns) (thread 1) (category 107) (name 109) (arguments ()) + ((timestamp 358ns) (thread 1) (category 107) (name 109) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 124ns) (thread 1) (category 107) (name 108) (arguments ()) + ((timestamp 358ns) (thread 1) (category 107) (name 108) (arguments ()) (event_type Duration_end))) (Error No_more_words) |}]; @@ -435,88 +454,88 @@ let%expect_test "with initial returns" = (Interned_string (index 104) (value "\026/")) (Interned_string (index 105) (value "")) (Event - ((timestamp 13ns) (thread 1) (category 105) (name 104) (arguments ()) + ((timestamp 71ns) (thread 1) (category 105) (name 104) (arguments ()) (event_type Duration_end))) - (Interned_string (index 106) (value "+O\002B~h")) + (Interned_string (index 106) (value "B~h\031T")) (Event - ((timestamp 87ns) (thread 1) (category 105) (name 106) (arguments ()) + ((timestamp 140ns) (thread 1) (category 105) (name 106) (arguments ()) (event_type Duration_end))) - (Interned_string (index 107) (value "\017c\004dl\\")) + (Interned_string (index 107) (value "\020\012\024f")) (Event - ((timestamp 166ns) (thread 1) (category 105) (name 107) (arguments ()) + ((timestamp 190ns) (thread 1) (category 105) (name 107) (arguments ()) (event_type Duration_end))) (Interned_string (index 108) (value address)) - (Interned_string (index 109) (value "\011X\024\018I]")) + (Interned_string (index 109) (value "w7&\0188\020x\\")) (Interned_string (index 110) (value symbol)) (Event - ((timestamp 212ns) (thread 1) (category 105) (name 109) - (arguments ((108 (Pointer 0x3bafd6d24276)) (110 (String 109)))) + ((timestamp 278ns) (thread 1) (category 105) (name 109) + (arguments ((108 (Pointer 0x76ae90948b21)) (110 (String 109)))) (event_type Duration_begin))) - (Interned_string (index 111) (value "\006\0287KS{5")) + (Interned_string (index 111) (value "\bl@\011X\024\018I")) (Event - ((timestamp 263ns) (thread 1) (category 105) (name 111) - (arguments ((108 (Pointer 0x1ab97b79c3e9)) (110 (String 111)))) + ((timestamp 353ns) (thread 1) (category 105) (name 111) + (arguments ((108 (Pointer 0x3d60dc058bdb)) (110 (String 111)))) (event_type Duration_begin))) (Event - ((timestamp 290ns) (thread 1) (category 105) (name 111) (arguments ()) + ((timestamp 400ns) (thread 1) (category 105) (name 111) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 290ns) (thread 1) (category 105) (name 109) (arguments ()) + ((timestamp 400ns) (thread 1) (category 105) (name 109) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 290ns) (thread 1) (category 105) (name 111) - (arguments ((108 (Pointer 0x4e875e8d5917)) (110 (String 111)))) + ((timestamp 400ns) (thread 1) (category 105) (name 111) + (arguments ((108 (Pointer 0xeab2ebcd97d)) (110 (String 111)))) (event_type Duration_begin))) (Event - ((timestamp 337ns) (thread 1) (category 105) (name 111) (arguments ()) + ((timestamp 430ns) (thread 1) (category 105) (name 111) (arguments ()) (event_type Duration_end))) - (Interned_string (index 112) (value "\001/p:")) + (Interned_string (index 112) (value "]RP\006\0287")) (Event - ((timestamp 337ns) (thread 1) (category 105) (name 112) - (arguments ((108 (Pointer 0x7d1910749b4d)) (110 (String 112)))) + ((timestamp 430ns) (thread 1) (category 105) (name 112) + (arguments ((108 (Pointer 0x27bf01bcea1d)) (110 (String 112)))) (event_type Duration_begin))) (Event - ((timestamp 396ns) (thread 1) (category 105) (name 112) (arguments ()) + ((timestamp 509ns) (thread 1) (category 105) (name 112) (arguments ()) (event_type Duration_end))) - (Interned_string (index 113) (value "\0188\020")) + (Interned_string (index 113) (value "\017c\004")) (Event - ((timestamp 396ns) (thread 1) (category 105) (name 113) (arguments ()) + ((timestamp 509ns) (thread 1) (category 105) (name 113) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 396ns) (thread 1) (category 105) (name 112) - (arguments ((108 (Pointer 0x3218dd4125e6)) (110 (String 112)))) + ((timestamp 509ns) (thread 1) (category 105) (name 112) + (arguments ((108 (Pointer 0x6bd56981ff1e)) (110 (String 112)))) (event_type Duration_begin))) (Event - ((timestamp 422ns) (thread 1) (category 105) (name 112) (arguments ()) + ((timestamp 548ns) (thread 1) (category 105) (name 112) (arguments ()) (event_type Duration_end))) - (Interned_string (index 114) (value "\002s\b6t\031L&3")) + (Interned_string (index 114) (value "p\011\004\027BMw`")) (Interned_string (index 115) (value true)) (Interned_string (index 116) (value inferred_start_time)) (Event ((timestamp 0s) (thread 1) (category 105) (name 114) (arguments - ((108 (Pointer 0x1d23eb1c2889)) (110 (String 114)) (116 (String 115)))) + ((108 (Pointer 0x7484e5a78107)) (110 (String 114)) (116 (String 115)))) (event_type Duration_begin))) - (Interned_string (index 117) (value "\015'p\011\004\027BM")) + (Interned_string (index 117) (value "5F\022\026x\001/p:}")) (Event ((timestamp 0s) (thread 1) (category 105) (name 117) (arguments - ((108 (Pointer 0x668b6c8c3735)) (110 (String 117)) (116 (String 115)))) + ((108 (Pointer 0x3218dd4125e6)) (110 (String 117)) (116 (String 115)))) (event_type Duration_begin))) (Event ((timestamp 0s) (thread 1) (category 105) (name 113) (arguments - ((108 (Pointer 0x4c43bd1036db)) (110 (String 113)) (116 (String 115)))) + ((108 (Pointer 0x70b30bb76ae5)) (110 (String 113)) (116 (String 115)))) (event_type Duration_begin))) (Event ((timestamp 0s) (thread 1) (category 105) (name 107) (arguments - ((108 (Pointer 0x70b30bb76ae5)) (110 (String 107)) (116 (String 115)))) + ((108 (Pointer 0x4b46c9ab792e)) (110 (String 107)) (116 (String 115)))) (event_type Duration_begin))) (Event ((timestamp 0s) (thread 1) (category 105) (name 106) (arguments - ((108 (Pointer 0x38df7fb74073)) (110 (String 106)) (116 (String 115)))) + ((108 (Pointer 0x40a09d024a7)) (110 (String 106)) (116 (String 115)))) (event_type Duration_begin))) (Interned_string (index 118) (value [unknown])) (Event @@ -528,10 +547,10 @@ let%expect_test "with initial returns" = ((108 (Pointer 0xd39111cc0c)) (110 (String 104)) (116 (String 115)))) (event_type Duration_begin))) (Event - ((timestamp 470ns) (thread 1) (category 105) (name 117) (arguments ()) + ((timestamp 628ns) (thread 1) (category 105) (name 117) (arguments ()) (event_type Duration_end))) (Event - ((timestamp 470ns) (thread 1) (category 105) (name 114) (arguments ()) + ((timestamp 628ns) (thread 1) (category 105) (name 114) (arguments ()) (event_type Duration_end))) (Error No_more_words) |}]; @@ -630,7 +649,8 @@ let%expect_test "time batch spreading" = (Event ((timestamp 103ns) (thread 1) (category 107) (name 103) (arguments ()) (event_type Duration_end))) - (Error No_more_words) |}]; + (Error No_more_words) + |}]; return () ;; @@ -703,7 +723,8 @@ let%expect_test "enqueuing events at start" = (Event ((timestamp 3ns) (thread 1) (category 105) (name 108) (arguments ()) (event_type Duration_end))) - (Error No_more_words) |}]; + (Error No_more_words) + |}]; return () ;; @@ -802,7 +823,8 @@ let%expect_test "filtered trace" = (Event ((timestamp 13ns) (thread 1) (category 109) (name 105) (arguments ()) (event_type Duration_end))) - (Error No_more_words) |}]; + (Error No_more_words) + |}]; return () ;; From cb14d188bf877fc853d22341b75755ffaa3268b5 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Fri, 24 Apr 2026 18:48:35 -0400 Subject: [PATCH 09/30] Use `value_or_null` template of `Hashtbl.t` instead of converting to `Uopt.t` Signed-off-by: Kevin Svetlitski --- src/symbolizer.ml | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/symbolizer.ml b/src/symbolizer.ml index cb6846b1b..ce5cf4565 100644 --- a/src/symbolizer.ml +++ b/src/symbolizer.ml @@ -65,7 +65,7 @@ module Llvm_symbolizer = struct end type t = - { symbolization_cache : (Request.t, Response.t Uopt.t) Hashtbl.t + { symbolization_cache : (Request.t, Response.t or_null) Hashtbl.t ; response_cache : Response.t Hash_set.t ; llvm_symbolizer : Llvm_symbolizer.t } @@ -89,15 +89,13 @@ let symbolize t ~executable ~addr = avoids us polluting our cache with many [Null] responses. *) if I64.O.(addr <= #0L) then Null - else ( - let result = - Hashtbl.find_or_add - t.symbolization_cache - { addr; executable } - ~default:(stack_ fun () -> - match Llvm_symbolizer.symbolize t.llvm_symbolizer ~executable ~addr with - | Null -> Uopt.none - | This response -> Uopt.some (Hash_set.get_or_add t.response_cache response)) - in - Bool.select (Uopt.is_some result) (This (Uopt.unsafe_value result)) Null) + else + (Hashtbl.find_or_add [@kind value value_or_null]) + t.symbolization_cache + { addr; executable } + ~default:(stack_ fun () -> + match Llvm_symbolizer.symbolize t.llvm_symbolizer ~executable ~addr with + | Null -> Null + | This response -> This (Hash_set.get_or_add t.response_cache response)) + [@nontail] ;; From 3f25fbd5317ef2373f8946a290a5c81127e17805 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Fri, 24 Apr 2026 18:50:11 -0400 Subject: [PATCH 10/30] Add `perf.data[.old]` to gitignore Signed-off-by: Kevin Svetlitski --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index fb2549625..d46401d4f 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,8 @@ _build *.install *.merlin _opam +perf.data +perf.data.old .vscode/* !.vscode/tasks.json *.fxt From b9112ac0d37f2bb91fab3a020ba5d01ab34a27e4 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Fri, 24 Apr 2026 18:56:31 -0400 Subject: [PATCH 11/30] Unbox a tuple Signed-off-by: Kevin Svetlitski --- src/perf_decode.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/perf_decode.ml b/src/perf_decode.ml index 1e4335c3b..b0867206a 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -113,7 +113,7 @@ let parse_event_header line = ;; let parse_symbol_and_offset_and_dso ?perf_maps pid str ~addr - : Symbol.t * int * Interned_string.t + : #(Symbol.t * int * Interned_string.t) = match Re.Group.all (Re.exec symbol_and_offset_and_dso_re str) with | [| _; symbol; offset; dso |] -> @@ -130,18 +130,18 @@ let parse_symbol_and_offset_and_dso ?perf_maps pid str ~addr avoid the extra allocation. *) Util.int_trunc_of_hex_string ~remove_hex_prefix:true offset in - From_perf symbol, offset, dso + #(From_perf symbol, offset, dso) | _ | (exception _) -> - let failed = Symbol.Unknown, 0, Interned_string.empty in + let failed = #(Symbol.Unknown, 0, Interned_string.empty) in (match perf_maps, pid with | None, _ | _, None -> (match Re.Group.all (Re.exec unknown_symbol_dso_re str) with | [| _; dso |] -> (* CR-someday tbrindus: ideally, we would subtract the DSO base offset from [offset] here. *) - ( From_perf [%string "[unknown @ %{addr#Int64.Hex} (%{dso})]"] - , 0 - , Interned_string.intern dso ) + #( From_perf [%string "[unknown @ %{addr#Int64.Hex} (%{dso})]"] + , 0 + , Interned_string.intern dso ) | _ | (exception _) -> failed) | Some perf_map, Some pid -> (match Perf_map.Table.symbol ~pid perf_map ~addr with @@ -150,7 +150,7 @@ let parse_symbol_and_offset_and_dso ?perf_maps pid str ~addr (* It's strange that perf isn't resolving these symbols. It says on the tin that it supports perf map files! *) let offset = saturating_sub_i64 addr location.start_addr in - From_perf_map location, offset, Interned_string.empty)) + #(From_perf_map location, offset, Interned_string.empty))) ;; let trace_error_to_event line : Event.Decode_error.t = @@ -190,7 +190,7 @@ let parse_location ?perf_maps ~pid instruction_pointer symbol_and_offset : Event.Location.t = let instruction_pointer = Util.int64_of_hex_string instruction_pointer in - let symbol, symbol_offset, dso = + let #(symbol, symbol_offset, dso) = parse_symbol_and_offset_and_dso ?perf_maps pid @@ -230,14 +230,14 @@ let parse_perf_branches_event ?perf_maps (thread : Event.Thread.t) time line : E |] -> let src_instruction_pointer = Util.int64_of_hex_string src_instruction_pointer in let dst_instruction_pointer = Util.int64_of_hex_string dst_instruction_pointer in - let src_symbol, src_symbol_offset, src_dso = + let #(src_symbol, src_symbol_offset, src_dso) = parse_symbol_and_offset_and_dso ?perf_maps thread.pid src_symbol_and_offset ~addr:src_instruction_pointer in - let dst_symbol, dst_symbol_offset, dst_dso = + let #(dst_symbol, dst_symbol_offset, dst_dso) = parse_symbol_and_offset_and_dso ?perf_maps thread.pid From ca429b32e796e100775f4cca1ec62452979ca382 Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 27 Apr 2026 10:52:53 -0400 Subject: [PATCH 12/30] Remove dead code from `Nonempty_vec` Signed-off-by: Kevin Svetlitski --- src/nonempty_vec.ml | 3 +-- src/nonempty_vec.mli | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/nonempty_vec.ml b/src/nonempty_vec.ml index c3b7e1c34..f41c6b7c2 100644 --- a/src/nonempty_vec.ml +++ b/src/nonempty_vec.ml @@ -1,6 +1,6 @@ open! Core -module%template [@kind k = (value, value & value, value & value & value)] T = struct +module%template [@kind k = (value & value, value & value & value)] T = struct type ('a : k) t = ('a Vec.t[@kind k]) let create x = @@ -28,6 +28,5 @@ module%template [@kind k = (value, value & value, value & value & value)] T = st ;; end -module Value = T [@kind value] module Valuex2 = T [@kind value & value] module Valuex3 = T [@kind value & value & value] diff --git a/src/nonempty_vec.mli b/src/nonempty_vec.mli index e3b2e7223..259c3ebb5 100644 --- a/src/nonempty_vec.mli +++ b/src/nonempty_vec.mli @@ -1,6 +1,6 @@ open! Core -module type%template [@kind k = (value, value & value, value & value & value)] S := sig +module type%template [@kind k = (value & value, value & value & value)] S := sig (** A [Vec.t] guaranteed to contain at least one element. *) type ('a : k) t @@ -15,6 +15,5 @@ module type%template [@kind k = (value, value & value, value & value & value)] S val iter_pairs : 'a t -> f:local_ (#('a * 'a) -> unit) -> unit end -module Value : S [@kind value] module Valuex2 : S [@kind value & value] module Valuex3 : S [@kind value & value & value] From 489d06e873f2fe79650ca220b41db33131d7f5cd Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 27 Apr 2026 10:54:54 -0400 Subject: [PATCH 13/30] Make `LLvm_symbolizer.t` type abstract Signed-off-by: Kevin Svetlitski --- src/symbolizer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/symbolizer.ml b/src/symbolizer.ml index ce5cf4565..ce963c1ce 100644 --- a/src/symbolizer.ml +++ b/src/symbolizer.ml @@ -42,7 +42,7 @@ module Response = struct end module Llvm_symbolizer = struct - type t = Iptr.t + type t : word external create : unit From 69ed37d3c02d7bf875d44d54df04ef72903e673f Mon Sep 17 00:00:00 2001 From: Kevin Svetlitski Date: Mon, 27 Apr 2026 12:22:41 -0400 Subject: [PATCH 14/30] Make traces smaller by omitting most additional per-slice information Signed-off-by: Kevin Svetlitski --- src/trace_segment.ml | 50 ++++++++------------------------------------ 1 file changed, 9 insertions(+), 41 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 7ab12ff08..187268063 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -984,54 +984,22 @@ end = struct } ;; - (* TODO We should probably scrap Owee entirely and get this information directly from - LLVM instead given that we're already using it to resolve inlined frames. *) - let location_args debug_info (location : Location.t) = - let display_name = Symbol.display_name location.symbol in - let base_address = - Int64.(location.instruction_pointer - of_int location.symbol_offset) - in - let open Tracing.Trace.Arg in - (* Using [Interned] may cause some issues with the 32k interned string limit, on - sufficiently large programs if the trace goes through a lot of different code, - but that'll also be a problem with the span names. This will just make it - happen around twice as fast. It does make the traces noticeably smaller. - - The real solution is to get around to improving the interning table management - in the trace writer library. - - --- - - [base_address] might be lie in the kernel, in which case [to_int] will fail (but - that's alright, because we wouldn't have a symbol for it in the executable's - [debug_info] anyway). *) - let address = "address", Pointer location.instruction_pointer in - match location.symbol with - | From_perf_map { start_addr = _; size = _; function_ = _ } -> - address :: [ "symbol", Interned display_name ] - | _ -> - (match Option.bind (Int64.to_int base_address) ~f:(Hashtbl.find debug_info) with - | None -> address :: [ "symbol", Interned display_name ] - | Some (info : Elf.Location.t) -> - (address - :: [ "line", Int info.line - ; "col", Int info.col - ; "symbol", Interned display_name - ]) - @ - (match info.filename with - | Some x -> [ "file", Interned x ] - | None -> [])) - ;; - let emit_frame_enter (local_ (t : _ t)) (time : Timestamp.t) (frame : Frame.t) = let location = frame.location in assert (Timestamp.( >= ) time t.last_time); t.last_time <- time; Vec.push_back t.active_frames location.symbol; if debug then eprintf "Enter %s\n" (Symbol.display_name location.symbol); + (* TODO In the future we can surface more detailed information in [args] + (e.g. filename, line number, etc.) since LLVM can easily provide it to us, + but for now we omit it given that the traces are already huge. *) + let args : Tracing.Trace.Arg.t list = + match frame.kind with + | Inlined -> [] + | Physical -> [ "address", Pointer location.instruction_pointer ] + in t.write_duration_begin - ~args:(location_args t.debug_info location) + ~args ~name:(Symbol.display_name location.symbol) ~time:(time :> Time_ns.Span.t) ;; From 1167449b7a002e4c4cf086b93f37054ae6d75b37 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 6 May 2026 11:43:16 -0400 Subject: [PATCH 15/30] fix 0 payload --- src/perf_decode.ml | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/src/perf_decode.ml b/src/perf_decode.ml index a8cce32b3..27b6129ac 100644 --- a/src/perf_decode.ml +++ b/src/perf_decode.ml @@ -31,7 +31,7 @@ let perf_cbr_event_re = let perf_ptwrite_event_re = Re.Perl.re - {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +(0x[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} + {|^ *(call|return|tr strt|syscall|sysret|hw int|iret|int|tx abrt|tr end|tr strt tr end|tr end (?:async|call|return|syscall|sysret|iret)|jmp|jcc)? +IP: +([0-9a-f]+) +payload: +((?:0x)?[0-9a-f]+) (.*) ([0-9]+) +([0-9a-f]+) (.*)$|} |> Re.compile ;; @@ -804,9 +804,10 @@ module%test _ = struct {| 2769074/2769293 2592496.569782106: 1 ptwrite: call IP: 0 payload: 0x1b5 0 55c7952ad2d0 [unknown] (foo.bin)|}; [%expect {| - ((Ok - ((thread ((pid (2769074)) (tid (2769293)))) (time 30d8m16.569782106s) - (data (Ptwrite (location 0x55c7952ad2d0) (data 0x1b5)))))) |}] + ((Ok + ((thread ((pid (2769074)) (tid (2769293)))) (time 30d8m16.569782106s) + (data (Ptwrite (location 0x55c7952ad2d0) (data 0x1b5)))))) + |}] ;; let%expect_test "perf ptwrite event with printable payload" = @@ -814,9 +815,10 @@ module%test _ = struct {|2817453/2817483 2596547.813541321: 1 ptwrite: call IP: 0 payload: 0x62 b 0 613d946b42d0 [unknown] (foo.bin)|}; [%expect {| - ((Ok - ((thread ((pid (2817453)) (tid (2817483)))) (time 30d1h15m47.813541321s) - (data (Ptwrite (location 0x613d946b42d0) (data 0x62)))))) |}] + ((Ok + ((thread ((pid (2817453)) (tid (2817483)))) (time 30d1h15m47.813541321s) + (data (Ptwrite (location 0x613d946b42d0) (data 0x62)))))) + |}] ;; let%expect_test "perf ptwrite event with jcc instruction" = @@ -826,7 +828,8 @@ module%test _ = struct {| ((Ok ((thread ((pid (3256341)) (tid (3256760)))) (time 30d11h19m6.069047397s) - (data (Ptwrite (location 0x577bcad80555) (data 0x5000000000061b2)))))) |}] + (data (Ptwrite (location 0x577bcad80555) (data 0x5000000000061b2)))))) + |}] ;; let%expect_test "perf ptwrite event without instruction" = @@ -836,7 +839,19 @@ module%test _ = struct {| ((Ok ((thread ((pid (3285832)) (tid (3286108)))) (time 30d11h51m6.172476558s) - (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) |}] + (data (Ptwrite (location 0x64d20fb10432) (data 0xa00000000000000)))))) + |}] + ;; + + let%expect_test "perf ptwrite event zero payload" = + check + {|997136/997136 340026.788189283: 1 ptwrite: jcc IP: 0 payload: 0 0 64d20fb10432 [unknown] (foo.bin)|}; + [%expect + {| + ((Ok + ((thread ((pid (997136)) (tid (997136)))) (time 3d22h27m6.788189283s) + (data (Ptwrite (location 0x64d20fb10432) (data 0)))))) + |}] ;; end From 3bc6ab78de751b63ccfee0dc76c1f8cc237e8f9d Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 6 May 2026 18:55:24 -0400 Subject: [PATCH 16/30] fibers --- src/new_trace_writer.ml | 78 +++++++++++++++++++++++++++++----------- src/real_trace.ml | 10 ++++++ src/trace.ml | 6 ++++ src/trace_segment.ml | 55 ++++++++++++++++++---------- src/trace_segment.mli | 2 ++ src/trace_writer_intf.ml | 6 ++++ test/perf_script.ml | 6 ++++ 7 files changed, 125 insertions(+), 38 deletions(-) diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index 2cad79fe4..648b187e7 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -172,6 +172,7 @@ type 'thread inner = ; annotate_inferred_start_times : bool ; mutable in_filtered_region : bool ; mutable transaction_events : Event.With_write_info.t Deque.t + ; pending_flows : ('thread -> Time_ns.Span.t -> unit) Hashtbl.M(Int).t } type t = T : 'thread inner -> t @@ -341,6 +342,7 @@ let create_expert ; annotate_inferred_start_times ; in_filtered_region = true ; transaction_events = Deque.create () + ; pending_flows = Hashtbl.create (module Int) } in write_hits t hits; @@ -964,35 +966,71 @@ and write_event' (T t) ?events_writer event = List.iter calls ~f:(fun location -> call t thread_info ~time ~location) | { Event.Ok.thread = _ ; time = _ - ; data = Trace { kind = _; trace_state_change = _; src = _; dst = _ } + ; data = Trace { kind; trace_state_change = _; src; dst } ; in_transaction = _ } -> (* TODO Re-add the assertion from the old trace-writer on impossible [kind, trace_state_change] combinations *) Thread_info.add_event_to_trace_segment thread_info event_value.data - (time :> Time_ns.Span.t) + (time :> Time_ns.Span.t); + let #(segment, ~in_filtered_region:_) = + Nonempty_vec.last thread_info.trace_segments + in + (match kind with + | Some (Call | Jump | Async) -> + (match Symbol.display_name dst.symbol with + | "caml_runstack" | "caml_resume" -> Trace_segment.push_fiber_state segment + | _ -> ()) + | Some (Return | Sysret | Iret) -> + (match Symbol.display_name src.symbol with + | "caml_runstack" | "caml_resume" | "caml_perform" -> + Trace_segment.pop_fiber_state segment + | _ -> ()) + | _ -> ()) | { Event.Ok.thread = _ (* Already used this to look up thread info. *) ; time = _ ; data = Ptwrite { location; data } ; in_transaction = _ } -> - let args = - Tracing.Trace.Arg.( - List.concat - [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] - ; [ "symbol", String (Symbol.display_name location.symbol) ] - ; [ "addr", Pointer location.instruction_pointer ] - ; [ "data", String data ] - ; Option.value_map - (Event.thread outer_event).pid - ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) - ~default:[] - ; Option.value_map - (Event.thread outer_event).tid - ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) - ~default:[] - ]) - in - write_duration_complete t ~thread ~args ~name:"PTWRITE" ~time ~time_end:time) + let symbol_name = Symbol.display_name location.symbol in + let is_perform = String.equal symbol_name "caml_perform" in + let is_resume = String.equal symbol_name "caml_resume" in + if is_perform || is_resume + then ( + let fiber_id = Int64.to_int_trunc (Int64.of_string data) in + let name = if is_perform then "Perform Effect" else "Resume Continuation" in + let args = Tracing.Trace.Arg.[ "fiber", String (sprintf "0x%x" fiber_id) ] in + write_duration_complete t ~thread ~args ~name ~time ~time_end:time; + if is_perform + then ( + let module T = (val t.trace) in + let flow = T.create_flow () in + T.write_flow_step flow ~thread ~time:(time :> Time_ns.Span.t); + Hashtbl.set t.pending_flows ~key:fiber_id ~data:(fun thread time -> + T.write_flow_step flow ~thread ~time; + T.finish_flow flow)) + else ( + match Hashtbl.find_and_remove t.pending_flows fiber_id with + | Some finish -> finish thread (time :> Time_ns.Span.t) + | None -> ())) + else ( + let args = + Tracing.Trace.Arg.( + List.concat + [ [ "timestamp", Int (Time_ns.Span.to_int_ns (time :> Time_ns.Span.t)) ] + ; [ "symbol", String symbol_name ] + ; [ "addr", Pointer location.instruction_pointer ] + ; [ "data", String data ] + ; Option.value_map + (Event.thread outer_event).pid + ~f:(fun pid -> [ "pid", Int (Pid.to_int pid) ]) + ~default:[] + ; Option.value_map + (Event.thread outer_event).tid + ~f:(fun tid -> [ "tid", Int (Pid.to_int tid) ]) + ~default:[] + ]) + in + write_duration_complete t ~thread ~args ~name:"PTWRITE" ~time ~time_end:time)) ;; diff --git a/src/real_trace.ml b/src/real_trace.ml index 09801ca5d..ba3015c10 100644 --- a/src/real_trace.ml +++ b/src/real_trace.ml @@ -12,6 +12,16 @@ let create (trace : Tracing.Trace.t) = let write_duration_complete = Tracing.Trace.write_duration_complete trace ~category:"" let write_duration_instant = Tracing.Trace.write_duration_instant trace ~category:"" let write_counter = Tracing.Trace.write_counter trace ~category:"" + + type flow = Tracing.Flow.t + + let create_flow () = Tracing.Trace.create_flow trace + + let write_flow_step flow ~thread ~time = + Tracing.Trace.write_flow_step trace flow ~thread ~time + ;; + + let finish_flow flow = Tracing.Trace.finish_flow trace flow end in (module T : S_trace with type thread = Tracing.Trace.Thread.t) diff --git a/src/trace.ml b/src/trace.ml index 6a5ac2124..397a2515d 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -84,6 +84,12 @@ module Null_writer : Trace_writer_intf.S_trace = struct let write_duration_complete ~args:_ ~thread:_ ~name:_ ~time:_ ~time_end:_ : unit = () let write_duration_instant ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () let write_counter ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () + + type flow = unit + + let create_flow () = () + let write_flow_step () ~thread:_ ~time:_ = () + let finish_flow () = () end let write_trace_from_events diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 71fb66a2f..2f6fe1fc2 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -333,7 +333,7 @@ type t = frames, starting from the [leaf] of the callstack immediately preceding it. *) ; symbolizer : Symbolizer.t ; ocaml_exception_info : Ocaml_exception_info.t or_null - ; exception_handlers : Frame.t Vec.t + ; mutable exception_handlers : Frame.t Vec.t (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -342,9 +342,18 @@ type t = later examination — [exception_handlers] represents the state **as of the event we are currently processing**, and as such is only used during the "ingestion" phase (i.e. while calls are still being made to [add_event]). *) + ; saved_fiber_state : (Frame.t Vec.t * Location.t) Stack.t ; mutable last_known_location : Location.t } +let unknown_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; instruction_pointer = Int64.max_value + ; dso = Interned_string.empty + } +;; + let create ocaml_exception_info = let root = Frame.Sentinel.create () in { root @@ -358,13 +367,9 @@ let create ocaml_exception_info = : Callstack.t) ; symbolizer = Symbolizer.create () ; exception_handlers = Vec.create () + ; saved_fiber_state = Stack.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info - ; last_known_location : Location.t = - { symbol = Unknown - ; symbol_offset = 0 - ; instruction_pointer = Int64.max_value - ; dso = Interned_string.empty - } + ; last_known_location = unknown_location } ;; @@ -378,6 +383,20 @@ let create_continuing_from existing = } ;; +let push_fiber_state t = + Stack.push t.saved_fiber_state (t.exception_handlers, t.last_known_location); + t.exception_handlers <- Vec.create (); + t.last_known_location <- unknown_location +;; + +let pop_fiber_state t = + match Stack.pop t.saved_fiber_state with + | Some (saved_handlers, saved_location) -> + t.exception_handlers <- saved_handlers; + t.last_known_location <- saved_location + | None -> () +;; + let[@inline always] current_frame t = (Nonempty_vec.last t.callstacks).#leaf let[@inline always] current_physical_frame t = Frame.find_first_physical (current_frame t) @@ -646,12 +665,9 @@ let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* Our [parent_frame] is the sentinel. *) return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) | #(Null, ~physical_distance:_, ..) -> - log_unexpected_case - [%message "return [dst] does not match known trace state." (dst : Location.t)]; - (* Something is probably wrong if we ever make it to this case, where the state - we're maintaining and the event we are processing seem to completely disagree. - Treating it like a tail-call seems like the least bad option, and at the very - least gets us to agree with the event stream that the current frame is [dst]. *) + (* This case is reachable after resuming a fiber that was detached from its parent. + Treating it like a tail-call gets us to agree with the event stream that the + current frame is [dst]. *) Nonempty_vec.push_back t.callstacks #{ time @@ -766,11 +782,14 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = [Call], because discovered roots are handled separately. *) ~physical_frame_is_new:false | #(This dst_frame, ~distance, ~leaf_of_inlined_stack, ..) -> - log_unexpected_case - [%message - "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ - no active exception handler, but a frame with a matching symbol was found." - (dst : Location.t)]; + (* This case is reachable after entering a fiber, which redirects all exceptions through a dynamic handler. *) + if Stack.is_empty t.saved_fiber_state + then + log_unexpected_case + [%message + "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ + no active exception handler, but a frame with a matching symbol was found." + (dst : Location.t)]; (match leaf_of_inlined_stack with | #(Null, _) -> Frame.set_instruction_pointer dst_frame dst.instruction_pointer; diff --git a/src/trace_segment.mli b/src/trace_segment.mli index 0cf99ca19..26197af5d 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -11,6 +11,8 @@ val create : Ocaml_exception_info.t option -> t val create_continuing_from : t -> t val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit +val push_fiber_state : t -> unit +val pop_fiber_state : t -> unit val write_trace : t diff --git a/src/trace_writer_intf.ml b/src/trace_writer_intf.ml index aef6a6d3e..2e4c2d297 100644 --- a/src/trace_writer_intf.ml +++ b/src/trace_writer_intf.ml @@ -41,4 +41,10 @@ module type S_trace = sig -> name:string -> time:Time_ns.Span.t -> unit + + type flow + + val create_flow : unit -> flow + val write_flow_step : flow -> thread:thread -> time:Time_ns.Span.t -> unit + val finish_flow : flow -> unit end diff --git a/test/perf_script.ml b/test/perf_script.ml index f64161a88..6d60393c5 100644 --- a/test/perf_script.ml +++ b/test/perf_script.ml @@ -45,6 +45,12 @@ let run ?(debug = false) ?events_writer ?ocaml_exception_info ~trace_scope file ;; let write_counter ~args:_ ~thread:_ ~name:_ ~time:_ : unit = () + + type flow = unit + + let create_flow () = () + let write_flow_step () ~thread:_ ~time:_ = () + let finish_flow () = () end in Magic_trace_lib.Trace_writer.debug := debug; From 7f16363d717bd73d0f37467d814d9ac843dbec62 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 13:49:18 -0400 Subject: [PATCH 17/30] revert state changes --- src/new_trace_writer.ml | 18 ++------------ src/trace_segment.ml | 55 ++++++++++++++--------------------------- src/trace_segment.mli | 2 -- 3 files changed, 20 insertions(+), 55 deletions(-) diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index 648b187e7..0fc0e0dd1 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -966,28 +966,14 @@ and write_event' (T t) ?events_writer event = List.iter calls ~f:(fun location -> call t thread_info ~time ~location) | { Event.Ok.thread = _ ; time = _ - ; data = Trace { kind; trace_state_change = _; src; dst } + ; data = Trace { kind = _; trace_state_change = _; src = _; dst = _ } ; in_transaction = _ } -> (* TODO Re-add the assertion from the old trace-writer on impossible [kind, trace_state_change] combinations *) Thread_info.add_event_to_trace_segment thread_info event_value.data - (time :> Time_ns.Span.t); - let #(segment, ~in_filtered_region:_) = - Nonempty_vec.last thread_info.trace_segments - in - (match kind with - | Some (Call | Jump | Async) -> - (match Symbol.display_name dst.symbol with - | "caml_runstack" | "caml_resume" -> Trace_segment.push_fiber_state segment - | _ -> ()) - | Some (Return | Sysret | Iret) -> - (match Symbol.display_name src.symbol with - | "caml_runstack" | "caml_resume" | "caml_perform" -> - Trace_segment.pop_fiber_state segment - | _ -> ()) - | _ -> ()) + (time :> Time_ns.Span.t) | { Event.Ok.thread = _ (* Already used this to look up thread info. *) ; time = _ ; data = Ptwrite { location; data } diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 2f6fe1fc2..71fb66a2f 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -333,7 +333,7 @@ type t = frames, starting from the [leaf] of the callstack immediately preceding it. *) ; symbolizer : Symbolizer.t ; ocaml_exception_info : Ocaml_exception_info.t or_null - ; mutable exception_handlers : Frame.t Vec.t + ; exception_handlers : Frame.t Vec.t (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -342,18 +342,9 @@ type t = later examination — [exception_handlers] represents the state **as of the event we are currently processing**, and as such is only used during the "ingestion" phase (i.e. while calls are still being made to [add_event]). *) - ; saved_fiber_state : (Frame.t Vec.t * Location.t) Stack.t ; mutable last_known_location : Location.t } -let unknown_location : Location.t = - { symbol = Unknown - ; symbol_offset = 0 - ; instruction_pointer = Int64.max_value - ; dso = Interned_string.empty - } -;; - let create ocaml_exception_info = let root = Frame.Sentinel.create () in { root @@ -367,9 +358,13 @@ let create ocaml_exception_info = : Callstack.t) ; symbolizer = Symbolizer.create () ; exception_handlers = Vec.create () - ; saved_fiber_state = Stack.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info - ; last_known_location = unknown_location + ; last_known_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; instruction_pointer = Int64.max_value + ; dso = Interned_string.empty + } } ;; @@ -383,20 +378,6 @@ let create_continuing_from existing = } ;; -let push_fiber_state t = - Stack.push t.saved_fiber_state (t.exception_handlers, t.last_known_location); - t.exception_handlers <- Vec.create (); - t.last_known_location <- unknown_location -;; - -let pop_fiber_state t = - match Stack.pop t.saved_fiber_state with - | Some (saved_handlers, saved_location) -> - t.exception_handlers <- saved_handlers; - t.last_known_location <- saved_location - | None -> () -;; - let[@inline always] current_frame t = (Nonempty_vec.last t.callstacks).#leaf let[@inline always] current_physical_frame t = Frame.find_first_physical (current_frame t) @@ -665,9 +646,12 @@ let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* Our [parent_frame] is the sentinel. *) return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) | #(Null, ~physical_distance:_, ..) -> - (* This case is reachable after resuming a fiber that was detached from its parent. - Treating it like a tail-call gets us to agree with the event stream that the - current frame is [dst]. *) + log_unexpected_case + [%message "return [dst] does not match known trace state." (dst : Location.t)]; + (* Something is probably wrong if we ever make it to this case, where the state + we're maintaining and the event we are processing seem to completely disagree. + Treating it like a tail-call seems like the least bad option, and at the very + least gets us to agree with the event stream that the current frame is [dst]. *) Nonempty_vec.push_back t.callstacks #{ time @@ -782,14 +766,11 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = [Call], because discovered roots are handled separately. *) ~physical_frame_is_new:false | #(This dst_frame, ~distance, ~leaf_of_inlined_stack, ..) -> - (* This case is reachable after entering a fiber, which redirects all exceptions through a dynamic handler. *) - if Stack.is_empty t.saved_fiber_state - then - log_unexpected_case - [%message - "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ - no active exception handler, but a frame with a matching symbol was found." - (dst : Location.t)]; + log_unexpected_case + [%message + "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ + no active exception handler, but a frame with a matching symbol was found." + (dst : Location.t)]; (match leaf_of_inlined_stack with | #(Null, _) -> Frame.set_instruction_pointer dst_frame dst.instruction_pointer; diff --git a/src/trace_segment.mli b/src/trace_segment.mli index 26197af5d..0cf99ca19 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -11,8 +11,6 @@ val create : Ocaml_exception_info.t option -> t val create_continuing_from : t -> t val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit -val push_fiber_state : t -> unit -val pop_fiber_state : t -> unit val write_trace : t From fad147b08f2b9bf5586cb76ede39bcef2738820b Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 15:31:36 -0400 Subject: [PATCH 18/30] respect exn handler in runstack --- src/trace_segment.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 71fb66a2f..ba64aaba9 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -695,14 +695,20 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = match t.ocaml_exception_info with | Null -> false | This ocaml_exception_info -> - Ocaml_exception_info.is_entertrap ocaml_exception_info ~addr:dst.instruction_pointer + (match Symbol.display_name dst.symbol, dst.symbol_offset with + | "caml_runstack", 0x13d -> true + | _ -> + Ocaml_exception_info.is_entertrap + ocaml_exception_info + ~addr:dst.instruction_pointer) ;; let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with | This dst_frame -> Vec.pop_back_unit_exn t.exception_handlers; - assert (Symbol.equal dst_frame.location.symbol dst.symbol); + if not (Symbol.equal dst_frame.location.symbol dst.symbol) + then log_unexpected_case [%message (dst_frame : Frame.t) (dst : Location.t)]; (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) @@ -855,6 +861,10 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = (match t.ocaml_exception_info with | Null -> () | This ocaml_exception_info -> + (match Symbol.display_name src.symbol, src.symbol_offset with + | "caml_runstack", 0xa9 -> + Vec.push_back t.exception_handlers current_physical_frame + | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info ~from:t.last_known_location.instruction_pointer From 256067715af762d414b45515b51af7db8c67d985 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 15:36:24 -0400 Subject: [PATCH 19/30] restore assert --- src/trace_segment.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index ba64aaba9..eef0605c5 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -707,8 +707,7 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with | This dst_frame -> Vec.pop_back_unit_exn t.exception_handlers; - if not (Symbol.equal dst_frame.location.symbol dst.symbol) - then log_unexpected_case [%message (dst_frame : Frame.t) (dst : Location.t)]; + assert (Symbol.equal dst_frame.location.symbol dst.symbol); (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) From 45a830fc23d38ba5cd26f4acbbcb0690b4a52e7a Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 15:40:30 -0400 Subject: [PATCH 20/30] poptrap --- src/trace_segment.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index eef0605c5..7cabbef49 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -863,6 +863,7 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = (match Symbol.display_name src.symbol, src.symbol_offset with | "caml_runstack", 0xa9 -> Vec.push_back t.exception_handlers current_physical_frame + | "caml_runstack", 0x13b -> Vec.pop_back_unit_exn t.exception_handlers | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info From 90b85bf82d7cea75414be8a8255e9e5b1edabe3e Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 16:40:37 -0400 Subject: [PATCH 21/30] perform --- src/trace_segment.ml | 94 +++++++++++++++++++++++++++++--------------- 1 file changed, 62 insertions(+), 32 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 7cabbef49..e6f22cd02 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -334,6 +334,7 @@ type t = ; symbolizer : Symbolizer.t ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t + ; effect_handlers : Frame.t Vec.t (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -345,6 +346,14 @@ type t = ; mutable last_known_location : Location.t } +let unknown_location : Location.t = + { symbol = Unknown + ; symbol_offset = 0 + ; instruction_pointer = Int64.max_value + ; dso = Interned_string.empty + } +;; + let create ocaml_exception_info = let root = Frame.Sentinel.create () in { root @@ -358,13 +367,9 @@ let create ocaml_exception_info = : Callstack.t) ; symbolizer = Symbolizer.create () ; exception_handlers = Vec.create () + ; effect_handlers = Vec.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info - ; last_known_location : Location.t = - { symbol = Unknown - ; symbol_offset = 0 - ; instruction_pointer = Int64.max_value - ; dso = Interned_string.empty - } + ; last_known_location = unknown_location } ;; @@ -375,6 +380,7 @@ let create_continuing_from existing = Nonempty_vec.create (#{ last_callstack with control_flow = Return { distance = 0 } } : Callstack.t) ; exception_handlers = Vec.copy existing.exception_handlers + ; effect_handlers = Vec.copy existing.effect_handlers } ;; @@ -703,6 +709,37 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = ~addr:dst.instruction_pointer) ;; +let return_to_handler + t + time + ~(dst : Location.t) + ~dst_frame + ~distance + ~leaf_of_inlined_stack + = + match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer +;; + let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with | This dst_frame -> @@ -711,31 +748,7 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) - (match leaf_of_inlined_stack with - | #(Null, _) -> - Frame.set_instruction_pointer dst_frame dst.instruction_pointer; - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = dst_frame; control_flow = Return { distance } }; - append_inlined_frames - t - time - ~physical_frame:dst_frame - ~physical_frame_is_new:false - | #(This inlined_leaf, inlined_leaf_distance) -> - Nonempty_vec.push_back - t.callstacks - #{ time - ; leaf = inlined_leaf - ; control_flow = Return { distance = inlined_leaf_distance } - }; - diff_inlined_frames - t - time - ~dso:dst.dso - ~before:dst_frame.instruction_pointer - ~after:dst.instruction_pointer; - Frame.set_instruction_pointer dst_frame dst.instruction_pointer) + return_to_handler t time ~dst ~dst_frame ~distance ~leaf_of_inlined_stack | #(~distance:Null, ..) -> let message = match Frame.find (current_frame t) dst.symbol with @@ -862,8 +875,25 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | This ocaml_exception_info -> (match Symbol.display_name src.symbol, src.symbol_offset with | "caml_runstack", 0xa9 -> + Vec.push_back t.effect_handlers current_physical_frame; Vec.push_back t.exception_handlers current_physical_frame - | "caml_runstack", 0x13b -> Vec.pop_back_unit_exn t.exception_handlers + | "caml_runstack", 0x13b -> + Vec.pop_back_unit_exn t.effect_handlers; + Vec.pop_back_unit_exn t.exception_handlers + | "caml_perform", 0xb5 -> + (* CR mslater: deal with exn handlers *) + let handler = Vec.pop_back_exn t.effect_handlers in + (match Frame.find_ancestor (current_frame t) ~ancestor:handler with + | #(~distance:(This distance), ~leaf_of_inlined_stack) -> + print_s [%message "found" (distance : int)]; + return_to_handler + t + time + ~dst + ~dst_frame:handler + ~distance + ~leaf_of_inlined_stack + | _ -> assert false) | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info From 1f01a20dcc63c9cb621ffe94eacc20f96c708ebf Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 16:47:36 -0400 Subject: [PATCH 22/30] pop exns --- src/trace_segment.ml | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index e6f22cd02..421c29561 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -334,7 +334,7 @@ type t = ; symbolizer : Symbolizer.t ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t - ; effect_handlers : Frame.t Vec.t + ; effect_handlers : (Frame.t * exn_depth:int) Vec.t (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -744,7 +744,13 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with | This dst_frame -> Vec.pop_back_unit_exn t.exception_handlers; - assert (Symbol.equal dst_frame.location.symbol dst.symbol); + if not (Symbol.equal dst_frame.location.symbol dst.symbol) + then + log_unexpected_case + [%message + "Mismatched handler and destination:" + (dst_frame.location.symbol : Symbol.t) + (dst.symbol : Symbol.t)]; (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) @@ -875,14 +881,18 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | This ocaml_exception_info -> (match Symbol.display_name src.symbol, src.symbol_offset with | "caml_runstack", 0xa9 -> - Vec.push_back t.effect_handlers current_physical_frame; + Vec.push_back + t.effect_handlers + (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); Vec.push_back t.exception_handlers current_physical_frame | "caml_runstack", 0x13b -> Vec.pop_back_unit_exn t.effect_handlers; Vec.pop_back_unit_exn t.exception_handlers | "caml_perform", 0xb5 -> - (* CR mslater: deal with exn handlers *) - let handler = Vec.pop_back_exn t.effect_handlers in + let handler, ~exn_depth = Vec.pop_back_exn t.effect_handlers in + while Vec.length t.exception_handlers > exn_depth do + Vec.pop_back_unit_exn t.exception_handlers + done; (match Frame.find_ancestor (current_frame t) ~ancestor:handler with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> print_s [%message "found" (distance : int)]; From 187603143d6413e253ff3223874ea7cc6dc08633 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 16:53:23 -0400 Subject: [PATCH 23/30] dup handle --- src/trace_segment.ml | 186 +++++++++++++++++++++++++++++++------------ 1 file changed, 137 insertions(+), 49 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 421c29561..7d53441f5 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -709,37 +709,6 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = ~addr:dst.instruction_pointer) ;; -let return_to_handler - t - time - ~(dst : Location.t) - ~dst_frame - ~distance - ~leaf_of_inlined_stack - = - match leaf_of_inlined_stack with - | #(Null, _) -> - Frame.set_instruction_pointer dst_frame dst.instruction_pointer; - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = dst_frame; control_flow = Return { distance } }; - append_inlined_frames t time ~physical_frame:dst_frame ~physical_frame_is_new:false - | #(This inlined_leaf, inlined_leaf_distance) -> - Nonempty_vec.push_back - t.callstacks - #{ time - ; leaf = inlined_leaf - ; control_flow = Return { distance = inlined_leaf_distance } - }; - diff_inlined_frames - t - time - ~dso:dst.dso - ~before:dst_frame.instruction_pointer - ~after:dst.instruction_pointer; - Frame.set_instruction_pointer dst_frame dst.instruction_pointer -;; - let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = match Vec.last t.exception_handlers with | This dst_frame -> @@ -748,13 +717,37 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = then log_unexpected_case [%message - "Mismatched handler and destination:" + "Mismatched handler and dst" (dst_frame.location.symbol : Symbol.t) (dst.symbol : Symbol.t)]; (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) - return_to_handler t time ~dst ~dst_frame ~distance ~leaf_of_inlined_stack + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer) | #(~distance:Null, ..) -> let message = match Frame.find (current_frame t) dst.symbol with @@ -822,6 +815,116 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) ;; +(* CR mslater: dedup *) +let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = + match Vec.last t.effect_handlers with + | This (dst_frame, ~exn_depth) -> + Vec.pop_back_unit_exn t.effect_handlers; + while Vec.length t.exception_handlers > exn_depth do + Vec.pop_back_unit_exn t.exception_handlers + done; + if not (Symbol.equal dst_frame.location.symbol dst.symbol) + then + log_unexpected_case + [%message + "Mismatched handler and dst" + (dst_frame.location.symbol : Symbol.t) + (dst.symbol : Symbol.t)]; + (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with + | #(~distance:(This distance), ~leaf_of_inlined_stack) -> + (* This is the happy case where our exception handler tracking is working as expected. *) + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer) + | #(~distance:Null, ..) -> + let message = + match Frame.find (current_frame t) dst.symbol with + | #(Null, ..) -> "This is likely to be a bug." + | #(This _, ..) -> + "This is deeply concerning because another frame with a matching symbol was \ + found. This is very likely to be a bug." + in + log_unexpected_case + [%message + [%string + "[effect_handlers] appears to be out-of-sync with [callstacks]; active \ + exception handler was not found in [callstacks]. %{message}"] + (dst : Location.t)]; + (* TODO Decide if maybe we should just raise in this case? The trace is probably going to be pretty broken if we make it here. *) + handle_return t time ~dst) + | Null -> + (match Frame.find (current_frame t) dst.symbol with + | #(Null, ~distance, ..) -> + (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) + let dst_frame = replace_root t dst ~kind:Physical in + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + (* Unlike [handle_return] we do *not* make the inlined frames at [dst] (or [dst.instruction_pointer - 1]) + the parents of the existing frames. The rationale is that unlike [handle_return], we have no idea + where we might've been within the frame for [dst] that we just inferred. *) + append_inlined_frames + t + time + ~physical_frame:dst_frame + (* This is subtle; Yes the frame is new, but we *don't* want to reflect that in a + [Call], because discovered roots are handled separately. *) + ~physical_frame_is_new:false + | #(This dst_frame, ~distance, ~leaf_of_inlined_stack, ..) -> + log_unexpected_case + [%message + "[effect_handlers] appears to be out-of-sync with [callstacks]; there is no \ + active exception handler, but a frame with a matching symbol was found." + (dst : Location.t)]; + (match leaf_of_inlined_stack with + | #(Null, _) -> + Frame.set_instruction_pointer dst_frame dst.instruction_pointer; + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = dst_frame; control_flow = Return { distance } }; + append_inlined_frames + t + time + ~physical_frame:dst_frame + ~physical_frame_is_new:false + | #(This inlined_leaf, inlined_leaf_distance) -> + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = inlined_leaf + ; control_flow = Return { distance = inlined_leaf_distance } + }; + diff_inlined_frames + t + time + ~dso:dst.dso + ~before:dst_frame.instruction_pointer + ~after:dst.instruction_pointer; + Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) +;; + let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = match event with | Trace { kind; src; dst; trace_state_change } -> @@ -888,22 +991,7 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | "caml_runstack", 0x13b -> Vec.pop_back_unit_exn t.effect_handlers; Vec.pop_back_unit_exn t.exception_handlers - | "caml_perform", 0xb5 -> - let handler, ~exn_depth = Vec.pop_back_exn t.effect_handlers in - while Vec.length t.exception_handlers > exn_depth do - Vec.pop_back_unit_exn t.exception_handlers - done; - (match Frame.find_ancestor (current_frame t) ~ancestor:handler with - | #(~distance:(This distance), ~leaf_of_inlined_stack) -> - print_s [%message "found" (distance : int)]; - return_to_handler - t - time - ~dst - ~dst_frame:handler - ~distance - ~leaf_of_inlined_stack - | _ -> assert false) + | "caml_perform", 0xb5 -> handle_ocaml_effect t time ~dst | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info From 280cb455f96edf0daf002a6041455e830e59932d Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 17:03:25 -0400 Subject: [PATCH 24/30] push --- src/trace_segment.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 7d53441f5..6eb1b58b6 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -653,7 +653,10 @@ let handle_return (t : t) (time : Timestamp.t) ~(dst : Location.t) = return_to_unseen t time ~dst ~distance:(distance + distance_to_parent_frame) | #(Null, ~physical_distance:_, ..) -> log_unexpected_case - [%message "return [dst] does not match known trace state." (dst : Location.t)]; + [%message + "return [dst] does not match known trace state." + (dst : Location.t) + (dst.symbol : Symbol.t)]; (* Something is probably wrong if we ever make it to this case, where the state we're maintaining and the event we are processing seem to completely disagree. Treating it like a tail-call seems like the least bad option, and at the very @@ -992,6 +995,12 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = Vec.pop_back_unit_exn t.effect_handlers; Vec.pop_back_unit_exn t.exception_handlers | "caml_perform", 0xb5 -> handle_ocaml_effect t time ~dst + | "caml_resume", 0xda -> + Vec.push_back + t.effect_handlers + (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); + (* CR mslater: wrong *) + Vec.push_back t.exception_handlers current_physical_frame | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info From 5cc1fc02d053d79b7de293978b0fd25a910cc4dd Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 7 May 2026 17:14:57 -0400 Subject: [PATCH 25/30] hmm --- src/trace_segment.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 6eb1b58b6..a3af61ea7 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -826,13 +826,8 @@ let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = while Vec.length t.exception_handlers > exn_depth do Vec.pop_back_unit_exn t.exception_handlers done; - if not (Symbol.equal dst_frame.location.symbol dst.symbol) - then - log_unexpected_case - [%message - "Mismatched handler and dst" - (dst_frame.location.symbol : Symbol.t) - (dst.symbol : Symbol.t)]; + (* CR mslater: we should preserve the handler frame *) + (* We expect the handler and dst to be different symbols. *) (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) From 5259ad7c07c9d61c460fe9ff030725cd3879f2fe Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 11 May 2026 16:54:10 -0400 Subject: [PATCH 26/30] progress --- src/trace_segment.ml | 48 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 39 insertions(+), 9 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index a3af61ea7..8f447dd6e 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -292,7 +292,7 @@ end = struct ;; let to_string_list t = to_string_list [] t - let print_callstack leaf = to_string_list leaf |> String.concat_lines |> printf "%s" + let print_callstack leaf = to_string_list leaf |> String.concat_lines |> eprintf "%s" end end @@ -335,6 +335,8 @@ type t = ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t ; effect_handlers : (Frame.t * exn_depth:int) Vec.t + ; saved_exception_handlers : Frame.t Vec.t + ; saved_callstacks : Callstack.t Vec.t__'value_value_value' (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -368,6 +370,8 @@ let create ocaml_exception_info = ; symbolizer = Symbolizer.create () ; exception_handlers = Vec.create () ; effect_handlers = Vec.create () + ; saved_exception_handlers = Vec.create () + ; saved_callstacks = (Vec.create [@kind value & value & value]) () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info ; last_known_location = unknown_location } @@ -820,19 +824,28 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* CR mslater: dedup *) let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = + Vec.clear t.saved_exception_handlers; + (Vec.clear [@kind value & value & value]) t.saved_callstacks; match Vec.last t.effect_handlers with | This (dst_frame, ~exn_depth) -> Vec.pop_back_unit_exn t.effect_handlers; while Vec.length t.exception_handlers > exn_depth do - Vec.pop_back_unit_exn t.exception_handlers + Vec.push_back t.saved_exception_handlers (Vec.pop_back_exn t.exception_handlers) done; - (* CR mslater: we should preserve the handler frame *) (* We expect the handler and dst to be different symbols. *) (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> (* This is the happy case where our exception handler tracking is working as expected. *) (match leaf_of_inlined_stack with | #(Null, _) -> + (Vec.push_back [@kind value & value & value]) + t.saved_callstacks + #{ time + ; leaf = current_frame t + ; control_flow = Call { depth = distance + 1 } + }; + eprint_s [%message "handle_ocaml_effect" (distance : int)]; + Frame.For_testing.print_callstack (current_frame t); Frame.set_instruction_pointer dst_frame dst.instruction_pointer; Nonempty_vec.push_back t.callstacks @@ -985,17 +998,34 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = Vec.push_back t.effect_handlers (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); - Vec.push_back t.exception_handlers current_physical_frame + Vec.push_back t.exception_handlers current_physical_frame; + (Vec.clear [@kind value & value & value]) t.saved_callstacks; + Vec.clear t.saved_exception_handlers | "caml_runstack", 0x13b -> - Vec.pop_back_unit_exn t.effect_handlers; - Vec.pop_back_unit_exn t.exception_handlers + let _, ~exn_depth = Vec.pop_back_exn t.effect_handlers in + while Vec.length t.exception_handlers > exn_depth do + Vec.pop_back_unit_exn t.exception_handlers + done | "caml_perform", 0xb5 -> handle_ocaml_effect t time ~dst | "caml_resume", 0xda -> Vec.push_back t.effect_handlers (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); - (* CR mslater: wrong *) - Vec.push_back t.exception_handlers current_physical_frame + eprint_s + [%message + (Vec.length t.saved_exception_handlers : int) + ((Vec.length [@kind value & value & value]) t.saved_callstacks : int)]; + Vec.iter t.saved_exception_handlers ~f:(fun exn -> + eprint_s [%message "saved_exception_handlers"]; + Frame.For_testing.print_callstack exn; + Vec.push_back t.exception_handlers exn); + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } }; + (Vec.iter [@kind value & value & value]) t.saved_callstacks ~f:(fun cs -> + eprint_s [%message "saved_callstacks"]; + Frame.For_testing.print_callstack cs.#leaf; + Nonempty_vec.push_back t.callstacks #{ cs with time }) | _ -> ()); Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info @@ -1150,7 +1180,7 @@ end = struct let location = frame.location in assert (Timestamp.( >= ) time t.last_time); t.last_time <- time; - [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; + (* [%test_result: Symbol.t] ~expect:(Vec.pop_back_exn t.active_frames) location.symbol; *) if debug then eprintf "Exit %s\n" (Symbol.display_name location.symbol); t.write_duration_end ~args:[] From 63219ee7a4da9169cbdb5d1d0f53ab25ce1c1903 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Mon, 11 May 2026 17:01:15 -0400 Subject: [PATCH 27/30] only return from resume if we saved the stack --- src/trace_segment.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 8f447dd6e..11b527046 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -1019,9 +1019,11 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = eprint_s [%message "saved_exception_handlers"]; Frame.For_testing.print_callstack exn; Vec.push_back t.exception_handlers exn); - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } }; + if (Vec.length [@kind value & value & value]) t.saved_callstacks > 0 + then + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } }; (Vec.iter [@kind value & value & value]) t.saved_callstacks ~f:(fun cs -> eprint_s [%message "saved_callstacks"]; Frame.For_testing.print_callstack cs.#leaf; From c7e596dfd332426e856a6bf325ae950621668019 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 13 May 2026 18:38:37 -0400 Subject: [PATCH 28/30] debugging --- src/new_trace_writer.ml | 26 ++++- src/perf_dlfilter.c | 8 +- src/trace_segment.ml | 234 +++++++++++++++++++++++++++++----------- src/trace_segment.mli | 7 +- 4 files changed, 202 insertions(+), 73 deletions(-) diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index 0fc0e0dd1..f9c330f9c 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -136,13 +136,23 @@ module Thread_info = struct Trace_segment.add_event trace_segment event_data (Timestamp.create time) ;; + let set_fiber_id t fiber_id = + let #(trace_segment, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in + Trace_segment.set_fiber_id trace_segment fiber_id + ;; + module New_trace_segment_kind = struct type t = | Independent | Continuing_from_current end - let start_new_trace_segment t ~in_filtered_region ~(kind : New_trace_segment_kind.t) = + let start_new_trace_segment + t + ~in_filtered_region + ~(kind : New_trace_segment_kind.t) + ~fiber_stacks + = let new_trace_segment = match kind with | Independent -> @@ -151,7 +161,7 @@ module Thread_info = struct | Without_exception_info _ -> None | With_exception_info { ocaml_exception_info; _ } -> Some ocaml_exception_info in - Trace_segment.create ocaml_exception_info + Trace_segment.create ocaml_exception_info fiber_stacks | Continuing_from_current -> let #(current, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in Trace_segment.create_continuing_from current @@ -173,6 +183,7 @@ type 'thread inner = ; mutable in_filtered_region : bool ; mutable transaction_events : Event.With_write_info.t Deque.t ; pending_flows : ('thread -> Time_ns.Span.t -> unit) Hashtbl.M(Int).t + ; fiber_stacks : Trace_segment.Fiber.t Hashtbl.M(Int).t } type t = T : 'thread inner -> t @@ -343,6 +354,7 @@ let create_expert ; in_filtered_region = true ; transaction_events = Deque.create () ; pending_flows = Hashtbl.create (module Int) + ; fiber_stacks = Hashtbl.create (module Int) } in write_hits t hits; @@ -577,7 +589,7 @@ let create_thread t event = ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) ; trace_segments = Nonempty_vec.create - #( Trace_segment.create t.ocaml_exception_info + #( Trace_segment.create t.ocaml_exception_info t.fiber_stacks , ~in_filtered_region:t.in_filtered_region ) } ;; @@ -778,7 +790,8 @@ let maybe_start_filtered_region t ~should_write ~time = Thread_info.start_new_trace_segment thread_info ~in_filtered_region:true - ~kind:Continuing_from_current); + ~kind:Continuing_from_current + ~fiber_stacks:t.fiber_stacks); t.in_filtered_region <- true; Hashtbl.iter t.thread_info ~f:(fun thread_info -> rewrite_all_callstacks t ~thread_info ~time)) @@ -793,7 +806,8 @@ let maybe_stop_filtered_region t ~should_write = Thread_info.start_new_trace_segment thread_info ~in_filtered_region:false - ~kind:Continuing_from_current)) + ~kind:Continuing_from_current + ~fiber_stacks:t.fiber_stacks)) ;; let write_event_and_callstack @@ -901,6 +915,7 @@ and write_event' (T t) ?events_writer event = thread_info ~in_filtered_region:t.in_filtered_region ~kind:Independent + ~fiber_stacks:t.fiber_stacks | Ok event_value -> if should_write then @@ -985,6 +1000,7 @@ and write_event' (T t) ?events_writer event = if is_perform || is_resume then ( let fiber_id = Int64.to_int_trunc (Int64.of_string data) in + Thread_info.set_fiber_id thread_info fiber_id; let name = if is_perform then "Perform Effect" else "Resume Continuation" in let args = Tracing.Trace.Arg.[ "fiber", String (sprintf "0x%x" fiber_id) ] in write_duration_complete t ~thread ~args ~name ~time ~time_end:time; diff --git a/src/perf_dlfilter.c b/src/perf_dlfilter.c index c3d462bd4..8bd921ff0 100644 --- a/src/perf_dlfilter.c +++ b/src/perf_dlfilter.c @@ -14,12 +14,12 @@ int filter_event_early(void *data, const struct perf_dlfilter_sample *sample, const struct perf_dlfilter_al *resolved_addr = perf_dlfilter_fns.resolve_addr(ctx); - // Only filter out events we for sure don't want. It's better to be less aggressive than - // too aggressive, as being too aggressive will lead to broken traces, while being not - // aggressive enough just makes things slower. + // Only filter out events we for sure don't want. It's better to be less + // aggressive than too aggressive, as being too aggressive will lead to broken + // traces, while being not aggressive enough just makes things slower. if (resolved_ip && resolved_ip->sym && resolved_addr && resolved_addr->sym && strcmp(resolved_ip->sym, resolved_addr->sym) == 0) { - return 1; + return 0; } return 0; diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 11b527046..29a49b4a3 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -15,7 +15,7 @@ module Frame : sig end (* The [location], [parent], and [kind] fields are actually **immutable** except for on [Sentinel.t] instances. *) - type t = private + type t = { mutable location : Event.Location.t ; mutable parent : t or_null ; mutable kind : Kind.t @@ -315,6 +315,21 @@ module Callstack = struct } end +module Fiber = struct + module Last_event = struct + type t = + | Perform + | Resume + end + + type t = + { mutable last_event : Last_event.t + ; mutable handler : Frame.t + ; mutable callstack : Callstack.t + ; exception_handlers : Frame.t Vec.t + } +end + type t = { mutable root : Frame.Sentinel.t ; mutable last_event_time : Timestamp.t @@ -335,8 +350,8 @@ type t = ; ocaml_exception_info : Ocaml_exception_info.t or_null ; exception_handlers : Frame.t Vec.t ; effect_handlers : (Frame.t * exn_depth:int) Vec.t - ; saved_exception_handlers : Frame.t Vec.t - ; saved_callstacks : Callstack.t Vec.t__'value_value_value' + ; fiber_stacks : Fiber.t Hashtbl.M(Int).t + ; mutable last_known_fiber_id : int or_null (** The currently active OCaml exception handlers. This is used to determine which frame to return to when [ocaml_exception_info] indicates that the current event is an OCaml exception being raised in the traced program. @@ -356,7 +371,7 @@ let unknown_location : Location.t = } ;; -let create ocaml_exception_info = +let create ocaml_exception_info fiber_stacks = let root = Frame.Sentinel.create () in { root ; last_event_time = Timestamp.zero @@ -368,11 +383,11 @@ let create ocaml_exception_info = } : Callstack.t) ; symbolizer = Symbolizer.create () + ; ocaml_exception_info = Or_null.of_option ocaml_exception_info ; exception_handlers = Vec.create () ; effect_handlers = Vec.create () - ; saved_exception_handlers = Vec.create () - ; saved_callstacks = (Vec.create [@kind value & value & value]) () - ; ocaml_exception_info = Or_null.of_option ocaml_exception_info + ; fiber_stacks + ; last_known_fiber_id = Null ; last_known_location = unknown_location } ;; @@ -726,6 +741,7 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = [%message "Mismatched handler and dst" (dst_frame.location.symbol : Symbol.t) + (dst.instruction_pointer : Int64.Hex.t) (dst.symbol : Symbol.t)]; (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with | #(~distance:(This distance), ~leaf_of_inlined_stack) -> @@ -794,7 +810,8 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = [%message "[exception_handlers] appears to be out-of-sync with [callstacks]; there is \ no active exception handler, but a frame with a matching symbol was found." - (dst : Location.t)]; + (dst : Location.t) + (dst.symbol : Symbol.t)]; (match leaf_of_inlined_stack with | #(Null, _) -> Frame.set_instruction_pointer dst_frame dst.instruction_pointer; @@ -822,15 +839,40 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) ;; +let set_fiber_id (t : t) fiber_id = + eprint_s [%message "set" (fiber_id : int)]; + t.last_known_fiber_id <- This fiber_id +;; + +let current_fiber (t : t) ~time = + let fiber_id = Or_null.value ~default:0 t.last_known_fiber_id in + eprint_s [%message "get" (fiber_id : int)]; + Hashtbl.find_or_add t.fiber_stacks fiber_id ~default:(fun () -> + { last_event = Resume + ; handler = current_frame t + ; callstack = + #{ time; leaf = current_frame t; control_flow = Return { distance = 0 } } + ; exception_handlers = Vec.create () + }) +;; + (* CR mslater: dedup *) -let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = - Vec.clear t.saved_exception_handlers; - (Vec.clear [@kind value & value & value]) t.saved_callstacks; +let handle_ocaml_perform (t : t) (time : Timestamp.t) ~(dst : Location.t) = + (* CR mslater: test without ptwrites *) + let fiber = current_fiber t ~time in + fiber.last_event <- Perform; + (* eprint_s [%message "perform" (t.last_known_fiber_id : int or_null)]; *) match Vec.last t.effect_handlers with | This (dst_frame, ~exn_depth) -> - Vec.pop_back_unit_exn t.effect_handlers; + fiber.handler <- dst_frame; + eprint_s + [%message + "ashdjgklahdfjkglhadfjkghajkdflgadfg" + (exn_depth : int) + (Vec.length t.exception_handlers : int)]; + Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers); while Vec.length t.exception_handlers > exn_depth do - Vec.push_back t.saved_exception_handlers (Vec.pop_back_exn t.exception_handlers) + Vec.push_back fiber.exception_handlers (Vec.pop_back_exn t.exception_handlers) done; (* We expect the handler and dst to be different symbols. *) (match Frame.find_ancestor (current_frame t) ~ancestor:dst_frame with @@ -838,13 +880,10 @@ let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* This is the happy case where our exception handler tracking is working as expected. *) (match leaf_of_inlined_stack with | #(Null, _) -> - (Vec.push_back [@kind value & value & value]) - t.saved_callstacks - #{ time - ; leaf = current_frame t - ; control_flow = Call { depth = distance + 1 } - }; - eprint_s [%message "handle_ocaml_effect" (distance : int)]; + (* CR mslater: other cases *) + fiber.callstack + <- #{ time; leaf = current_frame t; control_flow = Call { depth = distance } }; + eprint_s [%message "handle_ocaml_perform" (distance : int)]; Frame.For_testing.print_callstack (current_frame t); Frame.set_instruction_pointer dst_frame dst.instruction_pointer; Nonempty_vec.push_back @@ -881,14 +920,14 @@ let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = [%message [%string "[effect_handlers] appears to be out-of-sync with [callstacks]; active \ - exception handler was not found in [callstacks]. %{message}"] + effect handler was not found in [callstacks]. %{message}"] (dst : Location.t)]; (* TODO Decide if maybe we should just raise in this case? The trace is probably going to be pretty broken if we make it here. *) handle_return t time ~dst) | Null -> (match Frame.find (current_frame t) dst.symbol with | #(Null, ~distance, ..) -> - (* We are probably raising into an exception handler much further up the stack that we never saw the entrance into. *) + (* We are probably raising into an effect handler much further up the stack that we never saw the entrance into. *) let dst_frame = replace_root t dst ~kind:Physical in Nonempty_vec.push_back t.callstacks @@ -907,7 +946,7 @@ let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = log_unexpected_case [%message "[effect_handlers] appears to be out-of-sync with [callstacks]; there is no \ - active exception handler, but a frame with a matching symbol was found." + active effect handler, but a frame with a matching symbol was found." (dst : Location.t)]; (match leaf_of_inlined_stack with | #(Null, _) -> @@ -936,6 +975,70 @@ let handle_ocaml_effect (t : t) (time : Timestamp.t) ~(dst : Location.t) = Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) ;; +let handle_ocaml_resume t time = + let fiber = current_fiber t ~time in + (* let last_event = fiber.last_event in *) + fiber.last_event <- Resume; + eprint_s [%message "resume" (t.last_known_fiber_id : int or_null)]; + Vec.push_back + t.effect_handlers + (fiber.handler, ~exn_depth:(Vec.length t.exception_handlers)); + eprint_s + [%message + "before RESUME" + (Vec.length t.exception_handlers : int) + (Vec.length fiber.exception_handlers : int)]; + Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers); + while Vec.length fiber.exception_handlers > 0 do + eprint_s [%message "saved_exception_handlers"]; + Vec.push_back t.exception_handlers (Vec.pop_back_exn fiber.exception_handlers) + done; + (* (match last_event with + | Perform -> + Nonempty_vec.push_back + t.callstacks + #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } } + | Resume -> ()); *) + Nonempty_vec.push_back + t.callstacks + #{ time + ; leaf = Or_null.value_exn (current_frame t).parent + ; control_flow = Return { distance = 1 } + }; + let distance = + match Frame.find fiber.callstack.#leaf fiber.handler.location.symbol with + | #(This frame, ~distance, ~physical_distance:_, ~leaf_of_inlined_stack:_) -> + frame.parent <- This (current_frame t); + distance + | _ -> 0 + in + (* Nonempty_vec.push_back + t.callstacks + #{ time; leaf = fiber.handler; control_flow = Call { depth = 1 } }; *) + fiber.callstack + <- #{ fiber.callstack with time; control_flow = Call { depth = distance + 1 } }; + eprint_s [%message "new callstack"]; + Frame.For_testing.print_callstack fiber.callstack.#leaf; + Nonempty_vec.push_back t.callstacks fiber.callstack +;; + +let handle_ocaml_enter_runstack t ~current_physical_frame = + eprint_s [%message "enter runstack" (Vec.length t.exception_handlers : int)]; + Vec.push_back + t.effect_handlers + (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); + Vec.push_back t.exception_handlers current_physical_frame +;; + +let handle_ocaml_exit_runstack t = + let _, ~exn_depth = Vec.pop_back_exn t.effect_handlers in + eprint_s [%message "exit runstack" (Vec.length t.exception_handlers : int)]; + while Vec.length t.exception_handlers > exn_depth do + Vec.pop_back_unit_exn t.exception_handlers + done; + Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers) +;; + let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = match event with | Trace { kind; src; dst; trace_state_change } -> @@ -993,50 +1096,36 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = (match t.ocaml_exception_info with | Null -> () | This ocaml_exception_info -> - (match Symbol.display_name src.symbol, src.symbol_offset with - | "caml_runstack", 0xa9 -> - Vec.push_back - t.effect_handlers - (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); - Vec.push_back t.exception_handlers current_physical_frame; - (Vec.clear [@kind value & value & value]) t.saved_callstacks; - Vec.clear t.saved_exception_handlers - | "caml_runstack", 0x13b -> - let _, ~exn_depth = Vec.pop_back_exn t.effect_handlers in - while Vec.length t.exception_handlers > exn_depth do - Vec.pop_back_unit_exn t.exception_handlers - done - | "caml_perform", 0xb5 -> handle_ocaml_effect t time ~dst - | "caml_resume", 0xda -> - Vec.push_back - t.effect_handlers - (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); - eprint_s - [%message - (Vec.length t.saved_exception_handlers : int) - ((Vec.length [@kind value & value & value]) t.saved_callstacks : int)]; - Vec.iter t.saved_exception_handlers ~f:(fun exn -> - eprint_s [%message "saved_exception_handlers"]; - Frame.For_testing.print_callstack exn; - Vec.push_back t.exception_handlers exn); - if (Vec.length [@kind value & value & value]) t.saved_callstacks > 0 - then - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } }; - (Vec.iter [@kind value & value & value]) t.saved_callstacks ~f:(fun cs -> - eprint_s [%message "saved_callstacks"]; - Frame.For_testing.print_callstack cs.#leaf; - Nonempty_vec.push_back t.callstacks #{ cs with time }) - | _ -> ()); + let i = ref 0 in Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info ~from:t.last_known_location.instruction_pointer ~to_:src.instruction_pointer - ~f:(stack_ fun (_address, kind) -> + ~f:(stack_ fun (address, kind) -> + Int.incr i; + eprint_s [%message "ITERTRAP" (!i : int)]; match kind with - | Pushtrap -> Vec.push_back t.exception_handlers current_physical_frame + | Pushtrap -> + (match address with + | 0x4555b8L -> + eprint_s + [%message + "PUSHTRAP" + (t.last_known_location.instruction_pointer : Int64.Hex.t) + (src.instruction_pointer : Int64.Hex.t) + (dst.instruction_pointer : Int64.Hex.t)] + | _ -> ()); + Vec.push_back t.exception_handlers current_physical_frame | Poptrap -> + (match address with + | 0x455615L -> + eprint_s + [%message + "POPTRAP" + (t.last_known_location.instruction_pointer : Int64.Hex.t) + (src.instruction_pointer : Int64.Hex.t) + (dst.instruction_pointer : Int64.Hex.t)] + | _ -> ()); (match Vec.last t.exception_handlers with | This current_exception_handler when phys_equal current_exception_handler current_physical_frame -> @@ -1053,7 +1142,17 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = ~current_exception_handler: (current_exception_handler.location : Location.t) ~current_physical_frame: - (current_physical_frame.location : Location.t)]))); + (current_physical_frame.location : Location.t)])); + (match Symbol.display_name src.symbol, src.symbol_offset with + | "caml_runstack", 0xa9 -> handle_ocaml_enter_runstack t ~current_physical_frame + | "caml_runstack", 0x13b -> handle_ocaml_exit_runstack t + | "caml_perform", 0xb5 -> handle_ocaml_perform t time ~dst + | "caml_resume", 0xda -> handle_ocaml_resume t time + | _ -> ())); + (* eprint_s + [%message + (t.last_known_location.instruction_pointer : Int64.Hex.t) + (dst.instruction_pointer : Int64.Hex.t)]; *) t.last_known_location <- dst | _ -> ()); (match event with @@ -1069,6 +1168,15 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | Return | Sysret | Iret -> handle_return t time ~dst | Jump | Tx_abort | Async -> handle_jump t time ~src ~dst) | Trace { kind = None; _ } -> () + (* | Ptwrite { location; data } -> + let symbol_name = Symbol.display_name location.symbol in + eprint_s [%message (symbol_name : string)]; + (match symbol_name with + | "caml_perform" | "caml_resume" -> + let id = Int64.to_int_trunc (Int64.of_string data) in + eprint_s [%message (id : int)]; + t.last_known_fiber_id <- This id + | _ -> ()) *) (* All of the below events are handled in [new_trace_writer.ml]. *) | Power _ | Stacktrace_sample _ | Event_sample _ | Ptwrite _ -> ()); if debug @@ -1475,7 +1583,7 @@ module%test _ = struct end let setup_test () = - let t = create None in + let t = create None (Hashtbl.create (module Int)) in let ip = ref (-1) in let time = ref Time_ns.Span.zero in let incr_time () = time := Time_ns.Span.(!time + of_int_ns 1) in diff --git a/src/trace_segment.mli b/src/trace_segment.mli index 0cf99ca19..8c4ef6be7 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -4,13 +4,18 @@ open! Core thread. *) type t -val create : Ocaml_exception_info.t option -> t +module Fiber : sig + type t +end + +val create : Ocaml_exception_info.t option -> Fiber.t Hashtbl.M(Int).t -> t (** Create a new trace segment that continues from the state of an existing segment, taking the existing segment's last callstack as the new segment's first callstack. *) val create_continuing_from : t -> t val add_event : t -> Event.Ok.Data.t -> Timestamp.t -> unit +val set_fiber_id : t -> int -> unit val write_trace : t From 43b77650f6f3e86d0daa1e439ea85795231a2fbe Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 13 May 2026 18:45:04 -0400 Subject: [PATCH 29/30] filter --- src/perf_dlfilter.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/perf_dlfilter.c b/src/perf_dlfilter.c index 8bd921ff0..c3d462bd4 100644 --- a/src/perf_dlfilter.c +++ b/src/perf_dlfilter.c @@ -14,12 +14,12 @@ int filter_event_early(void *data, const struct perf_dlfilter_sample *sample, const struct perf_dlfilter_al *resolved_addr = perf_dlfilter_fns.resolve_addr(ctx); - // Only filter out events we for sure don't want. It's better to be less - // aggressive than too aggressive, as being too aggressive will lead to broken - // traces, while being not aggressive enough just makes things slower. + // Only filter out events we for sure don't want. It's better to be less aggressive than + // too aggressive, as being too aggressive will lead to broken traces, while being not + // aggressive enough just makes things slower. if (resolved_ip && resolved_ip->sym && resolved_addr && resolved_addr->sym && strcmp(resolved_ip->sym, resolved_addr->sym) == 0) { - return 0; + return 1; } return 0; From d873e87e53810f858dfb1f9939cbdf66282f93c7 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Thu, 21 May 2026 16:28:53 -0400 Subject: [PATCH 30/30] delete debug code --- src/trace_segment.ml | 80 +++----------------------------------------- 1 file changed, 5 insertions(+), 75 deletions(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 29a49b4a3..3e067e168 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -839,14 +839,10 @@ let handle_ocaml_exception (t : t) (time : Timestamp.t) ~(dst : Location.t) = Frame.set_instruction_pointer dst_frame dst.instruction_pointer)) ;; -let set_fiber_id (t : t) fiber_id = - eprint_s [%message "set" (fiber_id : int)]; - t.last_known_fiber_id <- This fiber_id -;; +let set_fiber_id (t : t) fiber_id = t.last_known_fiber_id <- This fiber_id let current_fiber (t : t) ~time = let fiber_id = Or_null.value ~default:0 t.last_known_fiber_id in - eprint_s [%message "get" (fiber_id : int)]; Hashtbl.find_or_add t.fiber_stacks fiber_id ~default:(fun () -> { last_event = Resume ; handler = current_frame t @@ -861,16 +857,9 @@ let handle_ocaml_perform (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* CR mslater: test without ptwrites *) let fiber = current_fiber t ~time in fiber.last_event <- Perform; - (* eprint_s [%message "perform" (t.last_known_fiber_id : int or_null)]; *) match Vec.last t.effect_handlers with | This (dst_frame, ~exn_depth) -> fiber.handler <- dst_frame; - eprint_s - [%message - "ashdjgklahdfjkglhadfjkghajkdflgadfg" - (exn_depth : int) - (Vec.length t.exception_handlers : int)]; - Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers); while Vec.length t.exception_handlers > exn_depth do Vec.push_back fiber.exception_handlers (Vec.pop_back_exn t.exception_handlers) done; @@ -883,8 +872,6 @@ let handle_ocaml_perform (t : t) (time : Timestamp.t) ~(dst : Location.t) = (* CR mslater: other cases *) fiber.callstack <- #{ time; leaf = current_frame t; control_flow = Call { depth = distance } }; - eprint_s [%message "handle_ocaml_perform" (distance : int)]; - Frame.For_testing.print_callstack (current_frame t); Frame.set_instruction_pointer dst_frame dst.instruction_pointer; Nonempty_vec.push_back t.callstacks @@ -977,28 +964,13 @@ let handle_ocaml_perform (t : t) (time : Timestamp.t) ~(dst : Location.t) = let handle_ocaml_resume t time = let fiber = current_fiber t ~time in - (* let last_event = fiber.last_event in *) fiber.last_event <- Resume; - eprint_s [%message "resume" (t.last_known_fiber_id : int or_null)]; Vec.push_back t.effect_handlers (fiber.handler, ~exn_depth:(Vec.length t.exception_handlers)); - eprint_s - [%message - "before RESUME" - (Vec.length t.exception_handlers : int) - (Vec.length fiber.exception_handlers : int)]; - Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers); while Vec.length fiber.exception_handlers > 0 do - eprint_s [%message "saved_exception_handlers"]; Vec.push_back t.exception_handlers (Vec.pop_back_exn fiber.exception_handlers) done; - (* (match last_event with - | Perform -> - Nonempty_vec.push_back - t.callstacks - #{ time; leaf = current_frame t; control_flow = Return { distance = 1 } } - | Resume -> ()); *) Nonempty_vec.push_back t.callstacks #{ time @@ -1012,18 +984,12 @@ let handle_ocaml_resume t time = distance | _ -> 0 in - (* Nonempty_vec.push_back - t.callstacks - #{ time; leaf = fiber.handler; control_flow = Call { depth = 1 } }; *) fiber.callstack <- #{ fiber.callstack with time; control_flow = Call { depth = distance + 1 } }; - eprint_s [%message "new callstack"]; - Frame.For_testing.print_callstack fiber.callstack.#leaf; Nonempty_vec.push_back t.callstacks fiber.callstack ;; let handle_ocaml_enter_runstack t ~current_physical_frame = - eprint_s [%message "enter runstack" (Vec.length t.exception_handlers : int)]; Vec.push_back t.effect_handlers (current_physical_frame, ~exn_depth:(Vec.length t.exception_handlers)); @@ -1032,11 +998,9 @@ let handle_ocaml_enter_runstack t ~current_physical_frame = let handle_ocaml_exit_runstack t = let _, ~exn_depth = Vec.pop_back_exn t.effect_handlers in - eprint_s [%message "exit runstack" (Vec.length t.exception_handlers : int)]; while Vec.length t.exception_handlers > exn_depth do Vec.pop_back_unit_exn t.exception_handlers - done; - Frame.For_testing.print_callstack (Vec.peek_back_exn t.exception_handlers) + done ;; let[@cold] print (event : Event.Ok.Data.t) (time : Timestamp.t) = @@ -1096,36 +1060,14 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = (match t.ocaml_exception_info with | Null -> () | This ocaml_exception_info -> - let i = ref 0 in Ocaml_exception_info.iter_pushtraps_and_poptraps_in_range ocaml_exception_info ~from:t.last_known_location.instruction_pointer ~to_:src.instruction_pointer - ~f:(stack_ fun (address, kind) -> - Int.incr i; - eprint_s [%message "ITERTRAP" (!i : int)]; + ~f:(stack_ fun (_, kind) -> match kind with - | Pushtrap -> - (match address with - | 0x4555b8L -> - eprint_s - [%message - "PUSHTRAP" - (t.last_known_location.instruction_pointer : Int64.Hex.t) - (src.instruction_pointer : Int64.Hex.t) - (dst.instruction_pointer : Int64.Hex.t)] - | _ -> ()); - Vec.push_back t.exception_handlers current_physical_frame + | Pushtrap -> Vec.push_back t.exception_handlers current_physical_frame | Poptrap -> - (match address with - | 0x455615L -> - eprint_s - [%message - "POPTRAP" - (t.last_known_location.instruction_pointer : Int64.Hex.t) - (src.instruction_pointer : Int64.Hex.t) - (dst.instruction_pointer : Int64.Hex.t)] - | _ -> ()); (match Vec.last t.exception_handlers with | This current_exception_handler when phys_equal current_exception_handler current_physical_frame -> @@ -1144,15 +1086,12 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = ~current_physical_frame: (current_physical_frame.location : Location.t)])); (match Symbol.display_name src.symbol, src.symbol_offset with + (* CR mslater: export these from the compiler *) | "caml_runstack", 0xa9 -> handle_ocaml_enter_runstack t ~current_physical_frame | "caml_runstack", 0x13b -> handle_ocaml_exit_runstack t | "caml_perform", 0xb5 -> handle_ocaml_perform t time ~dst | "caml_resume", 0xda -> handle_ocaml_resume t time | _ -> ())); - (* eprint_s - [%message - (t.last_known_location.instruction_pointer : Int64.Hex.t) - (dst.instruction_pointer : Int64.Hex.t)]; *) t.last_known_location <- dst | _ -> ()); (match event with @@ -1168,15 +1107,6 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | Return | Sysret | Iret -> handle_return t time ~dst | Jump | Tx_abort | Async -> handle_jump t time ~src ~dst) | Trace { kind = None; _ } -> () - (* | Ptwrite { location; data } -> - let symbol_name = Symbol.display_name location.symbol in - eprint_s [%message (symbol_name : string)]; - (match symbol_name with - | "caml_perform" | "caml_resume" -> - let id = Int64.to_int_trunc (Int64.of_string data) in - eprint_s [%message (id : int)]; - t.last_known_fiber_id <- This id - | _ -> ()) *) (* All of the below events are handled in [new_trace_writer.ml]. *) | Power _ | Stacktrace_sample _ | Event_sample _ | Ptwrite _ -> ()); if debug