diff --git a/infer/src/backend/InferAnalyze.ml b/infer/src/backend/InferAnalyze.ml index 8fcbb04ec..aa0b49663 100644 --- a/infer/src/backend/InferAnalyze.ml +++ b/infer/src/backend/InferAnalyze.ml @@ -21,11 +21,11 @@ let analyze_source_file : SourceFile.t Tasks.doer = fun source_file -> DB.Results_dir.init source_file ; let exe_env = Exe_env.mk () in - L.(debug Analysis Medium) "@\nProcessing '%a'@." SourceFile.pp source_file ; - (* clear cache for each source file to avoid it growing unboundedly *) - clear_caches () ; - Callbacks.analyze_file exe_env source_file ; - if Config.write_html then Printer.write_all_html_files source_file + L.task_progress SourceFile.pp source_file ~f:(fun () -> + (* clear cache for each source file to avoid it growing unboundedly *) + clear_caches () ; + Callbacks.analyze_file exe_env source_file ; + if Config.write_html then Printer.write_all_html_files source_file ) let output_json_makefile_stats clusters = diff --git a/infer/src/backend/Tasks.ml b/infer/src/backend/Tasks.ml index 8a2ac36e6..de2cdd7b4 100644 --- a/infer/src/backend/Tasks.ml +++ b/infer/src/backend/Tasks.ml @@ -11,9 +11,7 @@ module L = Logging type 'a doer = 'a -> unit let run_sequentially ~(f: 'a doer) (tasks: 'a list) : unit = - let task_bar = - if Config.show_progress_bar then TaskBar.create_multiline ~jobs:1 else TaskBar.create_dummy () - in + let task_bar = TaskBar.create ~jobs:1 in (ProcessPoolState.update_status := fun t status -> TaskBar.update_status task_bar ~slot:0 t status ; @@ -38,19 +36,13 @@ let fork_protect ~f x = module Runner = struct - type 'a t = {pool: 'a ProcessPool.t; task_bar: TaskBar.t} + type 'a t = 'a ProcessPool.t let create ~jobs ~f = - let task_bar = - if Config.show_progress_bar then TaskBar.create_multiline ~jobs else TaskBar.create_dummy () - in - { pool= - ProcessPool.create ~jobs - ~child_prelude: - ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *) - fork_protect ~f:(fun () -> () )) - task_bar ~f - ; task_bar } + ProcessPool.create ~jobs ~f + ~child_prelude: + ((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *) + fork_protect ~f:(fun () -> () )) let run runner ~tasks = @@ -58,6 +50,5 @@ module Runner = struct Pervasives.flush_all () ; (* Compact heap before forking *) Gc.compact () ; - ProcessPool.run runner.pool tasks ; - TaskBar.finish runner.task_bar + ProcessPool.run runner tasks end diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index dc8bbc7a6..3df5d6b45 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -1747,6 +1747,14 @@ and progress_bar = "Show a progress bar" +and progress_bar_style = + CLOpt.mk_symbol ~long:"progress-bar-style" + ~symbols:[("auto", `Auto); ("plain", `Plain); ("multiline", `MultiLine)] ~eq:Pervasives.( = ) + ~default:`Auto ~in_help:[(Analyze, manual_generic); (Capture, manual_generic)] + "Style of the progress bar. $(b,auto) selects $(b,multiline) if connected to a tty, otherwise \ + $(b,plain)." + + and project_root = CLOpt.mk_path ~deprecated:["project_root"; "-project_root"; "pr"] ~long:"project-root" ~short:'C' ~default:CLOpt.init_work_dir @@ -2747,6 +2755,18 @@ and[@warning "-32"] procedures_per_process = !procedures_per_process and procedures_source_file = !procedures_source_file +and progress_bar = + if !progress_bar then + match !progress_bar_style with + | `Auto when Unix.(isatty stdin && isatty stderr) -> + `MultiLine + | `Auto -> + `Plain + | (`Plain | `MultiLine) as style -> + style + else `Quiet + + and procs_csv = !procs_csv and project_root = !project_root @@ -2799,8 +2819,6 @@ and select = !select and show_buckets = !print_buckets -and show_progress_bar = !progress_bar - and siof = !siof and siof_check_iostreams = !siof_check_iostreams diff --git a/infer/src/base/Config.mli b/infer/src/base/Config.mli index 0f55c7c34..aca0ab6b5 100644 --- a/infer/src/base/Config.mli +++ b/infer/src/base/Config.mli @@ -520,6 +520,8 @@ val procs_csv : string option val project_root : string +val progress_bar : [`MultiLine | `Plain | `Quiet] + val quandary : bool val quandary_endpoints : Yojson.Basic.json @@ -562,8 +564,6 @@ val select : int option val show_buckets : bool -val show_progress_bar : bool - val siof : bool val siof_check_iostreams : bool diff --git a/infer/src/base/Logging.ml b/infer/src/base/Logging.ml index 6da67f093..4009b0132 100644 --- a/infer/src/base/Logging.ml +++ b/infer/src/base/Logging.ml @@ -208,6 +208,15 @@ let phase fmt = log ~to_console:false phase_file_fmts fmt let progress fmt = log ~to_console:(not Config.quiet) progress_file_fmts fmt +let task_progress ~f pp x = + let to_console = + match Config.progress_bar with `Plain -> true | `Quiet | `MultiLine -> false + in + log ~to_console progress_file_fmts "%a starting@." pp x ; + f () ; + log ~to_console progress_file_fmts "%a DONE@." pp x + + let user_warning fmt = log ~to_console:(not Config.quiet) user_warning_file_fmts fmt let user_error fmt = log ~to_console:true user_error_file_fmts fmt diff --git a/infer/src/base/Logging.mli b/infer/src/base/Logging.mli index 30d48533b..56b19115f 100644 --- a/infer/src/base/Logging.mli +++ b/infer/src/base/Logging.mli @@ -23,6 +23,10 @@ val environment_info : ('a, F.formatter, unit) format -> 'a val progress : ('a, F.formatter, unit) format -> 'a (** print immediately to standard error unless --quiet is specified *) +val task_progress : f:(unit -> unit) -> (F.formatter -> 'a -> unit) -> 'a -> unit +(** [task_progress ~f pp x] executes [f] and log progress [pp x] in the log file and also on the + console unless there is an active task bar *) + val result : ('a, F.formatter, unit) format -> 'a (** Emit a result to stdout. Use only if the output format is stable and useful enough that it may conceivably get piped to another program, ie, almost never (use [progress] instead otherwise). diff --git a/infer/src/base/ProcessPool.ml b/infer/src/base/ProcessPool.ml index 8fff41ccf..a13049f70 100644 --- a/infer/src/base/ProcessPool.ml +++ b/infer/src/base/ProcessPool.ml @@ -229,8 +229,9 @@ let fork_child ~child_prelude ~slot (updates_r, updates_w) ~f = {pid; down_pipe= Unix.out_channel_of_descr to_child_w} -let create : jobs:int -> child_prelude:(unit -> unit) -> TaskBar.t -> f:('a -> unit) -> 'a t = - fun ~jobs ~child_prelude task_bar ~f -> +let create : jobs:int -> child_prelude:(unit -> unit) -> f:('a -> unit) -> 'a t = + fun ~jobs ~child_prelude ~f -> + let task_bar = TaskBar.create ~jobs in (* Pipe to communicate from children to parent. Only one pipe is needed: the messages sent by children include the identifier of the child sending the message (its [slot]). This way there is only one pipe to wait on for updates. *) @@ -257,4 +258,5 @@ let run pool tasks = while not (List.is_empty pool.tasks && pool.idle_children >= pool.jobs) do process_updates pool buffer ; TaskBar.refresh pool.task_bar done ; - wait_all pool + wait_all pool ; + TaskBar.finish pool.task_bar diff --git a/infer/src/base/ProcessPool.mli b/infer/src/base/ProcessPool.mli index 23f5412a1..c6deb0fc5 100644 --- a/infer/src/base/ProcessPool.mli +++ b/infer/src/base/ProcessPool.mli @@ -26,7 +26,7 @@ open! IStd (** A ['a t] process pool accepts tasks of type ['a]. ['a] will be marshalled over a Unix pipe.*) type _ t -val create : jobs:int -> child_prelude:(unit -> unit) -> TaskBar.t -> f:('a -> unit) -> 'a t +val create : jobs:int -> child_prelude:(unit -> unit) -> f:('a -> unit) -> 'a t (** Create a new pool of processes running [jobs] jobs in parallel *) val run : 'a t -> 'a list -> unit diff --git a/infer/src/base/TaskBar.ml b/infer/src/base/TaskBar.ml index 489cdc37c..99a96c2ca 100644 --- a/infer/src/base/TaskBar.ml +++ b/infer/src/base/TaskBar.ml @@ -7,7 +7,6 @@ open! IStd module F = Format -module L = Logging (** {2 arbitrary constants } *) @@ -35,7 +34,7 @@ type multiline_info = type t = | MultiLine of multiline_info (** interactive *) | NonInteractive (** display terse progress, to use when output is redirected *) - | Dummy (** ignore everything *) + | Quiet (** ignore everything *) (** print [c] [n] times *) let rec pp_n c fmt n = @@ -123,25 +122,27 @@ let refresh_multiline task_bar = () -let refresh = function MultiLine t -> refresh_multiline t | NonInteractive | Dummy -> () +let refresh = function MultiLine t -> refresh_multiline t | NonInteractive | Quiet -> () -let create_multiline ~jobs = - if Unix.(isatty stdin) && Unix.(isatty stderr) then ( - let t0 = Mtime_clock.now () in - let task_bar = - { jobs - ; jobs_statuses= Array.create ~len:jobs "idle" - ; jobs_start_times= Array.create ~len:jobs t0 - ; start_time= Mtime_clock.counter () - ; tasks_done= 0 - ; tasks_total= 0 } - in - ANSITerminal.erase Below ; MultiLine task_bar ) - else NonInteractive +let create ~jobs = + match Config.progress_bar with + | `Quiet -> + Quiet + | `Plain -> + NonInteractive + | `MultiLine -> + let t0 = Mtime_clock.now () in + let task_bar = + { jobs + ; jobs_statuses= Array.create ~len:jobs "idle" + ; jobs_start_times= Array.create ~len:jobs t0 + ; start_time= Mtime_clock.counter () + ; tasks_done= 0 + ; tasks_total= 0 } + in + ANSITerminal.erase Below ; MultiLine task_bar -let create_dummy () = Dummy - let update_status_multiline task_bar ~slot:job t0 status = (task_bar.jobs_statuses).(job) <- status ; (task_bar.jobs_start_times).(job) <- t0 ; @@ -152,7 +153,7 @@ let update_status task_bar ~slot t0 status = match task_bar with | MultiLine t -> update_status_multiline t ~slot t0 status - | NonInteractive | Dummy -> + | NonInteractive | Quiet -> () @@ -160,7 +161,7 @@ let set_tasks_total task_bar n = match task_bar with | MultiLine multiline -> multiline.tasks_total <- n - | NonInteractive | Dummy -> + | NonInteractive | Quiet -> () @@ -168,9 +169,7 @@ let tasks_done_add task_bar n = match task_bar with | MultiLine multiline -> multiline.tasks_done <- multiline.tasks_done + n - | NonInteractive -> - L.progress "#%!" - | Dummy -> + | NonInteractive | Quiet -> () @@ -178,7 +177,7 @@ let tasks_done_reset task_bar = match task_bar with | MultiLine multiline -> multiline.tasks_done <- 0 - | NonInteractive | Dummy -> + | NonInteractive | Quiet -> () @@ -188,8 +187,8 @@ let finish = function Out_channel.output_string stderr "\n" ; ANSITerminal.erase Below ; Out_channel.flush stderr - | NonInteractive | Dummy -> + | NonInteractive | Quiet -> () -let is_interactive = function MultiLine _ -> true | NonInteractive | Dummy -> false +let is_interactive = function MultiLine _ -> true | NonInteractive | Quiet -> false diff --git a/infer/src/base/TaskBar.mli b/infer/src/base/TaskBar.mli index cbb026038..b83cfda55 100644 --- a/infer/src/base/TaskBar.mli +++ b/infer/src/base/TaskBar.mli @@ -12,15 +12,12 @@ type t val refresh : t -> unit (** draw the taskbar *) -val create_multiline : jobs:int -> t -(** creates a multiline task bar for running [jobs] jobs in parallel *) - -val create_dummy : unit -> t -(** silent task bar *) +val create : jobs:int -> t +(** creates a task bar for running [jobs] jobs in parallel *) val update_status : t -> slot:int -> Mtime.t -> string -> unit (** [update_status task_bar ~slot t status] records an event described by [status] on slot [slot] - started at time [t] *) + started at time [t] *) val set_tasks_total : t -> int -> unit (** set the total number of tasks to do *)