[perf] emit Trace Event json

Summary:
This adds an option `--trace-events` that generates a Chrome trace event[1] to
quickly visualise the performance of infer.

Reviewed By: mbouaziz

Differential Revision: D9831599

fbshipit-source-id: 96a33c627

infer/src/backend/Tasks.ml

@@ -40,10 +40,16 @@ module Runner = struct
   type 'a t = 'a ProcessPool.t
 
   let create ~jobs ~f =
-    ProcessPool.create ~jobs ~f
-      ~child_prelude:
-        ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *)
-         fork_protect ~f:(fun () -> () ))
+    PerfEvent.(
+      log (fun logger -> log_begin_event logger ~categories:["sys"] ~name:"fork prepare" ())) ;
+    let pool =
+      ProcessPool.create ~jobs ~f
+        ~child_prelude:
+          ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *)
+           fork_protect ~f:(fun () -> () ))
+    in
+    PerfEvent.(log (fun logger -> log_end_event logger ())) ;
+    pool
 
 
   let run runner ~tasks =

infer/src/backend/mergeCapture.ml

@@ -153,3 +153,10 @@ let merge_captured_targets () =
   MergeResults.merge_buck_flavors_results infer_deps_file ;
   process_merge_file infer_deps_file ;
   L.progress "Merging captured Buck targets took %a@\n%!" Mtime.Span.pp (Mtime_clock.count time0)
+
+
+(* shadowed for tracing *)
+let merge_captured_targets () =
+  PerfEvent.(log (fun logger -> log_begin_event logger ~name:"merge buck targets" ())) ;
+  merge_captured_targets () ;
+  PerfEvent.(log (fun logger -> log_end_event logger ()))

infer/src/backend/ondemand.ml

@@ -192,6 +192,19 @@ let run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc =
         log_error_and_continue exn initial_summary (FKcrash (Exn.to_string exn)) )
 
 
+(* shadowed for tracing *)
+let run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc =
+  PerfEvent.(
+    log (fun logger ->
+        let callee_pname = Procdesc.get_proc_name callee_pdesc in
+        log_begin_event logger ~name:"ondemand" ~categories:["backend"]
+          ~arguments:[("proc", `String (Typ.Procname.to_string callee_pname))]
+          () )) ;
+  let summary = run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc in
+  PerfEvent.(log (fun logger -> log_end_event logger ())) ;
+  summary
+
+
 let analyze_proc ?caller_pdesc callee_pdesc =
   let callbacks = Option.value_exn !callbacks_ref in
   (* wrap [callbacks.analyze_ondemand] to update the status bar *)

infer/src/base/Config.ml

@@ -181,6 +181,8 @@ let duplicates_filename = "duplicates.txt"
 
 let events_dir_name = "events"
 
+let trace_events_file = "perf_events.json"
+
 (** exit code to use for the --fail-on-issue option *)
 let fail_on_issue_exit_code = 2
 
@@ -2145,6 +2147,11 @@ and threadsafe_aliases =
     "Specify custom annotations that should be considered aliases of @ThreadSafe"
 
 
+and trace_events =
+  CLOpt.mk_bool ~long:"trace-events"
+    (Printf.sprintf "Emit Chrome performance trace events in infer-out/%s" trace_events_file)
+
+
 and trace_join =
   CLOpt.mk_bool ~deprecated:["trace_join"] ~long:"trace-join"
     "Detailed tracing information during prop join operations"
@@ -2961,6 +2968,8 @@ and threadsafe_aliases = !threadsafe_aliases
 
 and trace_error = !trace_error
 
+and trace_events = !trace_events
+
 and trace_ondemand = !trace_ondemand
 
 and trace_join = !trace_join

infer/src/base/Config.mli

@@ -195,6 +195,8 @@ val starvation_issues_dir_name : string
 
 val trace_absarray : bool
 
+val trace_events_file : string
+
 val undo_join : bool
 
 val unsafe_unret : string
@@ -647,6 +649,8 @@ val threadsafe_aliases : Yojson.Basic.json
 
 val trace_error : bool
 
+val trace_events : bool
+
 val trace_ondemand : bool
 
 val trace_join : bool

infer/src/base/PerfEvent.ml

@@ -0,0 +1,285 @@
+(*
+ * Copyright (c) 2018-present, Facebook, Inc.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+open! IStd
+module F = Format
+module L = Logging
+
+module Json = struct
+  (** do not break lines *)
+  let pp_seq pp f l = Pp.seq ~sep:"," pp f l
+
+  let pp_string f s = F.fprintf f "\"%s\"" (Escape.escape_json s)
+
+  let pp_field pp_value f field_name field_value =
+    Format.fprintf f "%a:%a" pp_string field_name pp_value field_value
+
+
+  (** only what we need for now *)
+  type t = [`Int of int | `String of string | `Assoc of (string * t) list | `List of t list]
+
+  let rec pp_assoc_field f (key, value) = pp_field pp f key value
+
+  and pp f = function
+    | `Int i ->
+        F.pp_print_int f i
+    | `String s ->
+        pp_string f s
+    | `Assoc fields ->
+        F.fprintf f "{%a}" (pp_seq pp_assoc_field) fields
+    | `List items ->
+        F.fprintf f "[%a]" (pp_seq pp) items
+end
+
+module JsonFragment = struct
+  type t = AssocBegin | AssocEnd | ListBegin | ListItemSeparator | ListEnd
+
+  let to_string = function
+    | AssocBegin ->
+        "AssocBegin"
+    | AssocEnd ->
+        "AssocEnd"
+    | ListBegin ->
+        "ListBegin"
+    | ListItemSeparator ->
+        "ListItemSeparator"
+    | ListEnd ->
+        "ListEnd"
+
+
+  type pp_state = Outside | InAssocFirst | InAssocMiddle | InList
+
+  let string_of_state = function
+    | Outside ->
+        "Outside"
+    | InAssocFirst ->
+        "InAssocFirst"
+    | InAssocMiddle ->
+        "InAssocMiddle"
+    | InList ->
+        "InList"
+
+
+  (** for some limited (not thread-safe) form of safety, and to know when we need to print separators
+   *)
+  let pp_state = ref [Outside]
+
+  let pp f json_fragment =
+    match (json_fragment, !pp_state) with
+    | AssocBegin, ((Outside | InList) :: _ as state) ->
+        pp_state := InAssocFirst :: state
+    | AssocEnd, (InAssocFirst | InAssocMiddle) :: state' ->
+        F.pp_print_string f "}" ;
+        pp_state := state'
+    | ListBegin, ((Outside | InList) :: _ as state) ->
+        F.pp_print_string f "[" ;
+        pp_state := InList :: state
+    | ListItemSeparator, InList :: _ ->
+        F.pp_print_string f ","
+    | ListEnd, InList :: state0 ->
+        F.pp_print_string f "]" ;
+        pp_state := state0
+    | _ ->
+        L.die InternalError "Unexpected json fragment \"%s\" in state [%a]"
+          (to_string json_fragment)
+          (Pp.seq (Pp.to_string ~f:string_of_state))
+          !pp_state
+
+
+  let pp_assoc_field pp_value f key value =
+    match !pp_state with
+    | InAssocFirst :: state0 ->
+        F.pp_print_string f "{" ;
+        Json.pp_field pp_value f key value ;
+        pp_state := InAssocMiddle :: state0
+    | InAssocMiddle :: _ ->
+        F.pp_print_string f "," ;
+        Json.pp_field pp_value f key value
+    | _ ->
+        L.die InternalError "Unexpected assoc field \"%t\" in state [%a]"
+          (fun f -> Json.pp_field pp_value f key value)
+          (Pp.seq (Pp.to_string ~f:string_of_state))
+          !pp_state
+end
+
+type event_type = Begin | Complete | End | Instant
+
+(* TODO(2018): add [Thread] when we have multicore OCaml :) *)
+type scope = Global | Process
+
+(* initialised at the start of the program *)
+let t0 = Mtime_clock.now ()
+
+let pp_arguments_field f arguments =
+  match arguments with
+  | [] ->
+      ()
+  | _ :: _ ->
+      JsonFragment.pp_assoc_field Json.pp f "args" (`Assoc arguments)
+
+
+let pp_categories_field f categories =
+  match categories with
+  | [] ->
+      ()
+  | _ :: _ ->
+      let pp_categories f categories =
+        Format.fprintf f "\"%a\"" (Json.pp_seq F.pp_print_string) categories
+      in
+      JsonFragment.pp_assoc_field pp_categories f "cat" categories
+
+
+let pp_duration_field f duration =
+  JsonFragment.pp_assoc_field Json.pp f "dur" (`Int (Mtime.Span.to_us duration |> Float.to_int))
+
+
+let pp_event_type_field f event_type =
+  let pp_event_type f event_type =
+    match event_type with
+    | Begin ->
+        Json.pp_string f "B"
+    | Complete ->
+        Json.pp_string f "X"
+    | End ->
+        Json.pp_string f "E"
+    | Instant ->
+        Json.pp_string f "i"
+  in
+  JsonFragment.pp_assoc_field pp_event_type f "ph" event_type
+
+
+let pp_process_id_field f pid = JsonFragment.pp_assoc_field Pid.pp f "pid" pid
+
+let pp_name_field f name = JsonFragment.pp_assoc_field Json.pp f "name" (`String name)
+
+let pp_scope_field f scope =
+  let pp_scope f = function Global -> Json.pp_string f "g" | Process -> Json.pp_string f "p" in
+  JsonFragment.pp_assoc_field pp_scope f "s" scope
+
+
+let pp_timestamp_field f ts_opt =
+  let ts = match ts_opt with None -> Mtime_clock.elapsed () | Some t -> Mtime.span t0 t in
+  JsonFragment.pp_assoc_field Json.pp f "ts" (`Int (Mtime.Span.to_us ts |> Float.to_int))
+
+
+let log_begin_event f ?timestamp ?categories ?arguments ~name () =
+  JsonFragment.pp f AssocBegin ;
+  pp_event_type_field f Begin ;
+  pp_name_field f name ;
+  pp_timestamp_field f timestamp ;
+  pp_process_id_field f (ProcessPoolState.get_pid ()) ;
+  Option.iter categories ~f:(pp_categories_field f) ;
+  Option.iter arguments ~f:(pp_arguments_field f) ;
+  JsonFragment.pp f AssocEnd
+
+
+let log_end_event f ?timestamp ?arguments () =
+  JsonFragment.pp f AssocBegin ;
+  pp_event_type_field f End ;
+  pp_timestamp_field f timestamp ;
+  Option.iter arguments ~f:(pp_arguments_field f) ;
+  pp_process_id_field f (ProcessPoolState.get_pid ()) ;
+  JsonFragment.pp f AssocEnd
+
+
+let log_complete_event f ~timestamp ?duration ?categories ?arguments ~name () =
+  JsonFragment.pp f AssocBegin ;
+  pp_event_type_field f Complete ;
+  pp_name_field f name ;
+  pp_timestamp_field f (Some timestamp) ;
+  pp_process_id_field f (ProcessPoolState.get_pid ()) ;
+  Option.iter duration ~f:(pp_duration_field f) ;
+  Option.iter categories ~f:(pp_categories_field f) ;
+  Option.iter arguments ~f:(pp_arguments_field f) ;
+  JsonFragment.pp f AssocEnd
+
+
+let log_instant_event f ?timestamp ~name scope =
+  JsonFragment.pp f AssocBegin ;
+  pp_event_type_field f Instant ;
+  pp_name_field f name ;
+  pp_timestamp_field f timestamp ;
+  pp_process_id_field f (ProcessPoolState.get_pid ()) ;
+  pp_scope_field f scope ;
+  JsonFragment.pp f AssocEnd
+
+
+type logger = F.formatter
+
+let register_gc_stats logger =
+  let alarms = ref [] in
+  let gc_alarm = Gc.Expert.Alarm.create (fun () -> alarms := Mtime_clock.now () :: !alarms) in
+  Epilogues.register ~description:"recording gc alarms" ~f:(fun () ->
+      Gc.Expert.Alarm.delete gc_alarm ;
+      List.iter !alarms ~f:(fun timestamp ->
+          log_instant_event logger ~timestamp ~name:"gc_major" Process ;
+          JsonFragment.pp logger ListItemSeparator ;
+          F.fprintf logger "%!" ) )
+
+
+let logger =
+  lazy
+    (let log_file =
+       let results_dir =
+         (* if invoked in a sub-dir (e.g., in Buck integrations), log inside the original log
+              file *)
+         Sys.getenv Config.infer_top_results_dir_env_var
+         |> Option.value ~default:Config.results_dir
+       in
+       results_dir ^/ Config.trace_events_file
+     in
+     let is_toplevel_process = CommandLineOption.is_originator && not !ProcessPoolState.in_child in
+     ( if is_toplevel_process then
+       let preexisting_logfile = PolyVariantEqual.( = ) (Sys.file_exists log_file) `Yes in
+       if preexisting_logfile then Unix.unlink log_file ) ;
+     let out_channel = Pervasives.open_out_gen [Open_append; Open_creat] 0o666 log_file in
+     let logger = F.formatter_of_out_channel out_channel in
+     register_gc_stats logger ;
+     if is_toplevel_process then (
+       JsonFragment.pp logger ListBegin ;
+       F.fprintf logger "%!" ;
+       Epilogues.register_late ~description:"closing perf trace json" ~f:(fun () ->
+           log_instant_event logger ~name:"end" Global ;
+           JsonFragment.pp logger ListEnd ;
+           F.fprintf logger "@." ;
+           Out_channel.close out_channel ) ) ;
+     logger)
+
+
+(* export logging functions that output a list element at a time and flushes so that multiple
+   processes can write to the same file and not garble each other's output. This should mostly work
+   as appending to a file is atomic as long as the write is not too big. *)
+
+let log_begin_event f ?timestamp ?categories ?arguments ~name () =
+  log_begin_event f ?timestamp ?categories ?arguments ~name () ;
+  JsonFragment.pp f ListItemSeparator ;
+  F.fprintf f "%!"
+
+
+let log_end_event f ?timestamp ?arguments () =
+  log_end_event f ?timestamp ?arguments () ;
+  JsonFragment.pp f ListItemSeparator ;
+  F.fprintf f "%!"
+
+
+let log_complete_event f ~timestamp ?duration ?categories ?arguments ~name () =
+  log_complete_event f ~timestamp ?duration ?categories ?arguments ~name () ;
+  JsonFragment.pp f ListItemSeparator ;
+  F.fprintf f "%!"
+
+
+let log_instant_event f ?timestamp ~name scope =
+  log_instant_event f ?timestamp ~name scope ;
+  JsonFragment.pp f ListItemSeparator ;
+  F.fprintf f "%!"
+
+
+let log =
+  if Config.trace_events then fun f_log ->
+    let logger = Lazy.force logger in
+    f_log logger
+  else fun _ -> ()

infer/src/base/PerfEvent.mli

@@ -0,0 +1,44 @@
+(*
+ * Copyright (c) 2018-present, Facebook, Inc.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+open! IStd
+
+module Json : sig
+  (** only what we need for now *)
+  type t = [`Int of int | `String of string | `Assoc of (string * t) list | `List of t list]
+end
+
+type scope = Global | Process
+
+type logger
+
+val log_begin_event :
+     logger
+  -> ?timestamp:Mtime.t
+  -> ?categories:string list
+  -> ?arguments:(string * Json.t) list
+  -> name:string
+  -> unit
+  -> unit
+
+val log_end_event :
+  logger -> ?timestamp:Mtime.t -> ?arguments:(string * Json.t) list -> unit -> unit
+
+val log_complete_event :
+     logger
+  -> timestamp:Mtime.t
+  -> ?duration:Mtime.Span.t
+  -> ?categories:string list
+  -> ?arguments:(string * Json.t) list
+  -> name:string
+  -> unit
+  -> unit
+  [@@warning "-32"]
+
+val log_instant_event : logger -> ?timestamp:Mtime.t -> name:string -> scope -> unit
+
+val log : (logger -> unit) -> unit

infer/src/base/ProcessPool.ml

@@ -202,6 +202,7 @@ let fork_child ~child_prelude ~slot (updates_r, updates_w) ~f =
       (* Pin to a core. [setcore] does the modulo <number of cores> for us. *)
       Setcore.setcore slot ;
       ProcessPoolState.in_child := true ;
+      ProcessPoolState.reset_pid () ;
       child_prelude () ;
       let updates_oc = Unix.out_channel_of_descr updates_w in
       let send_to_parent (message : worker_message) = marshal_to_pipe updates_oc message in
@@ -261,3 +262,9 @@ let run pool tasks =
   done ;
   wait_all pool ;
   TaskBar.finish pool.task_bar
+
+
+let run pool tasks =
+  PerfEvent.(log (fun logger -> log_instant_event logger ~name:"start process pool" Global)) ;
+  run pool tasks ;
+  PerfEvent.(log (fun logger -> log_instant_event logger ~name:"end process pool" Global))

infer/src/base/ProcessPoolState.ml

@@ -11,3 +11,9 @@ open! IStd
 let in_child = ref false
 
 let update_status = ref (fun _ _ -> ())
+
+let pid = ref (lazy (Unix.getpid ()))
+
+let reset_pid () = pid := lazy (Unix.getpid ())
+
+let get_pid () = Lazy.force !pid

infer/src/base/ProcessPoolState.mli

@@ -13,3 +13,7 @@ val in_child : bool ref
 val update_status : (Mtime.t -> string -> unit) ref
 (** Ping the task bar whenever a new task is started with the start time and a description for the
     task *)
+
+val get_pid : unit -> Pid.t
+
+val reset_pid : unit -> unit

infer/src/base/ResultsDatabase.ml

@@ -97,9 +97,11 @@ let register_statement =
 
 
 let with_registered_statement get_stmt ~f =
+  PerfEvent.(log (fun logger -> log_begin_event logger ~name:"sql op" ())) ;
   let stmt, db = get_stmt () in
   let result = f db stmt in
   Sqlite3.reset stmt |> SqliteUtils.check_result_code db ~log:"reset prepared statement" ;
+  PerfEvent.(log (fun logger -> log_end_event logger ())) ;
   result
 
 

infer/src/base/SqliteUtils.ml

@@ -23,7 +23,11 @@ let check_result_code ?(fatal = false) db ~log rc =
 
 let exec db ~log ~stmt =
   (* Call [check_result_code] with [fatal:true] and catch exceptions to rewrite the error message. This avoids allocating the error string when not needed. *)
-  try check_result_code ~fatal:true db ~log (Sqlite3.exec db stmt) with Error err ->
+  PerfEvent.log (fun logger ->
+      PerfEvent.log_begin_event logger ~name:"sql exec" ~arguments:[("stmt", `String log)] () ) ;
+  let rc = Sqlite3.exec db stmt in
+  PerfEvent.(log (fun logger -> log_end_event logger ())) ;
+  try check_result_code ~fatal:true db ~log rc with Error err ->
     error ~fatal:true "exec: %s (%s)" err (Sqlite3.errmsg db)
 
 

infer/src/biabduction/Prop.ml

@@ -2648,6 +2648,6 @@ let mk_ptsto_exp = Normalize.mk_ptsto_exp
 
 let mk_ptsto = Normalize.mk_ptsto
 
-let normalize = Normalize.normalize
+let normalize tenv prop = Normalize.normalize tenv prop
 
-let prop_atom_and = Normalize.prop_atom_and
+let prop_atom_and tenv ?footprint prop atom = Normalize.prop_atom_and tenv ?footprint prop atom

infer/src/integration/Driver.ml

@@ -298,12 +298,26 @@ let capture ~changed_files = function
       capture_with_compilation_database ~changed_files json_cdb
 
 
+(* shadowed for tracing *)
+let capture ~changed_files mode =
+  PerfEvent.(log (fun logger -> log_begin_event logger ~name:"capture" ())) ;
+  capture ~changed_files mode ;
+  PerfEvent.(log (fun logger -> log_end_event logger ()))
+
+
 let execute_analyze ~changed_files =
   register_perf_stats_report PerfStats.TotalBackend ;
   InferAnalyze.main ~changed_files ;
   PerfStats.get_reporter PerfStats.TotalBackend ()
 
 
+(* shadowed for tracing *)
+let execute_analyze ~changed_files =
+  PerfEvent.(log (fun logger -> log_begin_event logger ~name:"analyze" ())) ;
+  execute_analyze ~changed_files ;
+  PerfEvent.(log (fun logger -> log_end_event logger ()))
+
+
 let report ?(suppress_console = false) () =
   let report_json = Config.(results_dir ^/ report_json) in
   InferPrint.main ~report_json:(Some report_json) ;
@@ -336,6 +350,13 @@ let report ?(suppress_console = false) () =
           (String.concat ~sep:" " args)
 
 
+(* shadowed for tracing *)
+let report ?suppress_console () =
+  PerfEvent.(log (fun logger -> log_begin_event logger ~name:"report" ())) ;
+  report ?suppress_console () ;
+  PerfEvent.(log (fun logger -> log_end_event logger ()))
+
+
 let error_nothing_to_analyze mode =
   let clean_command_opt = clean_compilation_command mode in
   let nothing_to_compile_msg = "Nothing to compile." in

infer/src/istd/Escape.ml

@@ -130,6 +130,8 @@ let escape_filename s =
   escape_map map s
 
 
+let escape_json s = escape_map (function '"' -> Some "\\\"" | '\\' -> Some "\\\\" | _ -> None) s
+
 let escape_double_quotes s = escape_map (function '"' -> Some "\\\"" | _ -> None) s
 
 let escape_in_single_quotes s =

infer/src/istd/Escape.mli

@@ -27,6 +27,9 @@ val escape_url : string -> string
 val escape_filename : string -> string
 (** escape a string to be used as a file name *)
 
+val escape_json : string -> string
+(** escape characters in the string so it becomes a valid JSON string *)
+
 val escape_double_quotes : string -> string
 (** replaces double-quote with backslash double-quote *)