Catapult improvements

CHANGES.md

@@ -40,6 +40,8 @@ unreleased
 
 - Add `--trace-file` option to trace dune internals (#1639, fix #1180, @emillon)
 
+- Remove `--stats` and track fd usage in `--trace-file` (#1667, @emillon)
+
 1.6.2 (05/12/2018)
 ------------------
 

bin/common.ml

@@ -26,8 +26,7 @@ type t =
   ; default_target        : string
   (* For build & runtest only *)
   ; watch : bool
-  ; stats : bool
-  ; catapult_trace_file : string option
+  ; stats_trace_file : string option
   }
 
 let prefix_target common s = common.target_prefix ^ s
@@ -53,8 +52,7 @@ let set_common_other c ~targets =
       ; c.orig_args
       ; targets
       ];
-  if c.stats then Stats.enable ();
-  Option.iter ~f:Stats.enable_catapult c.catapult_trace_file
+  Option.iter ~f:Stats.enable c.stats_trace_file
 
 let set_common c ~targets =
   set_dirs c;
@@ -329,13 +327,7 @@ let term =
          & info ["diff-command"] ~docs
              ~doc:"Shell command to use to diff files.
                    Use - to disable printing the diff.")
-  and stats =
-    Arg.(value
-         & flag
-         & info ["stats"] ~docs
-             ~doc:{|Record and print statistics about Dune resource usage.
-                   |})
-  and catapult_trace_file =
+  and stats_trace_file =
     Arg.(value
          & opt (some string) None
          & info ["trace-file"] ~docs ~docv:"FILE"
@@ -394,8 +386,7 @@ let term =
   ; build_dir
   ; default_target
   ; watch
-  ; stats
-  ; catapult_trace_file
+  ; stats_trace_file
   }
 
 let term =

bin/common.mli

@@ -22,8 +22,7 @@ type t =
   ; default_target        : string
   (* For build & runtest only *)
   ; watch : bool
-  ; stats : bool
-  ; catapult_trace_file : string option
+  ; stats_trace_file : string option
   }
 
 val prefix_target : t -> string -> string

bootstrap.ml

@@ -37,7 +37,6 @@ let dirs =
   ; "src/dag"                , Some "Dag"
   ; "src/memo"               , Some "Memo"
   ; "src/ocaml-config"       , Some "Ocaml_config"
-  ; "src/catapult"           , Some "Catapult"
   ; "vendor/boot"            , None
   ; "src/dune_lang"              , Some "Dune_lang"
   ; "src"                    , None

src/catapult/catapult.ml

@@ -1,25 +1,13 @@
 open Stdune
 
-type ops =
+type t =
   { print : string -> unit
   ; close : unit -> unit
   ; get_time : unit -> float
   ; gc_stat : unit -> Gc.stat
   ; mutable after_first_event : bool
   }
 
-type mode =
-  | Disabled
-  | Using of ops
-
-type t =
-  { mutable mode : mode
-  }
-
-let make () =
-  { mode = Disabled
-  }
-
 let fake_gc_stat =
   { Gc.minor_words = 0.
   ; promoted_words = 0.
@@ -44,33 +32,25 @@ let fake time_ref buf =
   let close () = () in
   let get_time () = !time_ref in
   let gc_stat () = fake_gc_stat in
-  { mode =
-      Using
-        { print
-        ; close
-        ; get_time
-        ; gc_stat
-        ; after_first_event = false
-        }
+  { print
+  ; close
+  ; get_time
+  ; gc_stat
+  ; after_first_event = false
   }
 
-let close t = match t.mode with
-  | Disabled -> ()
-  | Using {print; close; _} ->
-    print "]\n";
-    close ()
+let close {print; close; _} =
+  print "]\n";
+  close ()
 
-let path_ops path =
+let make path =
   let channel = Pervasives.open_out path in
   let print s = Pervasives.output_string channel s in
   let close () = Pervasives.close_out channel in
   let get_time () = Unix.gettimeofday () in
   let gc_stat () = Gc.stat () in
   {print; close; get_time; gc_stat; after_first_event = false}
 
-let enable t path =
-  t.mode <- Using (path_ops path)
-
 let next_leading_char t =
   match t.after_first_event with
   | true -> ','
@@ -118,7 +98,8 @@ type event =
   ; args : string list
   }
 
-let emit_process t {start_time; program; args} ~time =
+let on_process_end t {start_time; program; args} =
+  let time = t.get_time () in
   let dur = time -. start_time in
   let name = Filename.basename program in
   printf
@@ -130,7 +111,8 @@ let emit_process t {start_time; program; args} ~time =
     (color_of_name name)
     (pp_args args)
 
-let emit_counter t ~time key value =
+let emit_counter t key value =
+  let time = t.get_time () in
   printf
     t
     {|{"name": %S, "pid": 0, "tid": 0, "ph": "C", "ts": %s, "args": {%S: %d}}|}
@@ -139,29 +121,14 @@ let emit_counter t ~time key value =
     "value"
     value
 
-let emit_counters t ~time (stat: Gc.stat) =
-  emit_counter t ~time "live_words" stat.live_words;
-  emit_counter t ~time "free_words" stat.free_words;
-  emit_counter t ~time "stack_size" stat.stack_size
+let emit_gc_counters t =
+  let stat = t.gc_stat () in
+  emit_counter t "live_words" stat.live_words;
+  emit_counter t "free_words" stat.free_words;
+  emit_counter t "stack_size" stat.stack_size
 
 let on_process_start t ~program ~args =
-  match t.mode with
-  | Disabled ->
-    { start_time = 0.
-    ; program
-    ; args
-    }
-  | Using t ->
-    { start_time = t.get_time ()
-    ; program
-    ; args
-    }
-
-let on_process_end t event =
-  match t.mode with
-  | Disabled -> ()
-  | Using t ->
-    let time = t.get_time () in
-    emit_process t event ~time;
-    let stat = t.gc_stat () in
-    emit_counters t stat ~time
+  { start_time = t.get_time ()
+  ; program
+  ; args
+  }

src/catapult/catapult.mli

@@ -5,10 +5,10 @@
     It is basically an output channel. *)
 type t
 
-(** Create a new reporter.
-    Initially, the reporter is in a disabled state where events are ignored and
-    no trace file is written. *)
-val make : unit -> t
+(** Create a reporter: open a trace file and further events will be logged into
+    it. It is necessary to call [close] on the reporter to make the file valid.
+*)
+val make : string -> t
 
 (** Return a fake reporter that reads time in a reference and writes JSON
     objects to a buffer. *)
@@ -17,10 +17,6 @@ val fake : float ref -> Buffer.t -> t
 (** Output trailing data to make the underlying file valid JSON, and close it. *)
 val close : t -> unit
 
-(** Enable tracing: open a trace file and further events will be logged into it.
-    It is necessary to call [close] on the reporter to make the file valid. *)
-val enable : t -> string -> unit
-
 type event
 
 (** Prepare data related to the processus. This will capture the current time to
@@ -29,3 +25,9 @@ val on_process_start : t -> program:string -> args:string list -> event
 
 (** Capture the current time and output a complete event. *)
 val on_process_end : t -> event -> unit
+
+(** Emit a counter event. This is measuring the value of an integer variable. *)
+val emit_counter : t -> string -> int -> unit
+
+(** Emit counter events for GC stats. *)
+val emit_gc_counters : t -> unit

src/process.ml

@@ -246,12 +246,6 @@ let cmdline_approximate_length prog args =
   List.fold_left args ~init:(String.length prog) ~f:(fun acc arg ->
     acc + String.length arg)
 
-let with_process ~program ~args fiber =
-  let event = Catapult.on_process_start Stats.catapult ~program ~args in
-  fiber >>| fun result ->
-  Catapult.on_process_end Stats.catapult event;
-  result
-
 let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr)
       ~env ~purpose fail_mode prog args =
   Scheduler.wait_for_available_job ()
@@ -325,7 +319,7 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr)
   in
   Output.release stdout_to;
   Output.release stderr_to;
-  with_process ~program:prog_str ~args (Scheduler.wait_for_process pid)
+  Stats.with_process ~program:prog_str ~args (Scheduler.wait_for_process pid)
   >>| fun exit_status ->
   Option.iter response_file ~f:Path.unlink;
   let output =

src/stats.boot.ml

@@ -0,0 +1,5 @@
+let enable _path = ()
+
+let record () = ()
+
+let with_process ~program:_ ~args:_ fiber = fiber

src/stats.ml

@@ -1,7 +1,5 @@
 open Stdune
 
-let enabled = ref false
-
 module Fd_count = struct
   type t = Unknown | This of int
 
@@ -30,45 +28,30 @@ module Fd_count = struct
       | value -> value
       end
     | files -> This (Array.length files - 1 (* -1 for the dirfd *))
-
-  let map2 ~f a b =
-    match a, b with
-    | Unknown, x | x, Unknown -> x
-    | This a, This b -> This (f a b)
-
-  let max = map2 ~f:max
-
-  let to_string = function
-    | Unknown -> "unknown"
-    | This n -> string_of_int n
 end
 
-type t =
-  { mutable fds : Fd_count.t
-  }
-
-let observed_max =
-  { fds = Unknown
-  }
+let catapult = ref None
 
 let record () =
-  if !enabled then begin
-    let fds = Fd_count.get () in
-    observed_max.fds <- Fd_count.max fds observed_max.fds
-  end
-
-let dump () =
-  let pr fmt = Printf.eprintf (fmt ^^ "\n") in
-  pr "Stats:";
-  pr "max opened fds: %s" (Fd_count.to_string observed_max.fds);
-  flush stderr
-
-let enable () =
-  enabled := true;
-  at_exit dump
-
-let catapult = Catapult.make ()
-
-let enable_catapult path =
-  Catapult.enable catapult path;
-  at_exit (fun () -> Catapult.close catapult)
+  Option.iter !catapult ~f:(fun reporter ->
+    Catapult.emit_gc_counters reporter;
+    match Fd_count.get () with
+    | This fds ->
+      Catapult.emit_counter reporter "fds" fds
+    | Unknown -> ()
+  )
+
+let enable path =
+  let reporter = Catapult.make path in
+  catapult := Some reporter;
+  at_exit (fun () -> Catapult.close reporter)
+
+let with_process ~program ~args fiber =
+  match !catapult with
+  | None -> fiber
+  | Some reporter ->
+    let open Fiber.O in
+    let event = Catapult.on_process_start reporter ~program ~args in
+    fiber >>| fun result ->
+    Catapult.on_process_end reporter event;
+    result

src/stats.mli

@@ -1,11 +1,10 @@
 (** Collect stats during the execution of dune *)
 
 (** Enable stats recording *)
-val enable : unit -> unit
+val enable : string -> unit
 
 (** If stats recording is enabled, collect stats now *)
 val record : unit -> unit
 
-val catapult : Catapult.t
-
-val enable_catapult : string -> unit
+(** Collect data about a subprocess *)
+val with_process : program:string -> args:string list -> 'a Fiber.t -> 'a Fiber.t

test/blackbox-tests/test-cases/trace-file/run.t

@@ -2,16 +2,17 @@
 
 This captures the commands that are being run:
 
-  $ <trace.json grep '"X"' | sed -E 's/ [0-9]+/ .../g'
-  [{"name": "ocamlc.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_uninterruptible", "args": ["-config"]}
-  ,{"name": "ocamldep.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_runnable", "args": ["-modules","-impl","prog.ml"]}
-  ,{"name": "ocamlc.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_uninterruptible", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-bin-annot","-I",".prog.eobjs","-no-alias-deps","-opaque","-o",".prog.eobjs/prog.cmo","-c","-impl","prog.ml"]}
-  ,{"name": "ocamlopt.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_running", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-I",".prog.eobjs","-intf-suffix",".ml","-no-alias-deps","-opaque","-o",".prog.eobjs/prog.cmx","-c","-impl","prog.ml"]}
-  ,{"name": "ocamlopt.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_running", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-o","prog.exe",".prog.eobjs/prog.cmx"]}
+  $ <trace.json grep '"X"' | cut -c 2- | sed -E 's/ [0-9]+/ .../g'
+  {"name": "ocamlc.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_uninterruptible", "args": ["-config"]}
+  {"name": "ocamldep.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_runnable", "args": ["-modules","-impl","prog.ml"]}
+  {"name": "ocamlc.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_uninterruptible", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-bin-annot","-I",".prog.eobjs","-no-alias-deps","-opaque","-o",".prog.eobjs/prog.cmo","-c","-impl","prog.ml"]}
+  {"name": "ocamlopt.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_running", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-I",".prog.eobjs","-intf-suffix",".ml","-no-alias-deps","-opaque","-o",".prog.eobjs/prog.cmx","-c","-impl","prog.ml"]}
+  {"name": "ocamlopt.opt", "pid": ..., "tid": ..., "ph": "X", "dur": ..., "ts": ..., "color": "thread_state_running", "args": ["-w","@a-4-29-40-41-42-44-45-48-58-59-60-40","-strict-sequence","-strict-formats","-short-paths","-keep-locs","-g","-o","prog.exe",".prog.eobjs/prog.cmx"]}
 
 As well as data about the garbage collector:
 
-  $ <trace.json grep '"C"' | sed -E 's/ [0-9]+/ .../g' | sort -u
-  ,{"name": "free_words", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
-  ,{"name": "live_words", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
-  ,{"name": "stack_size", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
+  $ <trace.json grep '"C"' | cut -c 2- | sed -E 's/ [0-9]+/ .../g' | sort -u
+  {"name": "fds", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
+  {"name": "free_words", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
+  {"name": "live_words", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}
+  {"name": "stack_size", "pid": ..., "tid": ..., "ph": "C", "ts": ..., "args": {"value": ...}}

test/unit-tests/catapult.mlt

@@ -26,6 +26,9 @@ time := 30.;;
 Catapult.on_process_end c e;;
 [%%ignore]
 
+Catapult.emit_gc_counters c;;
+[%%ignore]
+
 Catapult.close c;;
 [%%ignore]