Convert Process.run_jobs_in_parallel to Core.Std.Unix

Reviewed By: jvillard

Differential Revision: D4232431

fbshipit-source-id: 93f5cee

infer/src/base/Process.ml

@@ -9,30 +9,21 @@
 
 open! Utils
 
-(** Prints information about a unix error *)
-let print_unix_error cmd e =
-  match e with
-  | Unix.Unix_error(err, _, _) ->
-      Logging.err "Cannot execute %s : %s\n%!"
-        cmd (Unix.error_message err)
-  | _ -> ()
+module Pid = Core.Std.Pid
+
+module L = Logging
+module F = Format
 
 (** Prints an error message to a log file, prints a message saying that the error can be
     found in that file, and exits, with default code 1 or a given code. *)
 let print_error_and_exit ?(exit_code=1) fmt =
-  Format.kfprintf (fun _ ->
-      Logging.do_err "%s" (Format.flush_str_formatter ());
-      let log_file = snd (Logging.log_file_names ()) in
-      Logging.stderr "@\nAn error occured. Please find details in %s@\n@\n%!" log_file;
+  F.kfprintf (fun _ ->
+      L.do_err "%s" (F.flush_str_formatter ());
+      let log_file = snd (L.log_file_names ()) in
+      L.stderr "@\nAn error occured. Please find details in %s@\n@\n%!" log_file;
       exit exit_code
     )
-    Format.str_formatter fmt
-
-(** Executes a command and catches a potential exception and prints it. *)
-let exec_command ~prog ~args env =
-  try Unix.execve prog (Array.of_list (prog :: args)) env
-  with (Unix.Unix_error _ as e) ->
-    print_unix_error (String.concat ~sep:" " (prog :: args)) e
+    F.str_formatter fmt
 
 (** Given a command to be executed, create a process to execute this command, and wait for it to
     terminate. The standard out and error are not redirected.  If the command fails to execute,
@@ -51,40 +42,35 @@ let create_process_and_wait ~prog ~args =
 (** Given a process id and a function that describes the command that the process id
     represents, prints a message explaining the command and its status, if in debug or stats mode.
     It also prints a dot to show progress of jobs being finished.  *)
-let print_status f pid (status : Unix. process_status) =
-  if Config.debug_mode || Config.stats_mode then
-    (let program = f pid in
-     match status with
-     | WEXITED status ->
-         if status = 0 then
-           Logging.out "%s OK \n%!" program
-         else
-           Logging.err "%s exited with code %d\n%!" program status
-     | WSIGNALED signal ->
-         Logging.err "%s killed by signal %d\n%!" program signal
-     | WSTOPPED _ ->
-         Logging.err "%s stopped \n%!" program);
-  Logging.stdout ".%!"
+let print_status f pid status =
+  let open Core.Std in
+  L.err "%a%s@."
+    (fun fmt pid -> F.pp_print_string fmt (f pid)) pid
+    (Unix.Exit_or_signal.to_string_hum status) ;
+  L.stdout ".%!"
 
 let start_current_jobs_count () = ref 0
 
 let waited_for_jobs = ref 0
 
+module PidMap = Map.Make (Pid)
+
 (** [wait_for_son pid_child f jobs_count] wait for pid_child
     and all the other children and update the current jobs count.
     Use f to print the job status *)
 let rec wait_for_child f current_jobs_count jobs_map =
-  let pid, status = Unix.wait () in
+  let open! Core.Std in
+  let pid, status = Unix.wait `Any in
   Pervasives.decr current_jobs_count;
   Pervasives.incr waited_for_jobs;
   print_status f pid status;
-  jobs_map := IntMap.remove pid !jobs_map;
-  if not (IntMap.is_empty !jobs_map) then
+  jobs_map := PidMap.remove pid !jobs_map;
+  if not (PidMap.is_empty !jobs_map) then
     wait_for_child f current_jobs_count jobs_map
 
 let pid_to_program jobsMap pid =
   try
-    IntMap.find pid jobsMap
+    PidMap.find pid jobsMap
   with Not_found -> ""
 
 (** [run_jobs_in_parallel jobs_stack gen_prog prog_to_string] runs the jobs in the given stack, by
@@ -93,27 +79,28 @@ let pid_to_program jobsMap pid =
     env)] where [dir_opt] is an optional directory to chdir to before executing [command] with
     [args] in [env]. [prog_to_string] is used for printing information about the job's status. *)
 let run_jobs_in_parallel jobs_stack gen_prog prog_to_string =
+  let open! Core.Std in
   let run_job () =
-    let jobs_map = ref IntMap.empty in
+    let jobs_map = ref PidMap.empty in
     let current_jobs_count = start_current_jobs_count () in
-    while not (Stack.is_empty jobs_stack) do
-      let job_prog = Stack.pop jobs_stack in
+    while not (Caml.Stack.is_empty jobs_stack) do
+      let job_prog = Caml.Stack.pop jobs_stack in
       let (dir_opt, prog, args, env) = gen_prog job_prog in
       Pervasives.incr current_jobs_count;
       match Unix.fork () with
-      | 0 ->
-          (match dir_opt with
-           | Some dir -> Unix.chdir dir
-           | None -> ());
-          exec_command ~prog ~args env
-      | pid_child ->
-          jobs_map := IntMap.add pid_child (prog_to_string job_prog) !jobs_map;
-          if Stack.length jobs_stack = 0 || !current_jobs_count >= Config.jobs then
+      | `In_the_child ->
+          Core.Std.Option.iter dir_opt ~f:Unix.chdir ;
+          Unix.exec ~prog ~args:(prog :: args) ~env ~use_path:false
+          |> Unix.handle_unix_error
+          |> never_returns
+      | `In_the_parent pid_child ->
+          jobs_map := PidMap.add pid_child (prog_to_string job_prog) !jobs_map;
+          if Caml.Stack.length jobs_stack = 0 || !current_jobs_count >= Config.jobs then
             wait_for_child (pid_to_program !jobs_map) current_jobs_count jobs_map
     done in
   run_job ();
-  Logging.stdout ".\n%!";
-  Logging.out "Waited for %d jobs" !waited_for_jobs
+  L.stdout ".@.";
+  L.out "Waited for %d jobs" !waited_for_jobs
 
 let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args =
   let open Core.Std in

infer/src/base/Process.mli

@@ -25,7 +25,7 @@ val print_error_and_exit :
     env)] where [dir_opt] is an optional directory to chdir to before executing [command] with
     [args] in [env]. [prog_to_string] is used for printing information about the job's status. *)
 val run_jobs_in_parallel :
-  'a Stack.t -> ('a -> (string option * string * string list * string array)) -> ('a -> string)
+  'a Stack.t -> ('a -> (string option * string * string list * Core.Std.Unix.env)) -> ('a -> string)
   -> unit
 
 (** Pipeline producer program into consumer program *)

infer/src/integration/CaptureCompilationDatabase.ml

@@ -64,6 +64,7 @@ let swap_command cmd =
     Config.wrappers_dir // clang
 
 let run_compilation_file compilation_database file =
+  let open! Core.Std in
   try
     let compilation_data = CompilationDatabase.find compilation_database file in
     let wrapper_cmd = swap_command compilation_data.command in
@@ -72,21 +73,10 @@ let run_compilation_file compilation_database file =
         "cdb_clang_args_" ClangQuotes.EscapedNoQuotes [compilation_data.args] in
     let args = ["@" ^ arg_file] in
     let env =
-      let env0 = Unix.environment () in
-      let found = ref false in
-      Array.iteri (fun i key_val ->
-          match String.rsplit2 key_val ~on:'=' with
-          | Some (var, args) when String.equal var CLOpt.args_env_var ->
-              found := true ;
-              env0.(i) <-
-                F.sprintf "%s=%s%c--fcp-syntax-only" CLOpt.args_env_var args CLOpt.env_var_sep
-          | _ ->
-              ()
-        ) env0 ;
-      if !found then
-        env0
-      else
-        Array.append env0 [|CLOpt.args_env_var ^ "=--fcp-syntax-only"|] in
+      `Extend [
+        (CLOpt.args_env_var,
+         String.concat ~sep:(String.of_char CLOpt.env_var_sep)
+           (Option.to_list (Sys.getenv CLOpt.args_env_var) @ ["--fcp-syntax-only"]))] in
     (Some compilation_data.dir, wrapper_cmd, args, env)
   with Not_found ->
     Process.print_error_and_exit "Failed to find compilation data for %a \n%!"