Allow running with sampling if Intel PT is unavailable

core/backend_intf.ml

@@ -1,5 +1,5 @@
-(** Backends, which do the Processor Trace recording, present this unified
-    interface in order to be exposed as commands which can generate traces. *)
+(** Backends, which do the trace recording, present this unified interface in
+    order to be exposed as commands which can generate traces. *)
 
 open! Core
 open! Async
@@ -19,9 +19,11 @@ module type S = sig
       -> debug_print_perf_commands:bool
       -> subcommand:Subcommand.t
       -> when_to_snapshot:When_to_snapshot.t
-      -> trace_mode:Trace_mode.t
+      -> trace_scope:Trace_scope.t
+      -> multi_snapshot:bool
       -> timer_resolution:Timer_resolution.t
       -> record_dir:string
+      -> collection_mode:Collection_mode.t
       -> Pid.t list
       -> t Deferred.Or_error.t
 
@@ -39,6 +41,7 @@ module type S = sig
     :  ?perf_maps:Perf_map.Table.t
     -> debug_print_perf_commands:bool
     -> record_dir:string
+    -> collection_mode:Collection_mode.t
     -> Decode_opts.t
     -> Decode_result.t Deferred.Or_error.t
 end

core/collection_mode.ml

@@ -0,0 +1,28 @@
+open! Core
+
+type t =
+  | Intel_processor_trace
+  | Stacktrace_sampling
+
+let select_collection_mode ~use_sampling =
+  match use_sampling with
+  | true -> Stacktrace_sampling
+  | false ->
+    (match Core_unix.access "/sys/bus/event_source/devices/intel_pt" [ `Exists ] with
+    | Ok () -> Intel_processor_trace
+    | Error _ ->
+      Core.printf
+        "Intel PT support not found. magic-trace will continue and use sampling instead.";
+      Stacktrace_sampling)
+;;
+
+let param =
+  Command.Param.(
+    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))
+;;

core/collection_mode.mli

@@ -0,0 +1,7 @@
+open! Core
+
+type t =
+  | Intel_processor_trace
+  | Stacktrace_sampling
+
+val param : t Command.Param.t

core/decode_result.ml

@@ -2,6 +2,6 @@ open Core
 open Async
 
 type t =
-  { events : Event.t Pipe.Reader.t
+  { events : Event.t Pipe.Reader.t list
   ; close_result : unit Or_error.t Deferred.t
   }

core/decode_result.mli

@@ -1,9 +1,11 @@
 open Core
 open Async
 
-(* The result of decoding events is a pipe of those events, and a deferred reason why the
-   decoder exited. *)
+(* The result of decoding events are pipe(s) of those events, and a deferred
+   reason why the decoder exited. Multiple pipes will be returned if multiple
+   snapshots were captured and processed, but they are returned in chronological
+   order. Waiting on [close_result] will wait on pipes in sequential order. *)
 type t =
-  { events : Event.t Pipe.Reader.t
+  { events : Event.t Pipe.Reader.t list
   ; close_result : unit Or_error.t Deferred.t
   }

core/event.ml

@@ -38,30 +38,24 @@ module Location = struct
 end
 
 module Ok = struct
-  module Trace = struct
+  module Data = struct
     type t =
-      { thread : Thread.t
-      ; time : Time_ns.Span.t
-      ; trace_state_change : Trace_state_change.t option [@sexp.option]
-      ; kind : Kind.t option [@sexp.option]
-      ; src : Location.t
-      ; dst : Location.t
-      }
-    [@@deriving sexp]
-  end
-
-  module Power = struct
-    type t =
-      { thread : Thread.t
-      ; time : Time_ns.Span.t
-      ; freq : int
-      }
+      | Trace of
+          { trace_state_change : Trace_state_change.t option [@sexp.option]
+          ; kind : Kind.t option [@sexp.option]
+          ; src : Location.t
+          ; dst : Location.t
+          }
+      | Power of { freq : int }
+      | Sample of { callstack : Location.t list }
     [@@deriving sexp]
   end
 
   type t =
-    | Trace of Trace.t
-    | Power of Power.t
+    { thread : Thread.t
+    ; time : Time_ns.Span.t
+    ; data : Data.t
+    }
   [@@deriving sexp]
 end
 
@@ -82,19 +76,18 @@ type t = (Ok.t, Decode_error.t) Result.t [@@deriving sexp]
 
 let thread (t : t) =
   match t with
-  | Ok (Trace { thread; _ }) | Ok (Power { thread; _ }) | Error { thread; _ } -> thread
+  | Ok { thread; _ } | Error { thread; _ } -> thread
 ;;
 
 let time (t : t) =
   match t with
-  | Ok (Trace { time; _ }) | Ok (Power { time; _ }) -> Time_ns_unix.Span.Option.some time
+  | Ok { time; _ } -> Time_ns_unix.Span.Option.some time
   | Error { time; _ } -> time
 ;;
 
 let change_time (t : t) ~f : t =
   match t with
-  | Ok (Trace ({ time; _ } as t)) -> Ok (Trace { t with time = f time })
-  | Ok (Power ({ time; _ } as t)) -> Ok (Power { t with time = f time })
+  | Ok ({ time; _ } as t) -> Ok { t with time = f time }
   | Error ({ time; _ } as u) ->
     (match%optional.Time_ns_unix.Span.Option time with
     | None -> t

core/event.mli

@@ -35,30 +35,25 @@ module Location : sig
 end
 
 module Ok : sig
-  module Trace : sig
+  module Data : sig
     type t =
-      { thread : Thread.t
-      ; time : Time_ns.Span.t
-      ; trace_state_change : Trace_state_change.t option
-      ; kind : Kind.t option
-      ; src : Location.t
-      ; dst : Location.t
-      }
-    [@@deriving sexp]
-  end
-
-  module Power : sig
-    type t =
-      { thread : Thread.t
-      ; time : Time_ns.Span.t
-      ; freq : int
-      }
+      | Trace of
+          { trace_state_change : Trace_state_change.t option
+          ; kind : Kind.t option
+          ; src : Location.t
+          ; dst : Location.t
+          } (** Represents an event collected from Intel PT. *)
+      | Power of { freq : int } (** Power event collected by Intel PT. *)
+      | Sample of { callstack : Location.t list }
+          (** Represents event collected through sampling. *)
     [@@deriving sexp]
   end
 
   type t =
-    | Trace of Trace.t
-    | Power of Power.t
+    { thread : Thread.t
+    ; time : Time_ns.Span.t
+    ; data : Data.t
+    }
   [@@deriving sexp]
 end
 

core/timer_resolution.ml

@@ -4,6 +4,7 @@ type t =
   | Low
   | Normal
   | High
+  | Sample of { freq : int }
   | Custom of
       { cyc : bool option [@sexp.option]
       ; cyc_thresh : int option [@sexp.option]
@@ -23,5 +24,5 @@ let param =
        (Command.Arg_type.create (fun str -> t_of_sexp (Sexp.of_string str))))
     ~doc:
       "RESOLUTION How granular timing information should be, one of Low, Normal, High, \
-       or Custom (default: Normal). For more info visit https://magic-trace.org/w/t"
+       Sample or Custom (default: Normal). For more info: https://magic-trace.org/w/t"
 ;;

core/timer_resolution.mli

@@ -6,14 +6,15 @@ type t =
   | Low
   | Normal
   | High
+  | Sample of { freq : int } (** Used when sampling *)
   | Custom of
       { cyc : bool option
       ; cyc_thresh : int option
       ; mtc : bool option
       ; mtc_period : int option
       ; noretcomp : bool option
       ; psb_period : int option
-      }
+      } (** Used when running with Intel PT. *)
 [@@deriving sexp]
 
 val param : t Command.Param.t

src/callgraph_mode.ml

@@ -0,0 +1,32 @@
+open! Core
+
+type t =
+  | Last_branch_record
+  | Frame_pointers
+  | Dwarf
+[@@deriving sexp]
+
+let of_string = function
+  | "lbr" -> Last_branch_record
+  | "fp" -> Frame_pointers
+  | "dwarf" -> Dwarf
+  | str -> t_of_sexp (Sexp.of_string str)
+;;
+
+let param =
+  let open Command.Param in
+  flag
+    "-callgraph-mode"
+    (optional (Command.Arg_type.create of_string))
+    ~doc:
+      " When magic-trace is running with sampling collection mode, this sets how it \
+       should reconstruct callstacks. The options are Last_branch_record (lbr), Dwarf \
+       (dwarf), and Frame_pointers (fp). Will default to Last_branch_record if supported \
+       and Dwarf otherwise."
+;;
+
+let to_perf_string = function
+  | Last_branch_record -> "lbr"
+  | Frame_pointers -> "fp"
+  | Dwarf -> "dwarf"
+;;

src/callgraph_mode.mli

@@ -0,0 +1,10 @@
+open! Core
+
+type t =
+  | Last_branch_record
+  | Frame_pointers
+  | Dwarf
+[@@deriving sexp]
+
+val param : t option Command.Param.t
+val to_perf_string : t -> string

src/import.ml

@@ -11,7 +11,8 @@ include struct
   module Subcommand = Subcommand
   module Symbol = Symbol
   module Timer_resolution = Timer_resolution
-  module Trace_mode = Trace_mode
+  module Trace_scope = Trace_scope
+  module Collection_mode = Collection_mode
   module Trace_state_change = Trace_state_change
   module When_to_snapshot = When_to_snapshot
 end

src/perf_capabilities.ml

@@ -6,6 +6,7 @@ let configurable_psb_period = bit 0
 let kernel_tracing = bit 1
 let kcore = bit 2
 let snapshot_on_exit = bit 3
+let last_branch_record = bit 4
 
 include Flags.Make (struct
   let allow_intersecting = false
@@ -16,6 +17,7 @@ include Flags.Make (struct
     [ configurable_psb_period, "configurable_psb_period"
     ; kernel_tracing, "kernel_tracing"
     ; kcore, "kcore"
+    ; last_branch_record, "last_branch_record"
     ]
   ;;
 end)
@@ -41,10 +43,35 @@ module Version = struct
 end
 
 let supports_configurable_psb_period () =
-  let cyc_cap =
-    In_channel.read_all "/sys/bus/event_source/devices/intel_pt/caps/psb_cyc"
+  try
+    let cyc_cap =
+      In_channel.read_all "/sys/bus/event_source/devices/intel_pt/caps/psb_cyc"
+    in
+    String.( = ) cyc_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. *)
+let supports_last_branch_record () =
+  let cpuinfo = In_channel.read_lines "/proc/cpuinfo" in
+  let flag_re = Re.Perl.re {|^flags\s*:\s+(\S.*)$|} |> Re.compile in
+  let flags =
+    List.filter_map cpuinfo ~f:(fun line ->
+        try
+          match Re.Group.all (Re.exec flag_re line) with
+          | [| _; flags |] -> Some (String.split ~on:' ' flags)
+          | _ -> None
+        with
+        | _ -> None)
   in
-  String.( = ) cyc_cap "1\n"
+  (* Check if pdcm in intersection of all processor flags *)
+  let contains_pdcm flags = List.exists flags ~f:(fun flag -> String.(flag = "pdcm")) in
+  List.fold flags ~init:true ~f:(fun acc flags -> acc && contains_pdcm flags)
 ;;
 
 let supports_tracing_kernel () =
@@ -77,4 +104,5 @@ let detect_exn () =
   |> set_if (supports_tracing_kernel ()) kernel_tracing
   |> set_if (supports_kcore version) kcore
   |> set_if (supports_snapshot_on_exit version) snapshot_on_exit
+  |> set_if (supports_last_branch_record ()) last_branch_record
 ;;

src/perf_capabilities.mli

@@ -9,4 +9,5 @@ val configurable_psb_period : t
 val kernel_tracing : t
 val kcore : t
 val snapshot_on_exit : t
+val last_branch_record : t
 val detect_exn : unit -> t Deferred.t