[oomguard]

Reviewed By: jvillard

Differential Revision: D15352091

fbshipit-source-id: 6e09777d6

infer/man/man1/infer-full.txt

@@ -1471,6 +1471,13 @@ INTERNAL OPTIONS
            Activates: Skip the re-execution phase (Conversely:
            --no-only-footprint)
 
+       --oom-threshold int
+           Available memory threshold (in MB) below which multi-worker
+           scheduling throttles back work. Only for use on Linux.
+
+       --oom-threshold-reset
+           Cancel the effect of --oom-threshold.
+
        --passthroughs
            Activates: In error traces, show intermediate steps that propagate
            data. When false, error traces are shorter and show only direct

infer/src/backend/TaskScheduler.ml

@@ -19,8 +19,9 @@ let chain (gen1 : 'a task_generator) (gen2 : 'a task_generator) : 'a task_genera
     !gen1_returned_empty
   in
   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; next}
+  {n_tasks; is_empty; finished; next}
 
 
 let count_procedures () =
@@ -64,22 +65,21 @@ let bottom_up sources : target task_generator =
         CallGraph.flag_reachable g n.pname ;
         Some (Procname n.pname)
   in
-  let next target_opt =
+  let finished = function
+    | File _ ->
+        assert false
+    | Procname pname ->
+        scheduled := Typ.Procname.Set.remove pname !scheduled ;
+        CallGraph.remove_reachable g pname
+  in
+  let next () =
     (* do construction here, to avoid having the call graph into forked workers *)
     if not !initialized then (
       CallGraph.build_from_sources g sources ;
       initialized := true ) ;
-    ( match target_opt with
-    | None ->
-        ()
-    | Some (File _) ->
-        assert false
-    | Some (Procname pname) ->
-        scheduled := Typ.Procname.Set.remove pname !scheduled ;
-        CallGraph.remove_reachable g pname ) ;
     next_aux ()
   in
-  {n_tasks; is_empty; next}
+  {n_tasks; is_empty; finished; next}
 
 
 let of_sources sources =

infer/src/backend/Tasks.ml

@@ -68,7 +68,8 @@ let gen_of_list (lst : 'a list) : 'a task_generator =
   let content = ref lst in
   let n_tasks = List.length lst in
   let is_empty () = List.is_empty !content in
-  let next _finished_item =
+  let finished _finished_item = () in
+  let next () =
     match !content with
     | [] ->
         None
@@ -76,4 +77,4 @@ let gen_of_list (lst : 'a list) : 'a task_generator =
         content := xs ;
         Some x
   in
-  {n_tasks; is_empty; next}
+  {n_tasks; is_empty; finished; next}

infer/src/base/Config.ml

@@ -1700,6 +1700,12 @@ and only_show =
     "Show the list of reports and exit"
 
 
+and oom_threshold =
+  CLOpt.mk_int_opt ~long:"oom-threshold"
+    "Available memory threshold (in MB) below which multi-worker scheduling throttles back work. \
+     Only for use on Linux."
+
+
 and passthroughs =
   CLOpt.mk_bool ~long:"passthroughs" ~default:false
     "In error traces, show intermediate steps that propagate data. When false, error traces are \
@@ -2861,6 +2867,8 @@ and nullsafe_strict_containers = !nullsafe_strict_containers
 
 and no_translate_libs = not !headers
 
+and oom_threshold = !oom_threshold
+
 and only_cheap_debug = !only_cheap_debug
 
 and only_footprint = !only_footprint

infer/src/base/Config.mli

@@ -498,6 +498,8 @@ val nullsafe : bool
 
 val nullsafe_strict_containers : bool
 
+val oom_threshold : int option
+
 val only_cheap_debug : bool
 
 val only_footprint : bool

infer/src/base/ProcessPool.ml

@@ -11,7 +11,8 @@ module L = Logging
 
 type child_info = {pid: Pid.t; down_pipe: Out_channel.t}
 
-type 'a task_generator = {n_tasks: int; is_empty: unit -> bool; next: 'a option -> 'a option}
+type 'a task_generator =
+  {n_tasks: int; is_empty: unit -> bool; finished: 'a -> unit; next: unit -> 'a option}
 
 (** the state of the pool *)
 type 'a t =
@@ -145,14 +146,60 @@ let idle_children pool =
 
 
 let send_work_to_child pool slot =
-  match pool.tasks.next pool.pending_items.(slot) with
-  | None ->
-      TaskBar.update_status pool.task_bar ~slot (Mtime_clock.now ()) "idle" ;
-      pool.pending_items.(slot) <- None
-  | Some x ->
-      let {down_pipe} = pool.slots.(slot) in
-      pool.pending_items.(slot) <- Some x ;
-      marshal_to_pipe down_pipe (Do x)
+  pool.tasks.next ()
+  |> Option.iter ~f:(fun x ->
+         let {down_pipe} = pool.slots.(slot) in
+         pool.pending_items.(slot) <- Some x ;
+         marshal_to_pipe down_pipe (Do x) )
+
+
+let proc_meminfo = "/proc/meminfo"
+
+(* this should not be called in any other arch than Linux *)
+let should_throttle =
+  Option.iter Config.oom_threshold ~f:(fun _threshold ->
+      match Sys.file_exists proc_meminfo with
+      | `Yes ->
+          ()
+      | _ ->
+          L.die UserError "Can't access %s even though oom detection was requested." proc_meminfo
+  ) ;
+  let currently_throttled = ref false in
+  let get_available_memory_MB () =
+    let rec aux in_channel =
+      match In_channel.input_line in_channel with
+      | None ->
+          L.die UserError
+            "Cannot find available memory line in %s even though oom detection was requested."
+            proc_meminfo
+      | Some line -> (
+        try Scanf.sscanf line "MemAvailable: %u kB" (fun mem_kB -> mem_kB / 1024)
+        with Scanf.Scan_failure _ -> aux in_channel )
+    in
+    Utils.with_file_in proc_meminfo ~f:aux
+  in
+  fun threshold ->
+    let available_memory = get_available_memory_MB () in
+    if available_memory < threshold then (
+      if not !currently_throttled then
+        L.user_warning
+          "Available memory (%d MB) is below configured threshold, throttling back scheduling \
+           analysis work.@."
+          available_memory ;
+      currently_throttled := true )
+    else (
+      if !currently_throttled then
+        L.user_warning
+          "Available memory (%d MB) exceeds configured threshold, resuming scheduling analysis \
+           work.@."
+          available_memory ;
+      currently_throttled := false ) ;
+    !currently_throttled
+
+
+let send_work_to_child pool slot =
+  let throttled = Option.exists Config.oom_threshold ~f:should_throttle in
+  if not throttled then send_work_to_child pool slot
 
 
 (** main dispatch function that responds to messages from worker processes and updates the taskbar
@@ -176,6 +223,9 @@ let process_updates pool buffer =
            killall pool ~slot "see backtrace above"
        | Ready slot ->
            TaskBar.tasks_done_add pool.task_bar 1 ;
+           TaskBar.update_status pool.task_bar ~slot (Mtime_clock.now ()) "idle" ;
+           Option.iter pool.pending_items.(slot) ~f:(fun work ->
+               pool.tasks.finished work ; pool.pending_items.(slot) <- None ) ;
            send_work_to_child pool slot )
 
 

infer/src/base/ProcessPool.mli

@@ -32,12 +32,12 @@ type 'a task_generator =
         (** total number of tasks -- 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 *)
-  ; next: 'a option -> 'a option
-        (** [next (Some finished_item)] generates the next work item.
-            The worker requesting more work has just finished processing [finished_item]. 
-            [None] is passed when the worker was previously idle. 
-            
-            In particular, it is OK to for [next] to return [None] even when [is_empty] 
+  ; finished: 'a -> unit
+        (** Process pool calls [finished x] when a worker finishes item [x]. This is only called 
+            if [next ()] has previously returned [Some x] and [x] was sent to a worker. *)
+  ; next: unit -> 'a option
+        (** [next ()] generates the next work item. If [is_empty ()] is true then [next ()] 
+            must return [None].  However, it is OK to for [next ()] to return [None] when [is_empty] 
             is false.  This corresponds to the case where there is more work to be done, 
             but it is not schedulable until some already scheduled work is finished. *)
   }