Merge pull request #4517 from rgrinberg/accurate-process-time

Use wait3 to accurately time spawned processes

bench/bench.ml

@@ -1,4 +1,6 @@
 open Stdune
+module Process = Dune_engine.Process
+module Config = Dune_util.Config
 
 module Json = struct
   include Chrome_trace.Json
@@ -69,8 +71,6 @@ module Package = struct
   let make org name = { org; name }
 
   let clone t =
-    let module Process = Dune_engine.Process in
-    let module Config = Dune_util.Config in
     let stdout_to = Process.Io.(file Config.dev_null Out) in
     let stderr_to = Process.Io.(file Config.dev_null Out) in
     let stdin_from = Process.Io.(null In) in
@@ -83,6 +83,42 @@ let duniverse =
   [ pkg "ocaml-dune" "dune-bench" ]
 
 let prepare_workspace () =
+  Fiber.parallel_iter duniverse ~f:(fun (pkg : Package.t) ->
+      Fpath.rm_rf pkg.name;
+      Format.eprintf "cloning %s/%s@." pkg.org pkg.name;
+      Package.clone pkg)
+
+let dune_build () =
+  let stdin_from = Process.(Io.null In) in
+  let stdout_to = Process.(Io.file Config.dev_null Out) in
+  let stderr_to = Process.(Io.file Config.dev_null Out) in
+  let open Fiber.O in
+  let+ times =
+    Process.run_with_times (Lazy.force dune) ~stdin_from ~stdout_to ~stderr_to
+      [ "build"; "@install"; "--root"; "." ]
+  in
+  times.elapsed_time
+
+let run_bench () =
+  let open Fiber.O in
+  let* clean = dune_build () in
+  let+ zero =
+    let open Fiber.O in
+    let rec zero acc n =
+      if n = 0 then
+        Fiber.return (List.rev acc)
+      else
+        let* time = dune_build () in
+        zero (time :: acc) (pred n)
+    in
+    zero [] 5
+  in
+  (clean, zero)
+
+let () =
+  Dune_util.Log.init ~file:No_log_file ();
+  let dir = Temp.create Dir ~prefix:"dune." ~suffix:".bench" in
+  Sys.chdir (Path.to_string dir);
   let module Scheduler = Dune_engine.Scheduler in
   let config =
     { Scheduler.Config.concurrency = 10
@@ -91,42 +127,22 @@ let prepare_workspace () =
     ; stats = None
     }
   in
-  Scheduler.Run.go config
-    ~on_event:(fun _ _ -> ())
-    (fun () ->
-      Fiber.parallel_iter duniverse ~f:(fun (pkg : Package.t) ->
-          Fpath.rm_rf pkg.name;
-          Format.eprintf "cloning %s/%s@." pkg.org pkg.name;
-          Package.clone pkg))
-
-let with_timer f =
-  let start = Unix.time () in
-  let res = f () in
-  let stop = Unix.time () in
-  (stop -. start, res)
-
-let () =
-  Dune_util.Log.init ~file:No_log_file ();
-  let dir = Temp.create Dir ~prefix:"dune." ~suffix:".bench" in
-  Sys.chdir (Path.to_string dir);
-  prepare_workspace ();
-  let clean, _ =
-    with_timer (fun () -> Sys.command "dune build @install --root . 1>&2")
-  in
-  let zeros =
-    List.init 5 ~f:(fun _ ->
-        let time, _ =
-          with_timer (fun () -> Sys.command "dune build @install --root . 1>&2")
-        in
-        `Float time)
+  let clean, zero =
+    Scheduler.Run.go config
+      ~on_event:(fun _ _ -> ())
+      (fun () ->
+        let open Fiber.O in
+        let* () = prepare_workspace () in
+        run_bench ())
   in
+  let zero = List.map zero ~f:(fun t -> `Float t) in
   let size =
     let stat : Unix.stats = Path.stat_exn (Lazy.force dune) in
     stat.st_size
   in
   let results =
     [ { Output.name = "clean_build"; metrics = [ ("time", `Float clean) ] }
-    ; { Output.name = "zero_build"; metrics = [ ("time", `List zeros) ] }
+    ; { Output.name = "zero_build"; metrics = [ ("time", `List zero) ] }
     ; { Output.name = "dune_size"; metrics = [ ("size", `Int size) ] }
     ]
   in

otherlibs/stdune-unstable/dune

@@ -10,4 +10,4 @@
   dune_filesystem_stubs)
  (foreign_stubs
   (language c)
-  (names fcntl_stubs)))
+  (names fcntl_stubs wait3_stubs)))

otherlibs/stdune-unstable/proc.ml

@@ -22,3 +22,41 @@ let restore_cwd_and_execve prog argv ~env =
     Stdlib.do_at_exit ();
     Unix.execve prog argv env
   )
+
+module Resource_usage = struct
+  type t =
+    { user_cpu_time : float
+    ; system_cpu_time : float
+    }
+end
+
+module Times = struct
+  type t =
+    { elapsed_time : float
+    ; resource_usage : Resource_usage.t option
+    }
+end
+
+module Process_info = struct
+  type t =
+    { pid : Pid.t
+    ; status : Unix.process_status
+    ; end_time : float
+    ; resource_usage : Resource_usage.t option
+    }
+end
+
+external stub_wait3 :
+  Unix.wait_flag list -> int * Unix.process_status * float * Resource_usage.t
+  = "dune_wait3"
+
+let wait flags =
+  if Sys.win32 then
+    Code_error.raise "wait3 not available on windows" []
+  else
+    let pid, status, end_time, resource_usage = stub_wait3 flags in
+    { Process_info.pid = Pid.of_int pid
+    ; status
+    ; end_time
+    ; resource_usage = Some resource_usage
+    }

otherlibs/stdune-unstable/proc.mli

@@ -1 +1,30 @@
 val restore_cwd_and_execve : string -> string list -> env:Env.t -> _
+
+module Resource_usage : sig
+  type t =
+    { user_cpu_time : float
+          (** Same as the "user" time reported by the "time" command *)
+    ; system_cpu_time : float
+          (** Same as the "sys" time reported by the "time" command *)
+    }
+end
+
+module Times : sig
+  type t =
+    { elapsed_time : float
+          (** Same as the "real" time reported by the "time" command *)
+    ; resource_usage : Resource_usage.t option
+    }
+end
+
+module Process_info : sig
+  type t =
+    { pid : Pid.t
+    ; status : Unix.process_status
+    ; end_time : float  (** Time at which the process finished. *)
+    ; resource_usage : Resource_usage.t option
+    }
+end
+
+(** This function is not implemented on Windows *)
+val wait : Unix.wait_flag list -> Process_info.t

otherlibs/stdune-unstable/wait3_stubs.c

@@ -0,0 +1,76 @@
+#include <caml/mlvalues.h>
+
+#ifdef _WIN32
+#include <caml/fail.h>
+
+void dune_wait3(value flags) {
+  caml_failwith("wait3: not supported on windows");
+}
+
+#else
+
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/unixsupport.h>
+
+#include <sys/resource.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#define TAG_WEXITED 0
+#define TAG_WSIGNALED 1
+#define TAG_WSTOPPED 2
+
+CAMLextern int caml_convert_signal_number(int);
+CAMLextern int caml_rev_convert_signal_number(int);
+
+static value alloc_process_status(int status) {
+  value st;
+
+  if (WIFEXITED(status)) {
+    st = caml_alloc_small(1, TAG_WEXITED);
+    Field(st, 0) = Val_int(WEXITSTATUS(status));
+  } else if (WIFSTOPPED(status)) {
+    st = caml_alloc_small(1, TAG_WSTOPPED);
+    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
+  } else {
+    st = caml_alloc_small(1, TAG_WSIGNALED);
+    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
+  }
+  return st;
+}
+
+static int wait_flag_table[] = {WNOHANG, WUNTRACED};
+
+value dune_wait3(value flags) {
+  CAMLparam1(flags);
+  CAMLlocal2(times, res);
+
+  int pid, status, cv_flags;
+  struct timeval tp;
+  cv_flags = caml_convert_flag_list(flags, wait_flag_table);
+
+  struct rusage ru;
+
+  caml_enter_blocking_section();
+  pid = wait3(&status, cv_flags, &ru);
+  gettimeofday(&tp, NULL);
+  caml_leave_blocking_section();
+  if (pid == -1)
+    uerror("wait3", Nothing);
+
+  times = caml_alloc_small(2 * Double_wosize, Double_array_tag);
+  Store_double_field(times, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
+  Store_double_field(times, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
+
+  res = caml_alloc_tuple(4);
+  Store_field(res, 0, Val_int(pid));
+  Store_field(res, 1, alloc_process_status(status));
+  Store_field(res, 2, caml_copy_double(((double) tp.tv_sec + (double) tp.tv_usec / 1e6)));
+  Store_field(res, 3, times);
+  CAMLreturn(res);
+}
+
+#endif