[driver] Make `infer -- analyze` almost python-clean

Summary:
This diff implements enough of the functionality in the python code in
the OCaml toplevel driver that executing `infer -- analyze` is done
with direct procedure calls instead of forking the python interpreter.
Except for some reporting code that remains in report.py.

Reviewed By: jvillard

Differential Revision: D4074718

fbshipit-source-id: 56a794d

infer/src/backend/InferAnalyze.re

@@ -71,7 +71,7 @@ let process_cluster_cmdline fname =>
   | Some (nr, cluster) => analyze_cluster (nr - 1) cluster
   };
 
-let main () => {
+let main makefile => {
   switch Config.modified_targets {
   | Some file => MergeCapture.modified_file file
   | None => ()
@@ -86,9 +86,9 @@ let main () => {
       MergeCapture.merge_captured_targets ()
     };
     let clusters = DB.find_source_dirs ();
-    L.err "Found %d source files in %s@." (IList.length clusters) Config.results_dir;
+    L.stdout "Found %d source files in %s@." (IList.length clusters) Config.results_dir;
-    if (Config.makefile_cmdline != "") {
+    if (makefile != "") {
-      ClusterMakefile.create_cluster_makefile clusters Config.makefile_cmdline
+      ClusterMakefile.create_cluster_makefile clusters makefile
     } else {
       IList.iteri (fun i cluster => analyze_cluster i cluster) clusters;
       L.stdout "@\nAnalysis finished in %as@." pp_elapsed_time ()

infer/src/backend/InferAnalyze.rei

@@ -11,4 +11,6 @@ open! Utils;
 
 
 /** Main module for the analysis after the capture phase */
-let main: unit => unit;
+
+/** Given a name of the Makefile to use for multicore analysis, analyze the captured code */
+let main: string => unit;

infer/src/backend/InferAnalyzeExe.re

@@ -67,5 +67,5 @@ let () = {
   };
   print_prolog ();
   RegisterCheckers.register ();
-  InferAnalyze.main ()
+  InferAnalyze.main Config.makefile_cmdline
 };

infer/src/backend/InferPrint.re

@@ -1262,8 +1262,9 @@ let process_summary filters formats_by_report_kind linereader stats top_proc_set
 
 let module AnalysisResults = {
   type t = list (string, Specs.summary);
-  let spec_files_from_cmdline = {
+  let spec_files_from_cmdline () => {
-    /* find spec files specified by command-line arguments */
+    /* Find spec files specified by command-line arguments.  Not run at init time since the specs
+       files may be generated between init and report time. */
     IList.iter
       (
         fun arg =>
@@ -1307,7 +1308,7 @@ let module AnalysisResults = {
         exit 0
       | Some summary => summaries := [(fname, summary), ...!summaries]
       };
-    apply_without_gc (IList.iter load_file) spec_files_from_cmdline;
+    apply_without_gc (IList.iter load_file) (spec_files_from_cmdline ());
     let summ_cmp (_, summ1) (_, summ2) => {
       let n =
         DB.source_file_compare
@@ -1326,7 +1327,7 @@ let module AnalysisResults = {
 
   /** Create an iterator which loads spec files one at a time */
   let iterator_of_spec_files () => {
-    let sorted_spec_files = IList.sort string_compare spec_files_from_cmdline;
+    let sorted_spec_files = IList.sort string_compare (spec_files_from_cmdline ());
     let do_spec f fname =>
       switch (Specs.load_summary (DB.filename_from_string fname)) {
       | None =>

infer/src/backend/cluster.ml

@@ -37,7 +37,7 @@ let cl_file n = "x" ^ (cl_name n) ^ ".cluster"
 let pp_cluster_name fmt n = Format.fprintf fmt "%s" (cl_name n)
 
 let pp_cluster fmt (nr, cluster) =
-  let fname = cl_file nr in
+  let fname = Config.results_dir // Config.multicore_dir_name // cl_file nr in
   let pp_cl fmt n = Format.fprintf fmt "%s" (cl_name n) in
   store_to_file (DB.filename_from_string fname) (nr, cluster);
   F.fprintf fmt "%a: @\n" pp_cl nr;

infer/src/backend/clusterMakefile.ml

@@ -78,4 +78,5 @@ let create_cluster_makefile (clusters: Cluster.t list) (fname: string) =
     Cluster.pp_cluster fmt (cluster_nr + 1, cluster) in
   pp_prolog fmt clusters;
   IList.iteri do_cluster clusters;
-  pp_epilog fmt ()
+  pp_epilog fmt () ;
+  close_out outc

infer/src/backend/infer.ml

@@ -12,49 +12,30 @@ open! Utils
 (** Top-level driver that orchestrates build system integration, frontends, backend, and
     reporting *)
 
+module CLOpt = CommandLineOption
 module L = Logging
 
+
 let rec rmtree name =
   match Unix.opendir name with
   | dir -> (
-      match Unix.readdir dir with
+      let rec rmdir dir =
-      | entry when entry = Filename.current_dir_name || entry = Filename.parent_dir_name ->
+        match Unix.readdir dir with
-          ()
+        | entry ->
-      | entry ->
+            if not (entry = Filename.current_dir_name || entry = Filename.parent_dir_name) then (
-          rmtree entry
+              rmtree (name // entry)
-      | exception End_of_file ->
+            );
-          Unix.closedir dir ;
+            rmdir dir
-          Unix.rmdir name
+        | exception End_of_file ->
+            Unix.closedir dir ;
+            Unix.rmdir name in
+      rmdir dir
     )
   | exception Unix.Unix_error (Unix.ENOTDIR, _, _) ->
       Unix.unlink name
   | exception Unix.Unix_error (Unix.ENOENT, _, _) ->
       ()
 
-(** as the Config.fail_on_bug flag mandates, exit with error when an issue is reported *)
-let fail_on_issue_epilogue () =
-  let issues_json = DB.Results_dir.(path_to_filename Abs_root ["report.json"]) in
-  match read_file (DB.filename_to_string issues_json) with
-  | Some lines ->
-      let issues = Jsonbug_j.report_of_string @@ String.concat "" lines in
-      if issues <> [] then exit Config.fail_on_issue_exit_code
-  | None -> ()
-
-(* permissions used for created files *)
-let file_perm = 0o0666
-
-let create_results_dir () =
-  create_path (Config.results_dir // Config.captured_dir_name) ;
-  create_path (Config.results_dir // Config.sources_dir_name) ;
-  create_path (Config.results_dir // Config.specs_dir_name)
-
-let touch_start_file () =
-  let start = Config.results_dir // Config.start_filename in
-  let flags =
-    Unix.O_CREAT :: Unix.O_WRONLY :: (if Config.continue_capture then [Unix.O_EXCL] else []) in
-  (* create new file, or open existing file for writing to update modified timestamp *)
-  try Unix.close (Unix.openfile start flags file_perm)
-  with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
 
 type build_mode =
   | Analyze | Ant | Buck | ClangCompilationDatabase | Gradle | Java | Javac | Make | Mvn | Ndk
@@ -75,9 +56,60 @@ let build_mode_of_string path =
   | "xcodebuild" -> Xcode
   | cmd -> failwithf "Unsupported build command %s" cmd
 
-let remove_results_dir build_mode =
+
-  if not (build_mode = Analyze || Config.buck || Config.reactive_mode) then
+let remove_results_dir () =
-    rmtree Config.results_dir
+  rmtree Config.results_dir
+
+let create_results_dir () =
+  create_path (Config.results_dir // Config.captured_dir_name) ;
+  create_path (Config.results_dir // Config.sources_dir_name) ;
+  create_path (Config.results_dir // Config.specs_dir_name)
+
+let clean_results_dir () =
+  let dirs = ["classnames"; "filelists"; "multicore"; "sources"] in
+  let suffixes = [".cfg"; ".cg"] in
+  let rec clean name =
+    match Unix.opendir name with
+    | dir -> (
+        let rec cleandir dir =
+          match Unix.readdir dir with
+          | entry ->
+              if (IList.exists (string_equal entry) dirs) then (
+                rmtree (name // entry)
+              ) else if not (entry = Filename.current_dir_name
+                             || entry = Filename.parent_dir_name) then (
+                clean (name // entry)
+              );
+              cleandir dir
+          | exception End_of_file ->
+              Unix.closedir dir in
+        cleandir dir
+      )
+    | exception Unix.Unix_error (Unix.ENOTDIR, _, _) ->
+        if IList.exists (Filename.check_suffix name) suffixes then
+          Unix.unlink name
+    | exception Unix.Unix_error (Unix.ENOENT, _, _) ->
+        () in
+  clean Config.results_dir
+
+
+let register_perf_stats_report () =
+  let stats_dir = Filename.concat Config.results_dir Config.backend_stats_dir_name in
+  let stats_base = Config.perf_stats_prefix ^ ".json" in
+  let stats_file = Filename.concat stats_dir stats_base in
+  create_path stats_dir;
+  PerfStats.register_report_at_exit stats_file
+
+
+let touch_start_file () =
+  let start = Config.results_dir // Config.start_filename in
+  let file_perm = 0o0666 in
+  let flags =
+    Unix.O_CREAT :: Unix.O_WRONLY :: (if Config.continue_capture then [Unix.O_EXCL] else []) in
+  (* create new file, or open existing file for writing to update modified timestamp *)
+  try Unix.close (Unix.openfile start flags file_perm)
+  with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+
 
 let run_command cmd_list after_wait =
   let cmd = Array.of_list cmd_list in
@@ -90,94 +122,134 @@ let run_command cmd_list after_wait =
     exit exit_code
   )
 
+
 let check_xcpretty () =
   let open Core.Std in
   let exit_code = Unix.system "xcpretty --version" in
   match exit_code with
   | Ok () -> ()
   | Error _ ->
-      Logging.stderr
+      L.stderr
         "@.xcpretty not found in the path. Please, install xcpretty \
          for a more robust integration with xcodebuild. Otherwise use the option \
          --no-xcpretty.@.@.";
       Unix.exit_immediately 1
 
-let capture build_cmd build_mode =
+
-  let analyze_cmd = "analyze" in
+let capture build_cmd = function
-  let is_analyze_cmd cmd =
+  | Analyze ->
-    match cmd with
+      ()
-    | [cmd] when cmd = analyze_cmd -> true
+  | Buck when Config.use_compilation_database <> None ->
-    | _ -> false in
+      let json_cdb = CaptureCompilationDatabase.get_compilation_database_files_buck () in
-  let build_cmd =
+      CaptureCompilationDatabase.capture_files_in_database json_cdb
-    match build_mode with
+  | ClangCompilationDatabase -> (
-    | Xcode when Config.xcpretty ->
+      match Config.rest with
-        check_xcpretty ();
+      | arg :: _ -> CaptureCompilationDatabase.capture_files_in_database [arg]
-        let json_cdb =
+      | _ ->
-          CaptureCompilationDatabase.get_compilation_database_files_xcodebuild () in
+          failwith
-        CaptureCompilationDatabase.capture_files_in_database json_cdb;
+            "Error parsing arguments. Please, pass the compilation database json file as in \
-        [analyze_cmd]
+             infer -- clang-compilation-database file.json." ;
-    | Buck when Option.is_some Config.use_compilation_database ->
+          Config.print_usage_exit ()
-        let json_cdb = CaptureCompilationDatabase.get_compilation_database_files_buck () in
+    )
-        CaptureCompilationDatabase.capture_files_in_database json_cdb;
+  | Xcode when Config.xcpretty ->
-        [analyze_cmd]
+      check_xcpretty ();
-    | ClangCompilationDatabase ->
+      let json_cdb = CaptureCompilationDatabase.get_compilation_database_files_xcodebuild () in
-        (match Config.rest with
+      CaptureCompilationDatabase.capture_files_in_database json_cdb
-         | arg::_ -> CaptureCompilationDatabase.capture_files_in_database [arg]
+  | build_mode ->
-         | _ -> failwith("Errror parsing arguments. Please, pass the compilation \
+      let in_buck_mode = build_mode = Buck in
-                          database json file as in \
+      let infer_py = Config.lib_dir // "python" // "infer.py" in
-                          infer -- clang-compilation-database file.json."));
+      run_command (
-        [analyze_cmd]
+        infer_py ::
-    | _ ->  build_cmd in
+        Config.anon_args @
-  let in_buck_mode = build_mode = Buck in
+        ["--analyzer";
-  let infer_py = Config.lib_dir // "python" // "infer.py" in
+         IList.assoc (=) Config.analyzer
+           (IList.map (fun (n,a) -> (a,n)) Config.string_to_analyzer)] @
+        (match Config.blacklist with
+         | Some s when in_buck_mode -> ["--blacklist-regex"; s]
+         | _ -> []) @
+        (if not Config.create_harness then [] else
+           ["--android-harness"]) @
+        (if not Config.buck then [] else
+           ["--buck"]) @
+        (match Config.java_jar_compiler with None -> [] | Some p ->
+            ["--java-jar-compiler"; p]) @
+        (match IList.rev Config.buck_build_args with
+         | args when in_buck_mode ->
+             IList.map (fun arg -> ["--Xbuck"; "'" ^ arg ^ "'"]) args |> IList.flatten
+         | _ -> []) @
+        (if not Config.debug_mode then [] else
+           ["--debug"]) @
+        (if not Config.debug_exceptions then [] else
+           ["--debug-exceptions"]) @
+        (if Config.filtering then [] else
+           ["--no-filtering"]) @
+        (if not Config.flavors || not in_buck_mode then [] else
+           ["--use-flavors"]) @
+        "-j" :: (string_of_int Config.jobs) ::
+        (match Config.load_average with None -> [] | Some l ->
+            ["-l"; string_of_float l]) @
+        (if not Config.pmd_xml then [] else
+           ["--pmd-xml"]) @
+        ["--project-root"; Config.project_root] @
+        (if not Config.reactive_mode then [] else
+           ["--reactive"]) @
+        "--out" :: Config.results_dir ::
+        (match Config.xcode_developer_dir with None -> [] | Some d ->
+            ["--xcode-developer-dir"; d]) @
+        ("--" :: build_cmd)
+      ) (fun exit_code ->
+          if exit_code = Config.infer_py_argparse_error_exit_code then
+            (* swallow infer.py argument parsing error *)
+            Config.print_usage_exit ()
+        )
+
+let run_parallel_analysis () =
+  let multicore_dir = Config.results_dir // Config.multicore_dir_name in
+  rmtree multicore_dir ;
+  create_path multicore_dir ;
+  InferAnalyze.main (multicore_dir // "Makefile") ;
+  let cwd = Unix.getcwd () in
+  Unix.chdir multicore_dir ;
   run_command (
-    infer_py ::
+    "make" ::
-    Config.anon_args @
+    "-k" ::
-    ["--analyzer";
-     IList.assoc (=) Config.analyzer
-       (IList.map (fun (n,a) -> (a,n)) Config.string_to_analyzer)] @
-    (match Config.blacklist with
-     | Some s when in_buck_mode && not (is_analyze_cmd build_cmd) -> ["--blacklist-regex"; s]
-     | _ -> []) @
-    (if not Config.create_harness then [] else
-       ["--android-harness"]) @
-    (if not Config.buck then [] else
-       ["--buck"]) @
-    (match Config.java_jar_compiler with None -> [] | Some p ->
-        ["--java-jar-compiler"; p]) @
-    (match IList.rev Config.buck_build_args with
-     | args when in_buck_mode ->
-         IList.map (fun arg -> ["--Xbuck"; "'" ^ arg ^ "'"]) args |> IList.flatten
-     | _ -> []) @
-    (if not Config.continue_capture then [] else
-       ["--continue"]) @
-    (if not Config.debug_mode then [] else
-       ["--debug"]) @
-    (if not Config.debug_exceptions then [] else
-       ["--debug-exceptions"]) @
-    (if Config.filtering then [] else
-       ["--no-filtering"]) @
-    (if not Config.flavors || not in_buck_mode || is_analyze_cmd build_cmd then [] else
-       ["--use-flavors"]) @
     "-j" :: (string_of_int Config.jobs) ::
     (Option.map_default (fun l -> ["-l"; string_of_float l]) [] Config.load_average) @
-    (if not Config.pmd_xml then [] else
+    (if Config.debug_mode then [] else ["-s"])
-       ["--pmd-xml"]) @
+  ) (fun _ -> ());
-    ["--project-root"; Config.project_root] @
+  Unix.chdir cwd
-    (if not Config.reactive_mode then [] else
+
-       ["--reactive"]) @
+let execute_analyze () =
-    "--out" :: Config.results_dir ::
+  if Config.jobs = 1 then
-    (match Config.xcode_developer_dir with None -> [] | Some d ->
+    InferAnalyze.main ""
-        ["--xcode-developer-dir"; d]) @
+  else
-    (if Config.rest = [] then [] else
+    run_parallel_analysis ()
-       ("--" :: build_cmd))
+
-  ) (fun exit_code ->
+let report () =
-      if exit_code = Config.infer_py_argparse_error_exit_code then
+  let open! Core.Std in
-        (* swallow infer.py argument parsing error *)
+  let report_csv = Some (Config.results_dir ^/ "report.csv") in
-        Config.print_usage_exit ()
+  let report_json = Some (Config.results_dir ^/ "report.json") in
-    )
+  InferPrint.main ~report_csv ~report_json ;
+  match Config.report_hook with
+  | None -> ()
+  | Some prog ->
+      let if_some key opt args = match opt with None -> args | Some arg -> key :: arg :: args in
+      let if_true key opt args = if not opt then args else key :: args in
+      let args =
+        if_some "--issues-csv" report_csv @@
+        if_some "--issues-json" report_json @@
+        if_some "--issues-txt" Config.bugs_txt @@
+        if_some "--issues-xml" Config.bugs_xml @@
+        if_true "--pmd-xml" Config.pmd_xml [
+          "--project-root"; Config.project_root;
+          "--results-dir"; Config.results_dir
+        ] in
+      Unix.waitpid (Unix.create_process ~prog ~args).pid |> ignore
 
 let analyze = function
+  | Ant | Gradle | Make | Mvn | Ndk | Xcode ->
+      (* Still handled by infer.py through capture function above *)
+      ()
   | Buck when Config.use_compilation_database = None ->
       (* In Buck mode when compilation db is not used, analysis is invoked either from capture or a
          separate Analyze invocation is necessary, depending on the buck flavor used. *)
@@ -185,39 +257,50 @@ let analyze = function
   | Java | Javac ->
       (* In Java and Javac modes, analysis is invoked from capture. *)
       ()
-  | Analyze | Ant | Buck | ClangCompilationDatabase | Gradle | Make | Mvn | Ndk | Xcode ->
+  | Analyze | Buck | ClangCompilationDatabase ->
       if not (Sys.file_exists Config.(results_dir // captured_dir_name)) then (
         L.err "There was nothing to analyze, exiting" ;
         Config.print_usage_exit ()
       );
       (match Config.analyzer with
        | Infer | Eradicate | Checkers | Tracing | Crashcontext | Quandary | Threadsafety ->
-           (* Still handled by infer.py through capture function above *)
+           execute_analyze () ;
-           ()
+           report ()
        | Linters ->
-           (* Still handled by infer.py through capture function above *)
+           report ()
-           ()
        | Capture | Compile ->
-           (* Still handled by infer.py through capture function above *)
            ()
       )
 
-let epilogue build_mode =
+(** as the Config.fail_on_bug flag mandates, exit with error when an issue is reported *)
-  if Config.is_originator then (
+let fail_on_issue_epilogue () =
-    StatsAggregator.generate_files () ;
+  let issues_json = DB.Results_dir.(path_to_filename Abs_root ["report.json"]) in
-    if Config.analyzer = Config.Crashcontext then
+  match read_file (DB.filename_to_string issues_json) with
-      Crashcontext.crashcontext_epilogue ~in_buck_mode:(build_mode = Buck);
+  | Some lines ->
-    if Config.fail_on_bug then
+      let issues = Jsonbug_j.report_of_string @@ String.concat "" lines in
-      fail_on_issue_epilogue ();
+      if issues <> [] then exit Config.fail_on_issue_exit_code
-  )
+  | None -> ()
 
 let () =
+  if Config.developer_mode then Printexc.record_backtrace true ;
   let build_cmd = IList.rev Config.rest in
   let build_mode = match build_cmd with path :: _ -> build_mode_of_string path | [] -> Analyze in
-  remove_results_dir build_mode ;
+  if build_mode != Analyze && not Config.buck && not Config.reactive_mode then
+    remove_results_dir () ;
   create_results_dir () ;
+  (* re-set log files, as default files were in results_dir removed above *)
+  L.set_log_file_identifier Config.current_exe (Some (CLOpt.exe_name Config.current_exe)) ;
   if Config.is_originator then L.out "%s@\n" Config.version_string ;
+  register_perf_stats_report () ;
   touch_start_file () ;
   capture build_cmd build_mode ;
   analyze build_mode ;
-  epilogue build_mode
+  if Config.is_originator then (
+    StatsAggregator.generate_files () ;
+    if Config.analyzer = Config.Crashcontext then
+      Crashcontext.crashcontext_epilogue ~in_buck_mode:(build_mode = Buck);
+    if build_mode = Buck then
+      clean_results_dir () ;
+    if Config.fail_on_bug then
+      fail_on_issue_epilogue () ;
+  )

infer/src/base/Config.ml

@@ -156,6 +156,8 @@ let max_recursion = 5
     1 = use the meet to generate new preconditions *)
 let meet_level = 1
 
+let multicore_dir_name = "multicore"
+
 let nsnotification_center_checker_backend = false
 
 let perf_stats_prefix = "perf_stats"
@@ -1099,6 +1101,14 @@ and report_custom_error =
   CLOpt.mk_bool ~long:"report-custom-error"
     ""
 
+and report_hook =
+  CLOpt.mk_string_opt ~long:"report-hook"
+    ~default:(lib_dir // "python" // "report.py")
+    ~meta:"script"
+    "Specify a script to be executed after the analysis results are written.  This script will be \
+     passed --issues-csv, --issues-json, --issues-txt, --issues-xml, --project-root, and \
+     --results-dir."
+
 and results_dir =
   CLOpt.mk_path ~deprecated:["results_dir"; "-out"] ~long:"results-dir" ~short:"o"
     ~default:(init_work_dir // "infer-out")
@@ -1488,6 +1498,7 @@ and reactive_mode = !reactive
 and reactive_capture = !reactive_capture
 and report = !report
 and report_custom_error = !report_custom_error
+and report_hook = !report_hook
 and report_runtime_exceptions = !tracing
 and reports_include_ml_loc = !reports_include_ml_loc
 and results_dir = !results_dir

infer/src/base/Config.mli

@@ -93,6 +93,7 @@ val max_recursion : int
 val meet_level : int
 val models_dir : string
 val models_jar : string
+val multicore_dir_name : string
 val ncpu : int
 val nsnotification_center_checker_backend : bool
 val os_type : os_type
@@ -235,6 +236,7 @@ val quiet : bool
 val reactive_mode : bool
 val reactive_capture : bool
 val report : string option
+val report_hook : string option
 val report_runtime_exceptions : bool
 val reports_include_ml_loc : bool
 val results_dir : string