Make the task bar display progress more accurately

Summary:
Move control of the number of remaining task from the taskbar [1] to each task generator [2]. This means that the call graph scheduler can count all procedures in mutually-recursive cycles as dealt with when only those procedures are left.

[1] : `infer/src/base/TaskBar.ml`
[2] : type defined in `/infer/src/base/ProcessPool.ml`

Reviewed By: ngorogiannis

Differential Revision: D16071497

fbshipit-source-id: aa9436638

infer/src/backend/TaskScheduler.ml

@@ -12,7 +12,7 @@ type target = Procname of Typ.Procname.t | File of SourceFile.t
 type 'a task_generator = 'a Tasks.task_generator
 
 let chain (gen1 : 'a task_generator) (gen2 : 'a task_generator) : 'a task_generator =
-  let n_tasks = gen1.n_tasks + gen2.n_tasks in
+  let remaining_tasks () = gen1.remaining_tasks () + gen2.remaining_tasks () in
   let gen1_returned_empty = ref false in
   let gen1_is_empty () =
     gen1_returned_empty := !gen1_returned_empty || gen1.is_empty () ;
@@ -21,7 +21,7 @@ let chain (gen1 : 'a task_generator) (gen2 : 'a task_generator) : 'a task_genera
   let is_empty () = gen1_is_empty () && gen2.is_empty () in
   let finished x = if gen1_is_empty () then gen2.finished x else gen1.finished x in
   let next x = if gen1_is_empty () then gen2.next x else gen1.next x in
-  {n_tasks; is_empty; finished; next}
+  {remaining_tasks; is_empty; finished; next}
 
 
 let count_procedures () =
@@ -43,7 +43,8 @@ let initial_call_graph_capacity = 1009
 
 let bottom_up sources : target task_generator =
   (* this will potentially grossly overapproximate the tasks *)
-  let n_tasks = count_procedures () in
+  let remaining = ref (count_procedures ()) in
+  let remaining_tasks () = !remaining in
   let g = CallGraph.create initial_call_graph_capacity in
   let initialized = ref false in
   let pending : CallGraph.Node.t list ref = ref [] in
@@ -51,6 +52,7 @@ let bottom_up sources : target task_generator =
   let is_empty () =
     let empty = !initialized && List.is_empty !pending && Typ.Procname.Set.is_empty !scheduled in
     if empty then (
+      remaining := 0 ;
       L.progress "Finished call graph scheduling, %d procs remaining (in cycles).@."
         (CallGraph.n_procs g) ;
       if Config.debug_level_analysis > 0 then CallGraph.to_dotty g "cycles.dot" ;
@@ -76,6 +78,7 @@ let bottom_up sources : target task_generator =
     | File _ ->
         assert false
     | Procname pname ->
+        decr remaining ;
         scheduled := Typ.Procname.Set.remove pname !scheduled ;
         CallGraph.remove_reachable g pname
   in
@@ -86,7 +89,7 @@ let bottom_up sources : target task_generator =
       initialized := true ) ;
     next_aux ()
   in
-  {n_tasks; is_empty; finished; next}
+  {remaining_tasks; is_empty; finished; next}
 
 
 let of_sources sources =

infer/src/backend/Tasks.ml

@@ -12,20 +12,6 @@ type 'a doer = 'a -> unit
 
 type 'a task_generator = 'a ProcessPool.task_generator
 
-let run_sequentially ~(f : 'a doer) (tasks : 'a list) : unit =
-  let task_bar = TaskBar.create ~jobs:1 in
-  (ProcessPoolState.update_status :=
-     fun t status ->
-       TaskBar.update_status task_bar ~slot:0 t status ;
-       TaskBar.refresh task_bar) ;
-  TaskBar.set_tasks_total task_bar (List.length tasks) ;
-  TaskBar.tasks_done_reset task_bar ;
-  List.iter
-    ~f:(fun task -> f task ; TaskBar.tasks_done_add task_bar 1 ; TaskBar.refresh task_bar)
-    tasks ;
-  TaskBar.finish task_bar
-
-
 let fork_protect ~f x =
   (* this is needed whenever a new process is started *)
   Epilogues.reset () ;
@@ -66,9 +52,10 @@ end
 
 let gen_of_list (lst : 'a list) : 'a task_generator =
   let content = ref lst in
-  let n_tasks = List.length lst in
+  let length = ref (List.length lst) in
+  let remaining_tasks () = !length in
   let is_empty () = List.is_empty !content in
-  let finished _finished_item = () in
+  let finished _finished_item = decr length in
   let next () =
     match !content with
     | [] ->
@@ -77,4 +64,23 @@ let gen_of_list (lst : 'a list) : 'a task_generator =
         content := xs ;
         Some x
   in
-  {n_tasks; is_empty; finished; next}
+  {remaining_tasks; is_empty; finished; next}
+
+
+let run_sequentially ~(f : 'a doer) (tasks : 'a list) : unit =
+  let task_generator = gen_of_list tasks in
+  let task_bar = TaskBar.create ~jobs:1 in
+  (ProcessPoolState.update_status :=
+     fun t status ->
+       TaskBar.update_status task_bar ~slot:0 t status ;
+       TaskBar.refresh task_bar) ;
+  TaskBar.set_tasks_total task_bar (task_generator.remaining_tasks ()) ;
+  TaskBar.tasks_done_reset task_bar ;
+  let rec run_tasks () =
+    if not (task_generator.is_empty ()) then (
+      Option.iter (task_generator.next ()) ~f:(fun t -> f t ; task_generator.finished t) ;
+      TaskBar.set_remaining_tasks task_bar (task_generator.remaining_tasks ()) ;
+      TaskBar.refresh task_bar ;
+      run_tasks () )
+  in
+  run_tasks () ; TaskBar.finish task_bar

infer/src/base/ProcessPool.ml

@@ -20,7 +20,10 @@ type child_info = {pid: Pid.t; down_pipe: Out_channel.t}
 type 'a child_state = Initializing | Idle | Processing of 'a
 
 type 'a task_generator =
-  {n_tasks: int; is_empty: unit -> bool; finished: 'a -> unit; next: unit -> 'a option}
+  { remaining_tasks: unit -> int
+  ; is_empty: unit -> bool
+  ; finished: 'a -> unit
+  ; next: unit -> 'a option }
 
 (** the state of the pool *)
 type 'a t =
@@ -234,7 +237,7 @@ let process_updates pool buffer =
            Unix.wait (`Pid pid) |> ignore ;
            killall pool ~slot "see backtrace above"
        | Ready slot ->
-           TaskBar.tasks_done_add pool.task_bar 1 ;
+           TaskBar.set_remaining_tasks pool.task_bar (pool.tasks.remaining_tasks ()) ;
            TaskBar.update_status pool.task_bar ~slot (Mtime_clock.now ()) "idle" ;
            ( match pool.children_states.(slot) with
            | Processing work ->
@@ -361,13 +364,9 @@ let create :
 
 
 let run pool =
-  TaskBar.set_tasks_total pool.task_bar pool.tasks.n_tasks ;
+  let total_tasks = pool.tasks.remaining_tasks () in
+  TaskBar.set_tasks_total pool.task_bar total_tasks ;
   TaskBar.tasks_done_reset pool.task_bar ;
-  (* Start with a negative number of completed tasks to account for the initial [Ready]
-     messages. All the children start by sending [Ready], which is interpreted by the parent process
-     as "one task has been completed". Starting with a negative number is a simple if hacky way to
-     account for these spurious "done" tasks.  *)
-  TaskBar.tasks_done_add pool.task_bar (-pool.jobs) ;
   (* allocate a buffer for reading children updates once for the whole run *)
   let buffer = Bytes.create buffer_size in
   (* wait for all children to run out of tasks *)

infer/src/base/ProcessPool.mli

@@ -28,8 +28,8 @@ type _ t
 
 (** abstraction for generating jobs *)
 type 'a task_generator =
-  { n_tasks: int
+  { remaining_tasks: unit -> int
-        (** total number of tasks -- only used for reporting, so imprecision is not a bug *)
+        (** number of tasks remaining to complete -- only used for reporting, so imprecision is not a bug *)
   ; is_empty: unit -> bool
         (** when should the main loop of the task manager stop expecting new tasks *)
   ; finished: 'a -> unit

infer/src/base/TaskBar.ml

@@ -168,10 +168,10 @@ let set_tasks_total task_bar n =
       ()
 
 
-let tasks_done_add task_bar n =
+let set_remaining_tasks task_bar n =
   match task_bar with
   | MultiLine multiline ->
-      multiline.tasks_done <- multiline.tasks_done + n
+      multiline.tasks_done <- multiline.tasks_total - n
   | NonInteractive | Quiet ->
       ()
 

infer/src/base/TaskBar.mli

@@ -25,8 +25,8 @@ val set_tasks_total : t -> int -> unit
 val tasks_done_reset : t -> unit
 (** record that 0 tasks have been completed so far *)
 
-val tasks_done_add : t -> int -> unit
+val set_remaining_tasks : t -> int -> unit
-(** record that a number of tasks have been completed *)
+(** set the number of tasks remaining to complete *)
 
 val finish : t -> unit
 (** tear down the task bar and ready the terminal for more output *)