(* * Copyright (c) 2009-2013, Monoidics ltd. * Copyright (c) Facebook, Inc. and its affiliates. * * This source code is licensed under the MIT license found in the * LICENSE file in the root directory of this source tree. *) open! IStd module Hashtbl = Caml.Hashtbl module L = Logging module F = Format let error_desc_to_plain_string error_desc = let pp fmt = Localise.pp_error_desc fmt error_desc in let s = F.asprintf "%t" pp in let s = String.strip s in let s = (* end error description with a dot *) if String.is_suffix ~suffix:"." s then s else s ^ "." in s let error_desc_to_dotty_string error_desc = Localise.error_desc_get_dotty error_desc let compute_key (bug_type : string) (proc_name : Typ.Procname.t) (filename : string) = let base_filename = Filename.basename filename and simple_procedure_name = Typ.Procname.get_method proc_name in String.concat ~sep:"|" [base_filename; simple_procedure_name; bug_type] let compute_hash ~(severity : string) ~(bug_type : string) ~(proc_name : Typ.Procname.t) ~(file : string) ~(qualifier : string) = let base_filename = Filename.basename file in let hashable_procedure_name = Typ.Procname.hashable_name proc_name in let location_independent_qualifier = (* Removing the line,column, and infer temporary variable (e.g., n$67) information from the error message as well as the index of the annonymmous class to make the hash invariant when moving the source code in the file *) Str.global_replace (Str.regexp "\\(line \\|column \\|parameter \\|\\$\\)[0-9]+") "$_" qualifier in Utils.better_hash (severity, bug_type, hashable_procedure_name, base_filename, location_independent_qualifier) |> Caml.Digest.to_hex let loc_trace_to_jsonbug_record trace_list ekind = match ekind with | Exceptions.Info -> [] | _ -> let trace_item_to_record trace_item = { Jsonbug_j.level= trace_item.Errlog.lt_level ; filename= SourceFile.to_string trace_item.Errlog.lt_loc.Location.file ; line_number= trace_item.Errlog.lt_loc.Location.line ; column_number= trace_item.Errlog.lt_loc.Location.col ; description= trace_item.Errlog.lt_description } in let record_list = List.rev (List.rev_map ~f:trace_item_to_record trace_list) in record_list type summary_val = { vname: string ; vname_id: string ; vspecs: int ; vto: string ; vsymop: int ; verr: int ; vfile: string ; vline: int ; vsignature: string ; vproof_trace: string } (** compute values from summary data to export to csv format *) let summary_values summary = let stats = summary.Summary.stats in let attributes = Summary.get_attributes summary in let err_log = Summary.get_err_log summary in let proc_name = Summary.get_proc_name summary in let vsignature = Summary.get_signature summary in let specs = Tabulation.get_specs_from_payload summary in let lines_visited = let visited = ref BiabductionSummary.Visitedset.empty in let do_spec spec = visited := BiabductionSummary.Visitedset.union spec.BiabductionSummary.visited !visited in List.iter ~f:do_spec specs ; let visited_lines = ref Int.Set.empty in BiabductionSummary.Visitedset.iter (fun (_, ls) -> List.iter ~f:(fun l -> visited_lines := Int.Set.add !visited_lines l) ls) !visited ; Int.Set.elements !visited_lines in let vproof_trace = let pp_line fmt l = F.pp_print_int fmt l in let pp fmt = Pp.seq pp_line fmt lines_visited in F.asprintf "%t" pp in { vname= Typ.Procname.to_string proc_name ; vname_id= Typ.Procname.to_filename proc_name ; vspecs= List.length specs ; vto= Summary.Stats.failure_kind_to_string stats ; vsymop= Summary.Stats.symops stats ; verr= Errlog.size (Exceptions.equal_severity Exceptions.Error) err_log ; vfile= SourceFile.to_string attributes.ProcAttributes.loc.Location.file ; vline= attributes.ProcAttributes.loc.Location.line ; vsignature ; vproof_trace } module ProcsCsv = struct (** Print the header of the procedures csv file, with column names *) let pp_header fmt () = Format.fprintf fmt "%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s@\n" Io_infer.Xml.tag_name Io_infer.Xml.tag_name_id Io_infer.Xml.tag_specs Io_infer.Xml.tag_time Io_infer.Xml.tag_to Io_infer.Xml.tag_symop Io_infer.Xml.tag_err Io_infer.Xml.tag_file Io_infer.Xml.tag_line Io_infer.Xml.tag_loc Io_infer.Xml.tag_top Io_infer.Xml.tag_signature Io_infer.Xml.tag_weight Io_infer.Xml.tag_proof_coverage Io_infer.Xml.tag_rank Io_infer.Xml.tag_in_calls Io_infer.Xml.tag_out_calls Io_infer.Xml.tag_proof_trace (** Write proc summary stats in csv format *) let pp_summary fmt summary = let pp x = F.fprintf fmt x in let sv = summary_values summary in pp "\"%s\"," (Escape.escape_csv sv.vname) ; pp "\"%s\"," (Escape.escape_csv sv.vname_id) ; pp "%d," sv.vspecs ; pp "%s," sv.vto ; pp "%d," sv.vsymop ; pp "%d," sv.verr ; pp "%s," sv.vfile ; pp "%d," sv.vline ; pp "\"%s\"," (Escape.escape_csv sv.vsignature) ; pp "%s@\n" sv.vproof_trace end let should_report (issue_kind : Exceptions.severity) issue_type error_desc eclass = if (not Config.filtering) || Exceptions.equal_err_class eclass Exceptions.Linters then true else let issue_kind_is_blacklisted = match issue_kind with Info -> true | Advice | Error | Like | Warning -> false in if issue_kind_is_blacklisted then false else let issue_type_is_null_deref = let null_deref_issue_types = let open IssueType in [ field_not_null_checked ; null_dereference ; parameter_not_null_checked ; premature_nil_termination ; empty_vector_access ; biabd_use_after_free ] in List.mem ~equal:IssueType.equal null_deref_issue_types issue_type in if issue_type_is_null_deref then Localise.error_desc_is_reportable_bucket error_desc else true (* The reason an issue should be censored (that is, not reported). The empty string (that is "no reason") means that the issue should be reported. *) let censored_reason (issue_type : IssueType.t) source_file = let filename = SourceFile.to_rel_path source_file in let rejected_by ((issue_type_polarity, issue_type_re), (filename_polarity, filename_re), reason) = let accepted = (* matches issue_type_re implies matches filename_re *) (not (Bool.equal issue_type_polarity (Str.string_match issue_type_re issue_type.unique_id 0))) || Bool.equal filename_polarity (Str.string_match filename_re filename 0) in Option.some_if (not accepted) reason in List.find_map Config.censor_report ~f:rejected_by let potential_exception_message = "potential exception at line" module type Printer = sig type elt val pp_open : F.formatter -> unit -> unit val pp_close : F.formatter -> unit -> unit val pp : F.formatter -> elt -> unit end module MakeJsonListPrinter (P : sig type elt val to_string : elt -> string option end) : Printer with type elt = P.elt = struct include P let is_first_item = ref true let pp_open fmt () = is_first_item := true ; F.fprintf fmt "[@?" let pp_close fmt () = F.fprintf fmt "]@\n@?" let pp fmt elt = match to_string elt with | Some s -> if !is_first_item then is_first_item := false else F.pp_print_char fmt ',' ; F.fprintf fmt "%s@?" s | None -> () end type json_issue_printer_typ = { error_filter: SourceFile.t -> IssueType.t -> bool ; proc_name: Typ.Procname.t ; proc_loc_opt: Location.t option ; err_key: Errlog.err_key ; err_data: Errlog.err_data } let procedure_id_of_procname proc_name = match Typ.Procname.get_language proc_name with | Language.Java -> Typ.Procname.to_unique_id proc_name | _ -> Typ.Procname.to_string proc_name module JsonIssuePrinter = MakeJsonListPrinter (struct type elt = json_issue_printer_typ let to_string ({error_filter; proc_name; proc_loc_opt; err_key; err_data} : elt) = let source_file, procedure_start_line = match proc_loc_opt with | Some proc_loc -> (proc_loc.Location.file, proc_loc.Location.line) | None -> (err_data.loc.Location.file, 0) in if SourceFile.is_invalid source_file then L.(die InternalError) "Invalid source file for %a %a@.Trace: %a@." IssueType.pp err_key.err_name Localise.pp_error_desc err_key.err_desc Errlog.pp_loc_trace err_data.loc_trace ; let should_report_source_file = (not (SourceFile.is_biabduction_model source_file)) || Config.debug_mode || Config.debug_exceptions in if error_filter source_file err_key.err_name && should_report_source_file && should_report err_key.severity err_key.err_name err_key.err_desc err_data.err_class then let severity = Exceptions.severity_string err_key.severity in let bug_type = err_key.err_name.IssueType.unique_id in let file = SourceFile.to_string ~force_relative:Config.report_force_relative_path source_file in let json_ml_loc = match err_data.loc_in_ml_source with | Some (file, lnum, cnum, enum) when Config.reports_include_ml_loc -> Some Jsonbug_j.{file; lnum; cnum; enum} | _ -> None in let qualifier = let base_qualifier = error_desc_to_plain_string err_key.err_desc in if IssueType.(equal resource_leak) err_key.err_name then match Errlog.compute_local_exception_line err_data.loc_trace with | None -> base_qualifier | Some line -> let potential_exception_message = Format.asprintf "%a: %s %d" MarkupFormatter.pp_bold "Note" potential_exception_message line in Format.sprintf "%s@\n%s" base_qualifier potential_exception_message else base_qualifier in let bug = { Jsonbug_j.bug_type ; qualifier ; severity ; line= err_data.loc.Location.line ; column= err_data.loc.Location.col ; procedure= procedure_id_of_procname proc_name ; procedure_start_line ; file ; bug_trace= loc_trace_to_jsonbug_record err_data.loc_trace err_key.severity ; node_key= Option.map ~f:Procdesc.NodeKey.to_string err_data.node_key ; key= compute_key bug_type proc_name file ; hash= compute_hash ~severity ~bug_type ~proc_name ~file ~qualifier ; dotty= error_desc_to_dotty_string err_key.err_desc ; infer_source_loc= json_ml_loc ; bug_type_hum= err_key.err_name.IssueType.hum ; linters_def_file= err_data.linters_def_file ; doc_url= err_data.doc_url ; traceview_id= None ; censored_reason= censored_reason err_key.err_name source_file ; access= err_data.access ; extras= err_data.extras } in Some (Jsonbug_j.string_of_jsonbug bug) else None end) module IssuesJson = struct include JsonIssuePrinter (** Write bug report in JSON format *) let pp_issues_of_error_log fmt error_filter _ proc_loc_opt proc_name err_log = Errlog.iter (fun err_key err_data -> pp fmt {error_filter; proc_name; proc_loc_opt; err_key; err_data}) err_log end type json_costs_printer_typ = {loc: Location.t; proc_name: Typ.Procname.t; cost_opt: CostDomain.summary option} module JsonCostsPrinter = MakeJsonListPrinter (struct type elt = json_costs_printer_typ let to_string {loc; proc_name; cost_opt} = match cost_opt with | Some {post; is_on_ui_thread} when not (Typ.Procname.is_java_access_method proc_name) -> let hum cost = let degree_with_term = CostDomain.BasicCost.get_degree_with_term cost in { Jsonbug_t.hum_polynomial= Format.asprintf "%a" CostDomain.BasicCost.pp_hum cost ; hum_degree= Format.asprintf "%a" (CostDomain.BasicCost.pp_degree ~only_bigO:false) degree_with_term ; big_o= Format.asprintf "%a" (CostDomain.BasicCost.pp_degree ~only_bigO:true) degree_with_term } in let cost_info cost = { Jsonbug_t.polynomial_version= CostDomain.BasicCost.version ; polynomial= CostDomain.BasicCost.encode cost ; degree= Option.map (CostDomain.BasicCost.degree cost) ~f:Polynomials.Degree.encode_to_int ; hum= hum cost } in let cost_item = let file = SourceFile.to_rel_path loc.Location.file in { Jsonbug_t.hash= compute_hash ~severity:"" ~bug_type:"" ~proc_name ~file ~qualifier:"" ; loc= {file; lnum= loc.Location.line; cnum= loc.Location.col; enum= -1} ; procedure_name= Typ.Procname.get_method proc_name ; procedure_id= procedure_id_of_procname proc_name ; is_on_ui_thread ; exec_cost= cost_info (CostDomain.get_cost_kind CostKind.OperationCost post) ; alloc_cost= cost_info (CostDomain.get_cost_kind CostKind.AllocationCost post) } in Some (Jsonbug_j.string_of_cost_item cost_item) | _ -> None end) let pp_custom_of_report fmt report fields = let pp_custom_of_issue fmt (issue : Jsonbug_t.jsonbug) = let open Jsonbug_t in let comma_separator index = if index > 0 then ", " else "" in let pp_trace fmt trace comma = let pp_trace_elem fmt {description} = F.pp_print_string fmt description in let trace_without_empty_descs = List.filter ~f:(fun {description} -> description <> "") trace in F.fprintf fmt "%s[%a]" comma (Pp.comma_seq pp_trace_elem) trace_without_empty_descs in let pp_field index field = match field with | `Issue_field_bug_type -> Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_type | `Issue_field_bucket -> let bucket = match String.lsplit2 issue.qualifier ~on:']' |> Option.map ~f:fst |> Option.bind ~f:(String.chop_prefix ~prefix:"[") with | Some bucket -> bucket | None -> "no_bucket" in Format.fprintf fmt "%s%s" (comma_separator index) bucket | `Issue_field_qualifier -> Format.fprintf fmt "%s%s" (comma_separator index) issue.qualifier | `Issue_field_severity -> Format.fprintf fmt "%s%s" (comma_separator index) issue.severity | `Issue_field_line -> Format.fprintf fmt "%s%d" (comma_separator index) issue.line | `Issue_field_column -> Format.fprintf fmt "%s%d" (comma_separator index) issue.column | `Issue_field_procedure -> Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure | `Issue_field_procedure_start_line -> Format.fprintf fmt "%s%d" (comma_separator index) issue.procedure_start_line | `Issue_field_file -> Format.fprintf fmt "%s%s" (comma_separator index) issue.file | `Issue_field_bug_trace -> pp_trace fmt issue.bug_trace (comma_separator index) | `Issue_field_key -> Format.fprintf fmt "%s%s" (comma_separator index) (Caml.Digest.to_hex issue.key) | `Issue_field_hash -> Format.fprintf fmt "%s%s" (comma_separator index) (Caml.Digest.to_hex issue.hash) | `Issue_field_line_offset -> Format.fprintf fmt "%s%d" (comma_separator index) (issue.line - issue.procedure_start_line) | `Issue_field_qualifier_contains_potential_exception_note -> Format.pp_print_bool fmt (String.is_substring issue.qualifier ~substring:potential_exception_message) in List.iteri ~f:pp_field fields ; Format.fprintf fmt "@." in List.iter ~f:(pp_custom_of_issue fmt) report let tests_jsonbug_compare (bug1 : Jsonbug_t.jsonbug) (bug2 : Jsonbug_t.jsonbug) = let open Jsonbug_t in [%compare: string * string * int * string * Caml.Digest.t] (bug1.file, bug1.procedure, bug1.line - bug1.procedure_start_line, bug1.bug_type, bug1.hash) (bug2.file, bug2.procedure, bug2.line - bug2.procedure_start_line, bug2.bug_type, bug2.hash) module IssuesTxt = struct let pp_issue fmt error_filter proc_loc_opt (key : Errlog.err_key) (err_data : Errlog.err_data) = let source_file = match proc_loc_opt with | Some proc_loc -> proc_loc.Location.file | None -> err_data.loc.Location.file in if error_filter source_file key.err_name && ((not Config.filtering) || Option.is_none (censored_reason key.err_name source_file)) then Exceptions.pp_err err_data.loc key.severity key.err_name key.err_desc None fmt () (** Write bug report in text format *) let pp_issues_of_error_log fmt error_filter _ proc_loc_opt _ err_log = Errlog.iter (pp_issue fmt error_filter proc_loc_opt) err_log end let pp_text_of_report fmt report = let pp_row jsonbug = let open Jsonbug_t in F.fprintf fmt "%s:%d: %s: %s %s@\n" jsonbug.file jsonbug.line jsonbug.severity jsonbug.bug_type jsonbug.qualifier in List.iter ~f:pp_row report ; F.fprintf fmt "@?" module Stats = struct type t = { files: (SourceFile.t, unit) Hashtbl.t ; mutable nchecked: int ; mutable ndefective: int ; mutable nerrors: int ; mutable ninfos: int ; mutable nadvice: int ; mutable nlikes: int ; mutable nprocs: int ; mutable nspecs: int ; mutable ntimeouts: int ; mutable nverified: int ; mutable nwarnings: int ; mutable saved_errors: string list } let create () = { files= Hashtbl.create 3 ; nchecked= 0 ; ndefective= 0 ; nerrors= 0 ; ninfos= 0 ; nadvice= 0 ; nlikes= 0 ; nprocs= 0 ; nspecs= 0 ; ntimeouts= 0 ; nverified= 0 ; nwarnings= 0 ; saved_errors= [] } let process_loc loc stats = try Hashtbl.find stats.files loc.Location.file with Caml.Not_found -> Hashtbl.add stats.files loc.Location.file () let loc_trace_to_string_list linereader indent_num ltr = let res = ref [] in let indent_string n = let s = ref "" in for _ = 1 to n do s := " " ^ !s done ; !s in let num = ref 0 in let loc_to_string lt = incr num ; let loc = lt.Errlog.lt_loc in let level = lt.Errlog.lt_level in let description = lt.Errlog.lt_description in let code = match Printer.LineReader.from_loc linereader loc with Some s -> s | None -> "" in let line = let pp fmt = if description <> "" then F.fprintf fmt "%s%4s // %s@\n" (indent_string (level + indent_num)) " " description ; F.fprintf fmt "%s%04d: %s" (indent_string (level + indent_num)) loc.Location.line code in F.asprintf "%t" pp in res := line :: "" :: !res in List.iter ~f:loc_to_string ltr ; List.rev !res let process_err_log error_filter linereader err_log stats = let found_errors = ref false in let process_row (key : Errlog.err_key) (err_data : Errlog.err_data) = let type_str = key.err_name.IssueType.unique_id in if error_filter key.err_name then match key.severity with | Exceptions.Error -> found_errors := true ; stats.nerrors <- stats.nerrors + 1 ; let error_strs = let pp1 fmt = F.fprintf fmt "%d: %s" stats.nerrors type_str in let pp2 fmt = F.fprintf fmt " %a:%d" SourceFile.pp err_data.loc.Location.file err_data.loc.Location.line in let pp3 fmt = F.fprintf fmt " (%a)" Localise.pp_error_desc key.err_desc in [F.asprintf "%t" pp1; F.asprintf "%t" pp2; F.asprintf "%t" pp3] in let trace = loc_trace_to_string_list linereader 1 err_data.loc_trace in stats.saved_errors <- List.rev_append (error_strs @ trace @ [""]) stats.saved_errors | Exceptions.Warning -> stats.nwarnings <- stats.nwarnings + 1 | Exceptions.Info -> stats.ninfos <- stats.ninfos + 1 | Exceptions.Advice -> stats.nadvice <- stats.nadvice + 1 | Exceptions.Like -> stats.nlikes <- stats.nlikes + 1 in Errlog.iter process_row err_log ; !found_errors let process_summary error_filter summary linereader stats = let specs = Tabulation.get_specs_from_payload summary in let found_errors = process_err_log error_filter linereader (Summary.get_err_log summary) stats in let is_defective = found_errors in let is_verified = specs <> [] && not is_defective in let is_checked = not (is_defective || is_verified) in let is_timeout = match Summary.(Stats.failure_kind summary.stats) with | None | Some (FKcrash _) -> false | _ -> true in stats.nprocs <- stats.nprocs + 1 ; stats.nspecs <- stats.nspecs + List.length specs ; if is_verified then stats.nverified <- stats.nverified + 1 ; if is_checked then stats.nchecked <- stats.nchecked + 1 ; if is_timeout then stats.ntimeouts <- stats.ntimeouts + 1 ; if is_defective then stats.ndefective <- stats.ndefective + 1 ; process_loc (Summary.get_loc summary) stats let num_files stats = Hashtbl.length stats.files let pp fmt stats = F.fprintf fmt "Files: %d@\n" (num_files stats) ; F.fprintf fmt "Specs: %d@\n" stats.nspecs ; F.fprintf fmt "Timeouts: %d@\n" stats.ntimeouts ; F.fprintf fmt "Procedures: %d@\n" stats.nprocs ; F.fprintf fmt " Verified: %d@\n" stats.nverified ; F.fprintf fmt " Checked: %d@\n" stats.nchecked ; F.fprintf fmt " Defective: %d@\n" stats.ndefective ; F.fprintf fmt "Errors: %d@\n" stats.nerrors ; F.fprintf fmt "Warnings: %d@\n" stats.nwarnings ; F.fprintf fmt "Infos: %d@\n" stats.ninfos ; F.fprintf fmt "@\n -------------------@\n" ; F.fprintf fmt "@\nDetailed Errors@\n@\n" ; List.iter ~f:(fun s -> F.fprintf fmt "%s@\n" s) (List.rev stats.saved_errors) end module StatsLogs = struct let process _ (summary : Summary.t) _ _ = let num_preposts = match summary.payloads.biabduction with Some {preposts} -> List.length preposts | None -> 0 in let clang_method_kind = ClangMethodKind.to_string (Summary.get_attributes summary).clang_method_kind in let proc_name = Summary.get_proc_name summary in let lang = Typ.Procname.get_language proc_name in let stats = EventLogger.AnalysisStats { analysis_nodes_visited= Summary.Stats.nb_visited summary.stats ; analysis_status= Summary.Stats.failure_kind summary.stats ; analysis_total_nodes= Summary.get_proc_desc summary |> Procdesc.get_nodes_num ; clang_method_kind= (match lang with Language.Clang -> Some clang_method_kind | _ -> None) ; lang= Language.to_explicit_string lang ; method_location= Summary.get_loc summary ; method_name= Typ.Procname.to_string proc_name ; num_preposts ; symops= Summary.Stats.symops summary.stats } in EventLogger.log stats end module Report = struct let pp_header fmt () = F.fprintf fmt "Infer Analysis Results -- generated %a@\n@\n" Pp.current_time () ; F.fprintf fmt "Summary Report@\n@\n" let pp_stats fmt stats = Stats.pp fmt stats end (** Categorize the preconditions of specs and print stats *) module PreconditionStats = struct let nr_nopres = ref 0 let nr_empty = ref 0 let nr_onlyallocation = ref 0 let nr_dataconstraints = ref 0 let do_summary proc_name summary = let specs = Tabulation.get_specs_from_payload summary in let preconditions = List.map ~f:(fun spec -> BiabductionSummary.Jprop.to_prop spec.BiabductionSummary.pre) specs in match Prop.CategorizePreconditions.categorize preconditions with | Prop.CategorizePreconditions.Empty -> incr nr_empty ; L.result "Procedure: %a footprint:Empty@." Typ.Procname.pp proc_name | Prop.CategorizePreconditions.OnlyAllocation -> incr nr_onlyallocation ; L.result "Procedure: %a footprint:OnlyAllocation@." Typ.Procname.pp proc_name | Prop.CategorizePreconditions.NoPres -> incr nr_nopres ; L.result "Procedure: %a footprint:NoPres@." Typ.Procname.pp proc_name | Prop.CategorizePreconditions.DataConstraints -> incr nr_dataconstraints ; L.result "Procedure: %a footprint:DataConstraints@." Typ.Procname.pp proc_name let pp_stats () = L.result "@.Precondition stats@." ; L.result "Procedures with no preconditions: %d@." !nr_nopres ; L.result "Procedures with empty precondition: %d@." !nr_empty ; L.result "Procedures with only allocation conditions: %d@." !nr_onlyallocation ; L.result "Procedures with data constraints: %d@." !nr_dataconstraints end module SummaryStats = struct module MetricTypes = struct type 't typ = Bool : bool typ | Int : int typ end module MakeTopN (V : PrettyPrintable.PrintableOrderedType) = struct type 'k t = {capacity: int; filter: V.t -> bool; size: int; sorted_elements: (V.t * 'k) list} let make capacity ~filter = {capacity; filter; size= 0; sorted_elements= []} let add top k v = if top.filter v then let smaller, greater = List.split_while top.sorted_elements ~f:(fun (v', _) -> V.compare v v' > 0) in if top.size >= top.capacity then match smaller with | [] -> top | _ :: tl -> let sorted_elements = tl @ ((v, k) :: greater) in {top with sorted_elements} else let sorted_elements = smaller @ ((v, k) :: greater) in {top with size= top.size + 1; sorted_elements} else top let is_empty top = top.size <= 0 let pp ~pp_k f top = if top.size > 0 then let pp1 f (v, k) = F.fprintf f "@[%a -> %a@]" V.pp v pp_k k in Pp.seq pp1 f (List.rev top.sorted_elements) end module IntTopN = MakeTopN (Int) module MetricAggregator = struct open MetricTypes type ('i, 'k) t = | A : { name: string ; value: 'o ; is_empty: 'o -> bool ; add: 'o -> 'k -> 'i -> 'o ; pp: pp_k:(F.formatter -> 'k -> unit) -> F.formatter -> 'o -> unit } -> ('i, 'k) t let add (A aggr) k i = A {aggr with value= aggr.add aggr.value k i} let pp ~pp_k f (A {name; pp; value; is_empty}) = if not (is_empty value) then F.fprintf f "@[%s: @[%a@]@]" name (pp ~pp_k) value let no_k pp ~pp_k:_ = pp let int name add = A {name; value= 0; is_empty= Int.(( = ) 0); add; pp= no_k F.pp_print_int} let int_sum = int "sum" (fun acc _ v -> acc + v) let int_top3 = A { name= "top3" ; value= IntTopN.make 3 ~filter:(fun x -> x > 1) ; is_empty= IntTopN.is_empty ; add= IntTopN.add ; pp= IntTopN.pp } let true_count = int "True" (fun acc _ b -> if b then acc + 1 else acc) let false_count = int "False" (fun acc _ b -> if b then acc else acc + 1) type 'k get = {get: 'i. 'i typ -> ('i, 'k) t list} let aggregators = let get : type i. i typ -> (i, _) t list = function | Bool -> [true_count; false_count] | Int -> [int_sum; int_top3] in {get} let get aggregators typ = aggregators.get typ end module Metrics = struct open MetricTypes type 'i metric = M : {get: 'i -> 't; typ: 't typ} -> 'i metric let for_fields poly_fields obj_metrics = PolyFields.map poly_fields { f= (fun field_name field_get -> let prefix = field_name ^ ":" in List.map obj_metrics ~f:(fun (metric_name, M {typ; get= metric_get}) -> let name = prefix ^ metric_name in let get r = r |> field_get |> Obj.repr |> metric_get in (name, M {typ; get}) ) ) } |> List.concat end module ObjMetrics = struct open MetricTypes open Metrics let obj_is_zero = phys_equal (Obj.repr 0) let obj_marshaled_size x = String.length (Marshal.to_string x []) - Marshal.header_size let metrics = let bool name get = (name, M {typ= Bool; get}) in let int name get = (name, M {typ= Int; get}) in [ int "reachable_words" Obj.reachable_words ; int "marshaled size" obj_marshaled_size ; bool "is_zero" obj_is_zero ] end module MetricResults = struct open MetricTypes open Metrics module StringMap = PrettyPrintable.MakePPMap (String) type ('i, 'k) result = | R : {typ: 't typ; get: 'i -> 't; aggrs: ('t, 'k) MetricAggregator.t list} -> ('i, 'k) result let init metrics aggregators = List.fold metrics ~init:StringMap.empty ~f:(fun acc (name, M {typ; get}) -> StringMap.add name (R {typ; get; aggrs= MetricAggregator.get aggregators typ}) acc ) let add results k x = StringMap.map (fun (R res) -> let v = res.get x in R {res with aggrs= List.map res.aggrs ~f:(fun aggr -> MetricAggregator.add aggr k v)} ) results let pp ~pp_k f results = let pp_value f (R {aggrs}) = Pp.seq (MetricAggregator.pp ~pp_k) f aggrs in StringMap.pp ~pp_value f results end let results = let summary_fields_obj_metrics = Metrics.for_fields Summary.poly_fields ObjMetrics.metrics in let init = MetricResults.init summary_fields_obj_metrics MetricAggregator.aggregators in ref init let do_summary proc_name summary = results := MetricResults.add !results proc_name summary let pp_stats () = L.result "%a@\n" (MetricResults.pp ~pp_k:Typ.Procname.pp) !results end let error_filter filters proc_name file error_name = (Config.write_html || not (IssueType.(equal skip_function) error_name)) && filters.Inferconfig.path_filter file && filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name type report_kind = Costs | Issues | Procs | Stats | Summary [@@deriving compare] let _string_of_report_kind = function | Costs -> "Costs" | Issues -> "Issues" | Procs -> "Procs" | Stats -> "Stats" | Summary -> "Summary" type bug_format_kind = Json | Csv | Logs | Tests | Text [@@deriving compare] let _string_of_bug_format_kind = function | Json -> "Json" | Csv -> "Csv" | Logs -> "Logs" | Tests -> "Tests" | Text -> "Text" let get_outfile outfile = match outfile with | Some outfile -> outfile | None -> L.(die InternalError) "An outfile is require for this format." let pp_issue_in_format (format_kind, (outfile_opt : Utils.outfile option)) error_filter {Issue.proc_name; proc_location; err_key; err_data} = match format_kind with | Json -> let outf = get_outfile outfile_opt in IssuesJson.pp outf.fmt {error_filter; proc_name; proc_loc_opt= Some proc_location; err_key; err_data} | Csv -> L.(die InternalError) "Printing issues in a CSV format is not implemented" | Tests -> L.(die InternalError) "Printing issues as tests is not implemented" | Logs -> L.(die InternalError) "Printing issues as logs is not implemented" | Text -> let outf = get_outfile outfile_opt in IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data let pp_issues_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Json -> let outf = get_outfile outfile_opt in IssuesJson.pp_issues_of_error_log outf.fmt | Csv -> L.(die InternalError) "Printing issues in a CSV format is not implemented" | Tests -> L.(die InternalError) "Printing issues as tests is not implemented" | Logs -> L.(die InternalError) "Printing issues as logs is not implemented" | Text -> let outf = get_outfile outfile_opt in IssuesTxt.pp_issues_of_error_log outf.fmt let pp_procs_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Csv -> let outf = get_outfile outfile_opt in ProcsCsv.pp_summary outf.fmt | Json | Tests | Text | Logs -> L.(die InternalError) "Printing procs in json/tests/text/logs is not implemented" let pp_stats_in_format (format_kind, _) = match format_kind with | Csv -> Stats.process_summary | Logs -> StatsLogs.process | Json | Tests | Text -> L.(die InternalError) "Printing stats in json/tests/text is not implemented" let pp_issues_of_error_log error_filter linereader proc_loc_opt procname err_log bug_format_list = let pp_issues_in_format format = pp_issues_in_format format error_filter linereader proc_loc_opt procname err_log in List.iter ~f:pp_issues_in_format bug_format_list let collect_issues summary issues_acc = let err_log = Summary.get_err_log summary in let proc_name = Summary.get_proc_name summary in let proc_location = Summary.get_loc summary in Errlog.fold (fun err_key err_data acc -> {Issue.proc_name; proc_location; err_key; err_data} :: acc) err_log issues_acc let pp_procs summary procs_format_list = let pp_procs_in_format format = let pp_procs = pp_procs_in_format format in pp_procs summary in List.iter ~f:pp_procs_in_format procs_format_list let pp_stats error_filter linereader summary stats stats_format_list = let pp_stats_in_format format = let pp_stats = pp_stats_in_format format in pp_stats error_filter summary linereader stats in List.iter ~f:pp_stats_in_format stats_format_list let pp_summary summary = L.result "Procedure: %a@\n%a@." Typ.Procname.pp (Summary.get_proc_name summary) Summary.pp_text summary let pp_costs_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Json -> let outf = get_outfile outfile_opt in JsonCostsPrinter.pp outf.fmt | Csv | Tests | Text | Logs -> L.(die InternalError) "Printing costs in csv/tests/text/logs is not implemented" let pp_costs summary costs_format_list = let pp format = pp_costs_in_format format { loc= Summary.get_loc summary ; proc_name= Summary.get_proc_name summary ; cost_opt= summary.Summary.payloads.Payloads.cost } in List.iter ~f:pp costs_format_list let pp_summary_by_report_kind formats_by_report_kind summary error_filter linereader stats file issues_acc = let pp_summary_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with | Costs, _ -> pp_costs summary format_list | Procs, _ :: _ -> pp_procs summary format_list | Stats, _ :: _ -> pp_stats (error_filter file) linereader summary stats format_list | Summary, _ when InferCommand.equal Config.command Report && not Config.quiet -> pp_summary summary | _ -> () in List.iter ~f:pp_summary_by_report_kind formats_by_report_kind ; collect_issues summary issues_acc let pp_json_report_by_report_kind formats_by_report_kind fname = match Utils.read_file fname with | Ok report_lines -> let pp_json_issues format_list report = let pp_json_issue (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Tests -> let outf = get_outfile outfile_opt in pp_custom_of_report outf.fmt report Config.issues_fields | Text -> let outf = get_outfile outfile_opt in pp_text_of_report outf.fmt report | Json -> L.(die InternalError) "Printing issues from json does not support json output" | Csv -> L.(die InternalError) "Printing issues from json does not support csv output" | Logs -> L.(die InternalError) "Printing issues from json does not support logs output" in List.iter ~f:pp_json_issue format_list in let sorted_report = let report = Jsonbug_j.report_of_string (String.concat ~sep:"\n" report_lines) in List.sort ~compare:tests_jsonbug_compare report in let pp_report_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with | Issues, _ :: _ -> pp_json_issues format_list sorted_report | _ -> () in List.iter ~f:pp_report_by_report_kind formats_by_report_kind | Error error -> L.(die UserError) "Error reading '%s': %s" fname error let pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log = let pp_summary_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with | Issues, _ :: _ -> pp_issues_of_error_log error_filter linereader None procname error_log format_list | _ -> () in List.iter ~f:pp_summary_by_report_kind formats_by_report_kind (** Process lint issues of a procedure *) let pp_lint_issues filters formats_by_report_kind linereader procname error_log = let error_filter = error_filter filters procname in pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log (** Process a summary *) let process_summary filters formats_by_report_kind linereader stats summary issues_acc = let file = (Summary.get_loc summary).Location.file in let proc_name = Summary.get_proc_name summary in let error_filter = error_filter filters proc_name in let issues_acc' = pp_summary_by_report_kind formats_by_report_kind summary error_filter linereader stats file issues_acc in if Config.precondition_stats then PreconditionStats.do_summary proc_name summary ; if Config.summary_stats then SummaryStats.do_summary proc_name summary ; issues_acc' (** Although the out_file is an Option type, the None option is strictly meant for the logs format_kind, and all other formats should contain an outfile value. *) let mk_format format_kind fname = Option.value_map ~f:(fun out_file -> [(format_kind, Some out_file)]) ~default:[] (Utils.create_outfile fname) let init_issues_format_list report_json = let json_format = Option.value_map ~f:(mk_format Json) ~default:[] report_json in let tests_format = Option.value_map ~f:(mk_format Tests) ~default:[] Config.issues_tests in let txt_format = Option.value_map ~f:(mk_format Text) ~default:[] Config.issues_txt in json_format @ tests_format @ txt_format let init_procs_format_list () = Option.value_map ~f:(mk_format Csv) ~default:[] Config.procs_csv let init_stats_format_list () = let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] Config.stats_report in let logs_format = if Config.log_events then [(Logs, None)] else [] in csv_format @ logs_format let init_files format_list_by_kind = let init_files_of_report_kind (report_kind, format_list) = let init_files_of_format (format_kind, (outfile_opt : Utils.outfile option)) = match (format_kind, report_kind) with | Csv, Issues -> L.(die InternalError) "Printing issues in a CSV format is not implemented" | Logs, (Issues | Procs | Summary) -> L.(die InternalError) "Logging these reports is not implemented" | Csv, Procs -> let outfile = get_outfile outfile_opt in ProcsCsv.pp_header outfile.fmt () | Csv, Stats -> let outfile = get_outfile outfile_opt in Report.pp_header outfile.fmt () | Json, Costs -> let outfile = get_outfile outfile_opt in JsonCostsPrinter.pp_open outfile.fmt () | Json, Issues -> let outfile = get_outfile outfile_opt in IssuesJson.pp_open outfile.fmt () | Csv, (Costs | Summary) | Logs, (Costs | Stats) | Json, (Procs | Stats | Summary) | Tests, _ | Text, _ -> () in List.iter ~f:init_files_of_format format_list in List.iter ~f:init_files_of_report_kind format_list_by_kind let finalize_and_close_files format_list_by_kind (stats : Stats.t) = let close_files_of_report_kind (report_kind, format_list) = let close_files_of_format (format_kind, (outfile_opt : Utils.outfile option)) = ( match (format_kind, report_kind) with | Logs, (Issues | Procs | Summary) -> L.(die InternalError) "Logging these reports is not implemented" | Csv, Stats -> let outfile = get_outfile outfile_opt in F.fprintf outfile.fmt "%a@?" Report.pp_stats stats | Json, Costs -> let outfile = get_outfile outfile_opt in JsonCostsPrinter.pp_close outfile.fmt () | Json, Issues -> let outfile = get_outfile outfile_opt in IssuesJson.pp_close outfile.fmt () | Csv, (Costs | Issues | Procs | Summary) | Logs, (Costs | Stats) | Json, (Procs | Stats | Summary) | Tests, _ | Text, _ -> () ) ; match outfile_opt with Some outfile -> Utils.close_outf outfile | None -> () in List.iter ~f:close_files_of_format format_list ; () in List.iter ~f:close_files_of_report_kind format_list_by_kind let pp_summary_and_issues formats_by_report_kind issue_formats = let stats = Stats.create () in let linereader = Printer.LineReader.create () in let filters = Inferconfig.create_filters () in let all_issues = ref [] in SpecsFiles.iter_from_config ~f:(fun summary -> all_issues := process_summary filters formats_by_report_kind linereader stats summary !all_issues ) ; all_issues := Issue.sort_filter_issues !all_issues ; if Config.quandaryBO then all_issues := QuandaryBO.update_issues !all_issues ; List.iter ~f:(fun ({Issue.proc_name} as issue) -> let error_filter = error_filter filters proc_name in List.iter ~f:(fun issue_format -> pp_issue_in_format issue_format error_filter issue) issue_formats ) !all_issues ; if Config.precondition_stats then PreconditionStats.pp_stats () ; if Config.summary_stats then SummaryStats.pp_stats () ; List.iter [Config.lint_issues_dir_name; Config.starvation_issues_dir_name; Config.racerd_issues_dir_name] ~f:(fun dir_name -> IssueLog.load dir_name |> IssueLog.iter ~f:(pp_lint_issues filters formats_by_report_kind linereader) ) ; finalize_and_close_files formats_by_report_kind stats let register_perf_stats_report () = let rtime_span, initial_times = (Mtime_clock.counter (), Unix.times ()) in PerfStats.register_report (PerfStats.Time (rtime_span, initial_times)) PerfStats.Reporting let main ~report_json = let issue_formats = init_issues_format_list report_json in let formats_by_report_kind = let costs_report_format_kind = match report_json with | Some _ -> let file = Config.(results_dir ^/ Config.costs_report_json) in [(Costs, mk_format Json file)] | None -> [] in costs_report_format_kind @ [ (Issues, issue_formats) ; (Procs, init_procs_format_list ()) ; (Stats, init_stats_format_list ()) ; (Summary, []) ] in register_perf_stats_report () ; init_files formats_by_report_kind ; ( match Config.from_json_report with | Some fname -> pp_json_report_by_report_kind formats_by_report_kind fname | None -> pp_summary_and_issues formats_by_report_kind issue_formats ) ; if Config.test_determinator && Config.process_clang_ast then TestDeterminator.merge_test_determinator_results () ; PerfStats.get_reporter PerfStats.Reporting ()