From 0c01d63ec031748a986c6562b38d3f949df96fb8 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 17 Jun 2026 14:18:27 -0400 Subject: [PATCH 1/4] read offsets from elf notes --- src/elf.ml | 23 +++++++++++++++++++ src/elf.mli | 1 + src/env_vars.ml | 5 +++++ src/env_vars.mli | 1 + src/new_trace_writer.ml | 12 ++++++++-- src/trace.ml | 9 ++++++++ src/trace.mli | 1 + src/trace_segment.ml | 30 ++++++++++++------------- src/trace_segment.mli | 6 ++++- src/trace_writer.ml | 3 +++ src/trace_writer_implementation_intf.ml | 2 ++ 11 files changed, 74 insertions(+), 19 deletions(-) diff --git a/src/elf.ml b/src/elf.ml index aeaf0c62c..ac937b697 100644 --- a/src/elf.ml +++ b/src/elf.ml @@ -9,12 +9,14 @@ type t = ; programs : Owee_elf.program array ; debug : Owee_buf.t option ; ocaml_exception_info : Ocaml_exception_info.t option + ; ocaml_effect_info : Ocaml_effect_info.t option ; base_offset : int ; filename : string ; statically_mappable : bool } let ocaml_exception_info t = t.ocaml_exception_info +let ocaml_effect_info t = t.ocaml_effect_info (** Elf files tend to have a "base offset" between where their sections end up in memory and where they are in the file, this function figures out that offset. *) @@ -33,6 +35,25 @@ let is_non_pie_executable (header : Owee_elf.header) = | _e_type -> false ;; +let find_ocaml_effect_info buffer sections = + try + let ocaml_eff = Owee_elf_notes.find_notes_section sections ".note.ocaml_eff" in + let body = Owee_elf.section_body buffer ocaml_eff in + let cursor = Owee_buf.cursor body in + let descsz = + Owee_elf_notes.read_desc_size ~expected_owner:"OCaml" ~expected_type:2 cursor + in + if descsz < 8 * 7 + then Owee_buf.invalid_format (Printf.sprintf "Too small size of note %d\n" descsz); + let rec read_offsets acc = + let addr = Owee_buf.Read.u64 cursor in + if Int64.equal addr 0L then Array.of_list_rev acc else read_offsets (addr :: acc) + in + Some (Ocaml_effect_info.create ~offsets:(read_offsets [])) + with + | Owee_elf_notes.Section_not_found _ -> None +;; + let find_ocaml_exception_info buffer sections = let read_note cursor ~actual_base = let descsz = @@ -102,6 +123,7 @@ let create filename = Owee_elf.find_section_body buffer sections ~section_name:".debug_line" in let ocaml_exception_info = find_ocaml_exception_info buffer sections in + let ocaml_effect_info = find_ocaml_effect_info buffer sections in Some { string ; symbol @@ -113,6 +135,7 @@ let create filename = ; filename ; statically_mappable ; ocaml_exception_info + ; ocaml_effect_info } | _, _ -> None with diff --git a/src/elf.mli b/src/elf.mli index ba18f0985..1e657fe08 100644 --- a/src/elf.mli +++ b/src/elf.mli @@ -15,6 +15,7 @@ val selection_stop_info : t -> Pid.t -> Selection.t -> Stop_info.t val addr_table : t -> Addr_table.t val ocaml_exception_info : t -> Ocaml_exception_info.t option +val ocaml_effect_info : t -> Ocaml_effect_info.t option (** Find function symbols matching a regex and return a map from symbol name to symbol suitable for asking the user to disambiguate. *) diff --git a/src/env_vars.ml b/src/env_vars.ml index e87055b7e..0f1c596f0 100644 --- a/src/env_vars.ml +++ b/src/env_vars.ml @@ -50,6 +50,11 @@ let no_ocaml_exception_debug_info = Option.is_some (Unix.getenv "MAGIC_TRACE_NO_OCAML_EXCEPTION_DEBUG_INFO") ;; +(* Ignore OxCaml effect machinery notes. *) +let no_ocaml_effect_debug_info = + Option.is_some (Unix.getenv "MAGIC_TRACE_NO_OCAML_EFFECT_DEBUG_INFO") +;; + (* Skip any special case transaction handling, intended for debugging tx/tx_abrt. *) let skip_transaction_handling = Option.is_some (Unix.getenv "MAGIC_TRACE_SKIP_TX_HANDLING") diff --git a/src/env_vars.mli b/src/env_vars.mli index 2df1e1213..ea190977a 100644 --- a/src/env_vars.mli +++ b/src/env_vars.mli @@ -11,6 +11,7 @@ val share_command_filename : string option val no_dlfilter : bool val fzf_demangle_symbols : bool val no_ocaml_exception_debug_info : bool +val no_ocaml_effect_debug_info : bool val skip_transaction_handling : bool val use_new_trace_writer : bool val check_invariants : bool diff --git a/src/new_trace_writer.ml b/src/new_trace_writer.ml index eb0481659..ed12cecef 100644 --- a/src/new_trace_writer.ml +++ b/src/new_trace_writer.ml @@ -45,6 +45,7 @@ module Thread_info = struct { thread : ('thread[@sexp.opaque]) ; mutable last_decode_error_time : Mapped_time.t ; ocaml_exception_info : (Ocaml_exception_info.t[@sexp.opaque]) option + ; ocaml_effect_info : (Ocaml_effect_info.t[@sexp.opaque]) option (* When the last event arrived. Used to give timestamps to events lacking them. *) ; mutable last_event_time : Mapped_time.t ; track_group_id : int @@ -78,7 +79,8 @@ module Thread_info = struct = let new_trace_segment = match kind with - | Independent -> Trace_segment.create t.ocaml_exception_info fiber_stacks + | Independent -> + Trace_segment.create t.ocaml_exception_info t.ocaml_effect_info fiber_stacks | Continuing_from_current -> let #(current, ~in_filtered_region:_) = Nonempty_vec.last t.trace_segments in Trace_segment.create_continuing_from current @@ -92,6 +94,7 @@ 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 + ; ocaml_effect_info : Ocaml_effect_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 @@ -222,6 +225,7 @@ let create_expert ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times @@ -235,6 +239,7 @@ let create_expert T { debug_info = Option.value debug_info ~default:(Int.Table.create ()) ; ocaml_exception_info + ; ocaml_effect_info ; thread_info = Hashtbl.create (module Event.Thread) ; base_time ; trace_scope @@ -254,6 +259,7 @@ let create ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times @@ -263,6 +269,7 @@ let create ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times @@ -345,12 +352,13 @@ let create_thread t event = { Thread_info.thread ; last_decode_error_time = effective_time ; ocaml_exception_info = t.ocaml_exception_info + ; ocaml_effect_info = t.ocaml_effect_info ; last_event_time = effective_time ; track_group_id ; extra_event_tracks = Hashtbl.create (module Collection_mode.Event.Name) ; trace_segments = Nonempty_vec.create - #( Trace_segment.create t.ocaml_exception_info t.fiber_stacks + #( Trace_segment.create t.ocaml_exception_info t.ocaml_effect_info t.fiber_stacks , ~in_filtered_region:t.in_filtered_region ) } ;; diff --git a/src/trace.ml b/src/trace.ml index 0a7b65110..d21047e1f 100644 --- a/src/trace.ml +++ b/src/trace.ml @@ -94,6 +94,7 @@ end let write_trace_from_events ?ocaml_exception_info + ?ocaml_effect_info ~events_writer ~writer ~print_events @@ -145,6 +146,7 @@ let write_trace_from_events ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times:Env_vars.debug @@ -154,6 +156,7 @@ let write_trace_from_events ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times:Env_vars.debug @@ -301,12 +304,18 @@ module Make_commands (Backend : Backend_intf.S) = struct | true -> None | false -> Option.bind elf ~f:Elf.ocaml_exception_info in + let ocaml_effect_info = + match Env_vars.no_ocaml_effect_debug_info with + | true -> None + | false -> Option.bind elf ~f:Elf.ocaml_effect_info + in let%bind events, close_result = get_events_and_close_result ~decode_events ~range_symbols in let%bind () = write_trace_from_events ?ocaml_exception_info + ?ocaml_effect_info ~events_writer ~writer ~debug_info diff --git a/src/trace.mli b/src/trace.mli index 51bca357f..946ae0a18 100644 --- a/src/trace.mli +++ b/src/trace.mli @@ -12,6 +12,7 @@ module For_testing : sig val write_trace_from_events : ?ocaml_exception_info:Ocaml_exception_info.t + -> ?ocaml_effect_info:Ocaml_effect_info.t -> events_writer:Tracing_tool_output.events_writer option -> writer:Tracing_zero.Writer.t option -> trace_scope:Trace_scope.t diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 7cc6a155f..8bedcc548 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -384,6 +384,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 + ; ocaml_effect_info : Ocaml_effect_info.t or_null ; exception_handlers : Frame.t Vec.t ; effect_handlers : (Frame.t * exn_depth:int) Vec.t ; fiber_stacks : Fiber.t Hashtbl.M(Int).t @@ -401,7 +402,7 @@ type t = ; mutable last_known_location : Location.t } -let create ocaml_exception_info fiber_stacks = +let create ocaml_exception_info ocaml_effect_info fiber_stacks = let root = Frame.Sentinel.create () in { root ; last_event_time = Timestamp.zero @@ -414,6 +415,7 @@ let create ocaml_exception_info fiber_stacks = : Callstack.t) ; symbolizer = Symbolizer.create () ; ocaml_exception_info = Or_null.of_option ocaml_exception_info + ; ocaml_effect_info = Or_null.of_option ocaml_effect_info ; exception_handlers = Vec.create () ; effect_handlers = Vec.create () ; fiber_stacks @@ -780,13 +782,9 @@ let is_ocaml_exception_handler t ~(dst : Location.t) = match t.ocaml_exception_info with | Null -> false | This ocaml_exception_info -> - (match Symbol.display_name dst.symbol, dst.symbol_offset with - (* CR-soon mslater: export this with the exception handler info *) - | "caml_runstack", 0x13d -> true - | _ -> - Ocaml_exception_info.is_entertrap - ocaml_exception_info - ~addr:dst.instruction_pointer) + Ocaml_exception_info.is_entertrap ocaml_exception_info ~addr:dst.instruction_pointer + || Or_null.value_map t.ocaml_effect_info ~default:false ~f:(fun info -> + Ocaml_effect_info.is_exn_handler info dst) ;; let return_to_unknown_handler (t : t) (time : Timestamp.t) ~(dst : Location.t) = @@ -1105,13 +1103,13 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = (current_exception_handler.location : Location.t) ~current_physical_frame: (current_physical_frame.location : Location.t)])); - (match Symbol.display_name src.symbol, src.symbol_offset with - (* CR-soon mslater: export these with the exception handler info *) - | "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 - | _ -> ())); + Or_null.iter t.ocaml_effect_info ~f:(fun ocaml_effect_info -> + match Ocaml_effect_info.categorize ocaml_effect_info src with + | This Runstack_enter -> handle_ocaml_enter_runstack t ~current_physical_frame + | This Runstack_exit -> handle_ocaml_exit_runstack t + | This Perform_enter -> handle_ocaml_perform t time ~dst + | This Resume_enter -> handle_ocaml_resume t time + | _ -> ())); t.last_known_location <- dst | _ -> ()); (match event with @@ -1557,7 +1555,7 @@ module%test _ = struct end let setup_test () = - let t = create None (Hashtbl.create (module Int)) in + let t = create None 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 89b5670e0..c0ba275ca 100644 --- a/src/trace_segment.mli +++ b/src/trace_segment.mli @@ -8,7 +8,11 @@ module Fiber : sig type t end -val create : Ocaml_exception_info.t option -> Fiber.t Hashtbl.M(Int).t -> t +val create + : Ocaml_exception_info.t option + -> Ocaml_effect_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. *) diff --git a/src/trace_writer.ml b/src/trace_writer.ml index 2e80dd73e..91962a264 100644 --- a/src/trace_writer.ml +++ b/src/trace_writer.ml @@ -304,6 +304,7 @@ let create_expert ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info:_ ~earliest_time ~hits ~annotate_inferred_start_times @@ -335,6 +336,7 @@ let create ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times @@ -344,6 +346,7 @@ let create ~trace_scope ~debug_info ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time ~hits ~annotate_inferred_start_times diff --git a/src/trace_writer_implementation_intf.ml b/src/trace_writer_implementation_intf.ml index 910a5ccb9..c353ccd76 100644 --- a/src/trace_writer_implementation_intf.ml +++ b/src/trace_writer_implementation_intf.ml @@ -14,6 +14,7 @@ module type S = sig : trace_scope:Trace_scope.t -> debug_info:Elf.Addr_table.t option -> ocaml_exception_info:Ocaml_exception_info.t option + -> ocaml_effect_info:Ocaml_effect_info.t option -> earliest_time:Time_ns.Span.t -> hits:(string * Breakpoint.Hit.t) list -> annotate_inferred_start_times:bool @@ -46,6 +47,7 @@ module type S = sig : trace_scope:Trace_scope.t -> debug_info:Elf.Addr_table.t option -> ocaml_exception_info:Ocaml_exception_info.t option + -> ocaml_effect_info:Ocaml_effect_info.t option -> earliest_time:Time_ns.Span.t -> hits:(string * Breakpoint.Hit.t) list -> annotate_inferred_start_times:bool From c61ca5e56506e575883895ac759d74d30627a75d Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 17 Jun 2026 14:22:05 -0400 Subject: [PATCH 2/4] add files --- src/ocaml_effect_info.ml | 51 +++++++++++++++++++++++++++++++++++++++ src/ocaml_effect_info.mli | 18 ++++++++++++++ 2 files changed, 69 insertions(+) create mode 100644 src/ocaml_effect_info.ml create mode 100644 src/ocaml_effect_info.mli diff --git a/src/ocaml_effect_info.ml b/src/ocaml_effect_info.ml new file mode 100644 index 000000000..7eef6fc78 --- /dev/null +++ b/src/ocaml_effect_info.ml @@ -0,0 +1,51 @@ +open! Core + +type t = + { caml_runstack_enter : int + ; caml_runstack_exit : int + ; caml_runstack_exn : int + ; caml_perform_enter : int + ; caml_resume_enter : int + ; caml_resume_preempted : int + } +[@@deriving sexp_of] + +module Kind = struct + type t = + | Runstack_enter + | Runstack_exit + | Runstack_exn + | Perform_enter + | Resume_enter + | Resume_premepted +end + +let create ~offsets = + if Array.length offsets < 6 then failwith "Insufficient offsets"; + (* Keep in sync with [amd64.S] in the compiler. *) + { caml_runstack_enter = Int64.to_int_exn offsets.(0) + ; caml_runstack_exit = Int64.to_int_exn offsets.(1) + ; caml_runstack_exn = Int64.to_int_exn offsets.(2) + ; caml_perform_enter = Int64.to_int_exn offsets.(3) + ; caml_resume_enter = Int64.to_int_exn offsets.(4) + ; caml_resume_preempted = Int64.to_int_exn offsets.(5) + } +;; + +let categorize t (loc : Event.Location.t) : Kind.t or_null = + match Symbol.display_name loc.symbol with + | "caml_runstack" when loc.symbol_offset = t.caml_runstack_enter -> This Runstack_enter + | "caml_runstack" when loc.symbol_offset = t.caml_runstack_exit -> This Runstack_exit + | "caml_runstack" when loc.symbol_offset = t.caml_runstack_exn -> This Runstack_exn + | "caml_perform" when loc.symbol_offset = t.caml_perform_enter -> This Perform_enter + | "caml_resume" when loc.symbol_offset = t.caml_resume_enter -> This Resume_enter + | "caml_resume" when loc.symbol_offset = t.caml_resume_preempted -> + This Resume_premepted + | _ -> Null +;; + +let is_exn_handler t (loc : Event.Location.t) = + match categorize t loc with + | This Runstack_exn -> true + | _ -> false +;; diff --git a/src/ocaml_effect_info.mli b/src/ocaml_effect_info.mli new file mode 100644 index 000000000..c798dd3f6 --- /dev/null +++ b/src/ocaml_effect_info.mli @@ -0,0 +1,18 @@ +type t + +(* Module for representing the necessary information to follow effect operations for + OxCaml programs compiled with *) + +module Kind : sig + type t = + | Runstack_enter + | Runstack_exit + | Runstack_exn + | Perform_enter + | Resume_enter + | Resume_premepted +end + +val create : offsets:int64 array -> t +val categorize : t -> Event.Location.t -> Kind.t or_null +val is_exn_handler : t -> Event.Location.t -> bool From 5aaf182b663b62c59d0fce946c7f8964062b07d9 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 17 Jun 2026 14:26:41 -0400 Subject: [PATCH 3/4] use resume_prempeted --- src/trace_segment.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/trace_segment.ml b/src/trace_segment.ml index 8bedcc548..8477e476b 100644 --- a/src/trace_segment.ml +++ b/src/trace_segment.ml @@ -1108,7 +1108,7 @@ let add_event (t : t) (event : Event.Ok.Data.t) (time : Timestamp.t) = | This Runstack_enter -> handle_ocaml_enter_runstack t ~current_physical_frame | This Runstack_exit -> handle_ocaml_exit_runstack t | This Perform_enter -> handle_ocaml_perform t time ~dst - | This Resume_enter -> handle_ocaml_resume t time + | This (Resume_enter | Resume_premepted) -> handle_ocaml_resume t time | _ -> ())); t.last_known_location <- dst | _ -> ()); From 17ac8b71558c2c45c7a59401d9d7aa6471ab7fc6 Mon Sep 17 00:00:00 2001 From: TheNumbat Date: Wed, 17 Jun 2026 14:38:38 -0400 Subject: [PATCH 4/4] fix build --- test/perf_script.ml | 10 +++++++++- test/perf_script.mli | 1 + 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/test/perf_script.ml b/test/perf_script.ml index 39f9dab2c..e790a9ef6 100644 --- a/test/perf_script.ml +++ b/test/perf_script.ml @@ -3,7 +3,14 @@ open! Async open Magic_trace_lib module Time_ns = Time_ns_unix -let run ?(debug = false) ?events_writer ?ocaml_exception_info ~trace_scope file = +let run + ?(debug = false) + ?events_writer + ?ocaml_exception_info + ?ocaml_effect_info + ~trace_scope + file + = (* CR-someday cgaebel: Get the git root by shelling out to `git rev-parse --show-toplevel`. This works, but is ridiculous. *) let git_root = "../../.." in @@ -62,6 +69,7 @@ let run ?(debug = false) ?events_writer ?ocaml_exception_info ~trace_scope file ~trace_scope ~debug_info:None ~ocaml_exception_info + ~ocaml_effect_info ~earliest_time:Time_ns.Span.zero ~hits:[] ~annotate_inferred_start_times:true diff --git a/test/perf_script.mli b/test/perf_script.mli index 1014cb6f7..c1144eb63 100644 --- a/test/perf_script.mli +++ b/test/perf_script.mli @@ -17,6 +17,7 @@ val run : ?debug:bool -> ?events_writer:Magic_trace_lib.Tracing_tool_output.events_writer -> ?ocaml_exception_info:Magic_trace_lib.Ocaml_exception_info.t + -> ?ocaml_effect_info:Magic_trace_lib.Ocaml_effect_info.t -> trace_scope:Magic_trace_lib.Trace_scope.t -> Filename.t -> unit Deferred.t