From 81d616a50bc81b364bb628b7de0b2dc7e53818fc Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Fri, 9 Dec 2016 16:27:13 -0800 Subject: [PATCH] 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 | 85 ++++++++----------- infer/src/base/Process.mli | 2 +- .../integration/CaptureCompilationDatabase.ml | 20 ++--- 3 files changed, 42 insertions(+), 65 deletions(-) diff --git a/infer/src/base/Process.ml b/infer/src/base/Process.ml index 17594653e..afabbf69f 100644 --- a/infer/src/base/Process.ml +++ b/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 diff --git a/infer/src/base/Process.mli b/infer/src/base/Process.mli index d5e9e36ee..b07bebf81 100644 --- a/infer/src/base/Process.mli +++ b/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 *) diff --git a/infer/src/integration/CaptureCompilationDatabase.ml b/infer/src/integration/CaptureCompilationDatabase.ml index 5d04bd7a1..aaf0df065 100644 --- a/infer/src/integration/CaptureCompilationDatabase.ml +++ b/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%!"