Add support for magic-trace to sample and show other events such as cache misses and branch misses

core/collection_mode.ml

@@ -1,28 +1,93 @@
 open! Core
 
+module Event = struct
+  module Name = struct
+    type t =
+      | Branch_misses
+      | Cache_misses
+    [@@deriving compare, hash, sexp]
+
+    let to_string = function
+      | Branch_misses -> "branch-misses"
+      | Cache_misses -> "cache-misses"
+    ;;
+  end
+
+  module When_to_sample = struct
+    type t =
+      | Frequency of int
+      | Period of int
+    [@@deriving of_sexp]
+  end
+
+  module Precision = struct
+    type t =
+      | Arbitrary_skid
+      | Constant_skid
+      | Request_zero_skid
+      | Zero_skid
+      | Maximum_possible
+    [@@deriving of_sexp]
+  end
+
+  type t =
+    { when_to_sample : When_to_sample.t
+    ; name : Name.t
+    ; precision : Precision.t
+    }
+  [@@deriving of_sexp]
+
+  let of_string = function
+    | "branch-misses" ->
+      { when_to_sample = Period 50; name = Branch_misses; precision = Maximum_possible }
+    | "cache-misses" ->
+      { when_to_sample = Period 1; name = Cache_misses; precision = Maximum_possible }
+    | str -> t_of_sexp (Sexp.of_string str)
+  ;;
+
+  let arg_type = Command.Arg_type.create of_string
+end
+
 type t =
-  | Intel_processor_trace
-  | Stacktrace_sampling
+  | Intel_processor_trace of { extra_events : Event.t list }
+  | Stacktrace_sampling of { extra_events : Event.t list }
+
+let extra_events = function
+  | Intel_processor_trace { extra_events } | Stacktrace_sampling { extra_events } ->
+    extra_events
+;;
 
-let select_collection_mode ~use_sampling =
+let select_collection_mode ~extra_events ~use_sampling =
   match use_sampling with
-  | true -> Stacktrace_sampling
+  | true -> Stacktrace_sampling { extra_events }
   | false ->
     (match Core_unix.access "/sys/bus/event_source/devices/intel_pt" [ `Exists ] with
-    | Ok () -> Intel_processor_trace
+    | Ok () -> Intel_processor_trace { extra_events }
     | Error _ ->
-      Core.printf
-        "Intel PT support not found. magic-trace will continue and use sampling instead.";
-      Stacktrace_sampling)
+      Core.eprintf
+        "Intel PT support not found. magic-trace will continue and use sampling instead.\n";
+      Stacktrace_sampling { extra_events })
 ;;
 
 let param =
-  Command.Param.(
+  let%map_open.Command extra_events =
+    flag
+      "-events"
+      (optional_with_default
+         []
+         (Command.Arg_type.comma_separated ~unique_values:true Event.arg_type))
+      ~doc:
+        "EVENTS Select additional events which can be sampled as a comma separated list. \
+         Valid options are [cache-misses] or [branch-misses]. For more info: \
+         https://magic-trace.org/w/e"
+    |> Util.experimental_flag ~default:[]
+  and use_sampling =
     flag
       "-sampling"
       no_arg
       ~doc:
         "Use stacktrace sampling instead of Intel PT. If Intel PT is not available, \
          magic-trace will default to this."
-    |> map ~f:(fun use_sampling -> select_collection_mode ~use_sampling))
+  in
+  select_collection_mode ~extra_events ~use_sampling
 ;;

core/collection_mode.mli

@@ -1,7 +1,40 @@
 open! Core
 
+module Event : sig
+  module Name : sig
+    type t =
+      | Branch_misses
+      | Cache_misses
+    [@@deriving compare, hash, sexp]
+
+    val to_string : t -> string
+  end
+
+  module When_to_sample : sig
+    type t =
+      | Frequency of int
+      | Period of int
+  end
+
+  module Precision : sig
+    type t =
+      | Arbitrary_skid
+      | Constant_skid
+      | Request_zero_skid
+      | Zero_skid
+      | Maximum_possible
+  end
+
+  type t =
+    { when_to_sample : When_to_sample.t
+    ; name : Name.t
+    ; precision : Precision.t
+    }
+end
+
 type t =
-  | Intel_processor_trace
-  | Stacktrace_sampling
+  | Intel_processor_trace of { extra_events : Event.t list }
+  | Stacktrace_sampling of { extra_events : Event.t list }
 
+val extra_events : t -> Event.t list
 val param : t Command.Param.t

src/env_vars.ml → core/env_vars.ml

@@ -17,6 +17,10 @@ let perf_is_privileged = Option.is_some (Unix.getenv "MAGIC_TRACE_PERF_IS_PRIVIL
    This helps magic-trace developers debug magic-trace, it's not generally useful. *)
 let debug = Option.is_some (Unix.getenv "MAGIC_TRACE_DEBUG")
 
+(* Turns on hidden command line options which are considered experimental
+   features of magic-trace. *)
+let experimental = Option.is_some (Unix.getenv "MAGIC_TRACE_EXPERIMENTAL")
+
 (* When tracing the kernel on certain systems, perf only has root access when
    being run with a specific set of flags. Since this does not include
    [--dlfilter], this environment variable allows the user to forcibly disable

src/env_vars.mli → core/env_vars.mli

@@ -1,6 +1,7 @@
 open! Core
 
 val debug : bool
+val experimental : bool
 val perf_is_privileged : bool
 val perfetto_dir : string option
 val no_dlfilter : bool

core/event.ml

@@ -47,7 +47,12 @@ module Ok = struct
           ; dst : Location.t
           }
       | Power of { freq : int }
-      | Sample of { callstack : Location.t list }
+      | Stacktrace_sample of { callstack : Location.t list }
+      | Event_sample of
+          { location : Location.t
+          ; count : int
+          ; name : Collection_mode.Event.Name.t
+          }
     [@@deriving sexp]
   end
 

core/event.mli

@@ -44,9 +44,14 @@ module Ok : sig
           ; dst : Location.t
           } (** Represents an event collected from Intel PT. *)
       | Power of { freq : int } (** Power event collected by Intel PT. *)
-      | Sample of
+      | Stacktrace_sample of
           { callstack : Location.t list (** Oldest to most recent calls in order. *) }
-          (** Represents event collected through sampling. *)
+          (** Represents cycles event collected through sampling. *)
+      | Event_sample of
+          { location : Location.t
+          ; count : int
+          ; name : Collection_mode.Event.Name.t
+          } (** Represents counter based events collected through sampling. *)
     [@@deriving sexp]
   end
 

core/util.ml

@@ -60,3 +60,7 @@ let%test_module _ =
     ;;
   end)
 ;;
+
+let experimental_flag ~default flag =
+  if Env_vars.experimental then flag else Command.Param.return default
+;;

core/util.mli

@@ -2,3 +2,4 @@ open! Core
 
 val int64_of_hex_string : ?remove_hex_prefix:bool -> string -> int64
 val int_of_hex_string : ?remove_hex_prefix:bool -> string -> int
+val experimental_flag : default:'a -> 'a Command.Param.t -> 'a Command.Param.t

src/for_range.ml

@@ -26,7 +26,7 @@ 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 _; _ } -> None
+          | Error _ | Ok { data = Power _; _ } | Ok { data = Event_sample _; _ } -> None
           | Ok { data = Trace trace; time; _ } ->
             (match trace.kind with
             | Some Call ->
@@ -37,7 +37,7 @@ let range_hit_times ~decode_events ~range_symbols =
               then Some { Symbol_hit.kind = Stop; symbol; time }
               else None
             | _ -> None)
-          | Ok { data = Sample { callstack }; time; _ } ->
+          | Ok { data = Stacktrace_sample { callstack }; time; _ } ->
             List.rev callstack
             |> List.fold ~init:None ~f:(fun acc call ->
                    match acc, call with
@@ -89,11 +89,12 @@ let decode_events_and_annotate ~decode_events ~range_symbols =
                      when Time_ns_unix.Span.(time = hd.time)
                           && Symbol.equal dst.symbol hd.symbol ->
                      tl, not in_filtered_region
-                   | Ok { data = Sample _; time; _ }
+                   | Ok { data = Stacktrace_sample _; time; _ }
                      when Time_ns_unix.Span.(time = hd.time) -> tl, not in_filtered_region
                    | Ok { data = Trace _; _ }
-                   | Ok { data = Sample _; _ }
                    | Ok { data = Power _; _ }
+                   | Ok { data = Stacktrace_sample _; _ }
+                   | Ok { data = Event_sample _; _ }
                    | Error _ -> hits, in_filtered_region)
                in
                ( (hits, in_filtered_region)

src/import.ml

@@ -4,9 +4,11 @@ include struct
   module Collection_mode = Collection_mode
   module Decode_result = Decode_result
   module Elf = Elf
+  module Env_vars = Env_vars
   module Errno = Errno
   module Event = Event
   module Ocaml_exception_info = Ocaml_exception_info
+  module Perf_capabilities = Perf_capabilities
   module Perf_map = Perf_map
   module Perf_map_location = Perf_map_location
   module Subcommand = Subcommand