Read effect branch offsets from elf notes

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

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. *)

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")

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

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 )
   }
 ;;

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
+;;

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 <https://github.com/oxcaml/oxcaml/pull/6274> *)
+
+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

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

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

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 | Resume_premepted) -> 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

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. *)

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