Add support for ptwrite events

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
 

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
 

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)

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

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

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

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 =

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 () =

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 }