pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[ocamlformat] Use ocamlformat from github

Browse Source 
Summary:
Install ocamlformat from github as part of `make devsetup`, and use it
for formatting OCaml (and jbuild) code.

Reviewed By: jvillard

Differential Revision: D6092464

fbshipit-source-id: 4ba0845
master
Josh Berdine 7 years ago committed by Facebook Github Bot
parent 13a02122ac
commit f89e687efa
277 changed files with 23836 additions and 19196 deletions
Show Stats Download Patch File Download Diff File

1
.ocamlformat
Unescape View File

@ -1,2 +1,3 @@
margin 100
sparse true
version v0.1

2
CONTRIBUTING.md
Unescape View File

@ -145,7 +145,7 @@ module MF = MarkupFormatter
- Use the `_hum` suffix to flag functions that output human-readable strings.
- Format code with ocamlformat.
- Format code with [ocamlformat](https://github.com/ocaml-ppx/ocamlformat).
### C/C++/Objective-C

14
Makefile
Unescape View File

@ -138,17 +138,23 @@ fb-setup:
$(QUIET)$(call silent_on_success,Facebook setup,\
$(MAKE) -C facebook setup)
OCAMLFORMAT_EXE=facebook/dependencies/ocamlformat/src/_build/opt/ocamlformat.exe
OCAMLFORMAT_EXE?=ocamlformat
.PHONY: fmt
fmt:
parallel $(OCAMLFORMAT_EXE) --no-warn-error -i ::: $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$")
parallel $(OCAMLFORMAT_EXE) -i ::: $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$")
JBUILD_ML:=$(shell find * -name 'jbuild*.in' | grep -v workspace)
.PHONY: fmt_jbuild
fmt_jbuild:
parallel $(OCAMLFORMAT_EXE) -i ::: $(JBUILD_ML)
SRC_ML:=$(shell find * \( -name _build -or -name facebook-clang-plugins -or -path facebook/dependencies \) -not -prune -or -type f -and -name '*'.ml -or -name '*'.mli 2>/dev/null)
.PHONY: fmt_all
fmt_all:
parallel $(OCAMLFORMAT_EXE) --no-warn-error -i ::: $(SRC_ML)
parallel $(OCAMLFORMAT_EXE) -i ::: $(SRC_ML) $(JBUILD_ML)
# pre-building these avoids race conditions when building, eg src_build and test_build in parallel
.PHONY: src_build_common
@ -584,6 +590,8 @@ devsetup: Makefile.autoconf
$(QUIET)[ $(OPAM) != "no" ] || (echo 'No `opam` found, aborting setup.' >&2; exit 1)
$(QUIET)$(call silent_on_success,installing $(OPAM_DEV_DEPS),\
OPAMSWITCH=$(OPAMSWITCH); $(OPAM) install --yes --no-checksum user-setup $(OPAM_DEV_DEPS))
$(QUIET)$(call silent_on_success,installing ocamlformat,\
OPAMSWITCH=$(OPAMSWITCH); $(OPAM) pin add --yes ocamlformat https://github.com/ocaml-ppx/ocamlformat.git#$$(grep version .ocamlformat | cut -d ' ' -f 2))
$(QUIET)echo '$(TERM_INFO)*** Running `opam config setup -a`$(TERM_RESET)' >&2
$(QUIET)OPAMSWITCH=$(OPAMSWITCH); $(OPAM) config --yes setup -a
$(QUIET)echo '$(TERM_INFO)*** Running `opam user-setup`$(TERM_RESET)' >&2

2
infer/src/IR/Annot.ml
Unescape View File

@ -53,10 +53,12 @@ module Item = struct
let pp fmt (a, _) = pp fmt a in
F.fprintf fmt "<%a>" (Pp.seq pp) ann
let to_string ann =
let pp fmt = pp fmt ann in
F.asprintf "%t" pp
(** Empty item annotation. *)
let empty = []

28
infer/src/IR/Attributes.ml
Unescape View File

@ -16,11 +16,13 @@ let int64_of_attributes_kind =
let int64_two = Int64.of_int 2 in
function ProcUndefined -> Int64.zero | ProcObjCAccessor -> Int64.one | ProcDefined -> int64_two
let proc_kind_of_attr (proc_attributes: ProcAttributes.t) =
if proc_attributes.is_defined then ProcDefined
else if Option.is_some proc_attributes.objc_accessor then ProcObjCAccessor
else ProcUndefined
module type Data = sig
val of_pname : Typ.Procname.t -> Sqlite3.Data.t
@ -38,6 +40,7 @@ module Data : Data = struct
let default () = Sqlite3.Data.TEXT (Typ.Procname.to_filename pname) in
Base.Hashtbl.find_or_add pname_to_key pname ~default
let of_source_file file = Sqlite3.Data.TEXT (SourceFile.to_string file)
let to_proc_attr = function[@warning "-8"] Sqlite3.Data.BLOB b -> Marshal.from_string b 0
@ -76,6 +79,7 @@ FROM (
WHERE attr_kind < :akind
OR (attr_kind = :akind AND source_file < :sfile) )|}
let replace pname_blob akind loc_file attr_blob =
let replace_stmt = get_replace_statement () in
Sqlite3.bind replace_stmt 1 (* :pname *) pname_blob
@ -88,6 +92,7 @@ let replace pname_blob akind loc_file attr_blob =
|> SqliteUtils.check_sqlite_error ~log:"replace bind proc attributes" ;
SqliteUtils.sqlite_unit_step ~finalize:false ~log:"Attributes.replace" replace_stmt
let get_find_more_defined_statement =
ResultsDir.register_statement
{|
@ -97,6 +102,7 @@ WHERE proc_name = :pname
AND attr_kind > :akind
|}
let should_try_to_update pname_blob akind =
let find_stmt = get_find_more_defined_statement () in
Sqlite3.bind find_stmt 1 (* :pname *) pname_blob
@ -106,14 +112,17 @@ let should_try_to_update pname_blob akind =
SqliteUtils.sqlite_result_step ~finalize:false ~log:"Attributes.replace" find_stmt
|> (* there is no entry with a strictly larger "definedness" for that proc name *) Option.is_none
let get_select_statement =
ResultsDir.register_statement "SELECT proc_attributes FROM attributes WHERE proc_name = :k"
let get_select_defined_statement =
ResultsDir.register_statement
"SELECT proc_attributes FROM attributes WHERE proc_name = :k AND attr_kind = %Ld"
(int64_of_attributes_kind ProcDefined)
let find ~defined pname_blob =
let select_stmt = if defined then get_select_defined_statement () else get_select_statement () in
Sqlite3.bind select_stmt 1 pname_blob
@ -121,6 +130,7 @@ let find ~defined pname_blob =
SqliteUtils.sqlite_result_step ~finalize:false ~log:"Attributes.find" select_stmt
|> Option.map ~f:Data.to_proc_attr
let load pname = Data.of_pname pname |> find ~defined:false
let store (attr: ProcAttributes.t) =
@ -129,26 +139,28 @@ let store (attr: ProcAttributes.t) =
if should_try_to_update key pkind then
replace key pkind (Data.of_source_file attr.loc.Location.file) (Data.of_proc_attr attr)
let load_defined pname = Data.of_pname pname |> find ~defined:true
let find_file_capturing_procedure pname =
match load pname with
| None
-> None
| Some proc_attributes
-> let source_file = proc_attributes.ProcAttributes.source_file_captured in
| None ->
None
| Some proc_attributes ->
let source_file = proc_attributes.ProcAttributes.source_file_captured in
let source_dir = DB.source_dir_from_source_file source_file in
let origin =
(* Procedure coming from include files if it has different location
than the file where it was captured. *)
match SourceFile.compare source_file proc_attributes.ProcAttributes.loc.file <> 0 with
| true
-> `Include
| false
-> `Source
| true ->
`Include
| false ->
`Source
in
let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg" in
let cfg_fname_exists =
PVariant.( = ) `Yes (Sys.file_exists (DB.filename_to_string cfg_fname))
in
if cfg_fname_exists then Some (source_file, origin) else None

135
infer/src/IR/Binop.ml
Unescape View File

@ -52,83 +52,86 @@ let invertible = function PlusA | PlusPI | MinusA | MinusPI -> true | _ -> false
If the [binop] operation is not invertible, the function raises Assert_failure. *)
let invert bop =
match bop with
| PlusA
-> MinusA
| PlusPI
-> MinusPI
| MinusA
-> PlusA
| MinusPI
-> PlusPI
| _
-> assert false
| PlusA ->
MinusA
| PlusPI ->
MinusPI
| MinusA ->
PlusA
| MinusPI ->
PlusPI
| _ ->
assert false
(** This function returns true if 0 is the right unit of [binop].
The return value false means "don't know". *)
let is_zero_runit = function PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false
let text = function
| PlusA
-> "+"
| PlusPI
-> "+"
| MinusA | MinusPP
-> "-"
| MinusPI
-> "-"
| Mult
-> "*"
| Div
-> "/"
| Mod
-> "%"
| Shiftlt
-> "<<"
| Shiftrt
-> ">>"
| Lt
-> "<"
| Gt
-> ">"
| Le
-> "<="
| Ge
-> ">="
| Eq
-> "=="
| Ne
-> "!="
| BAnd
-> "&"
| BXor
-> "^"
| BOr
-> "|"
| LAnd
-> "&&"
| LOr
-> "||"
| PlusA ->
"+"
| PlusPI ->
"+"
| MinusA | MinusPP ->
"-"
| MinusPI ->
"-"
| Mult ->
"*"
| Div ->
"/"
| Mod ->
"%"
| Shiftlt ->
"<<"
| Shiftrt ->
">>"
| Lt ->
"<"
| Gt ->
">"
| Le ->
"<="
| Ge ->
">="
| Eq ->
"=="
| Ne ->
"!="
| BAnd ->
"&"
| BXor ->
"^"
| BOr ->
"|"
| LAnd ->
"&&"
| LOr ->
"||"
(** Pretty print a binary operator. *)
let str pe binop =
match pe.Pp.kind with
| HTML -> (
match binop with
| Ge
-> " &gt;= "
| Le
-> " &lt;= "
| Gt
-> " &gt; "
| Lt
-> " &lt; "
| Shiftlt
-> " &lt;&lt; "
| Shiftrt
-> " &gt;&gt; "
| _
-> text binop )
| Ge ->
" &gt;= "
| Le ->
" &lt;= "
| Gt ->
" &gt; "
| Lt ->
" &lt; "
| Shiftlt ->
" &lt;&lt; "
| Shiftrt ->
" &gt;&gt; "
| _ ->
text binop )
| LATEX -> (
match binop with Ge -> " \\geq " | Le -> " \\leq " | _ -> text binop )
| _
-> text binop
| _ ->
text binop

3
infer/src/IR/BuiltinDecl.ml
Unescape View File

@ -19,6 +19,7 @@ let create_procname name =
let pname = Typ.Procname.from_string_c_fun name in
register pname ; pname
let create_objc_class_method class_name method_name =
let method_kind = Typ.Procname.ObjCClassMethod in
let tname = Typ.Name.Objc.from_string class_name in
@ -28,6 +29,7 @@ let create_objc_class_method class_name method_name =
in
register pname ; pname
let is_declared pname = Typ.Procname.Set.mem pname !builtin_decls
let __array_access = create_procname "__array_access"
@ -83,6 +85,7 @@ let __objc_cast = create_procname "__objc_cast"
let __objc_dictionary_literal =
create_objc_class_method "NSDictionary" "dictionaryWithObjects:forKeys:count:"
let __objc_release = create_procname "__objc_release"
let __objc_release_autorelease_pool = create_procname "__objc_release_autorelease_pool"

2
infer/src/IR/CallFlags.ml
Unescape View File

@ -27,9 +27,11 @@ let pp f cf =
if cf.cf_virtual then F.fprintf f " virtual" ;
if cf.cf_noreturn then F.fprintf f " noreturn"
let default =
{ cf_virtual= false
; cf_interface= false
; cf_noreturn= false
; cf_is_objc_block= false
; cf_targets= [] }

173
infer/src/IR/Cfg.ml
Unescape View File

@ -28,10 +28,13 @@ let find_proc_desc_from_name cfg pname =
try Some (Typ.Procname.Hash.find cfg.proc_desc_table pname)
with Not_found -> None
(** Create a new procdesc *)
let create_proc_desc cfg (proc_attributes: ProcAttributes.t) =
let pdesc = Procdesc.from_proc_attributes ~called_from_cfg:true proc_attributes in
add_proc_desc cfg proc_attributes.proc_name pdesc ; pdesc
add_proc_desc cfg proc_attributes.proc_name pdesc ;
pdesc
(** Iterate over all the nodes in the cfg *)
let iter_all_nodes ?(sorted= false) f cfg =
@ -49,12 +52,14 @@ let iter_all_nodes ?(sorted= false) f cfg =
|> List.sort ~cmp:[%compare : Procdesc.t * Procdesc.Node.t]
|> List.iter ~f:(fun (d, n) -> f d n)
(** Get all the procdescs (defined and declared) *)
let get_all_procs cfg =
let procs = ref [] in
let f _ pdesc = procs := pdesc :: !procs in
iter_proc_desc cfg f ; !procs
(** Get the procedures whose body is defined in this cfg *)
let get_defined_procs cfg = List.filter ~f:Procdesc.is_defined (get_all_procs cfg)
@ -67,12 +72,12 @@ let check_cfg_connectedness cfg =
let succs = Procdesc.Node.get_succs n in
let preds = Procdesc.Node.get_preds n in
match Procdesc.Node.get_kind n with
| Procdesc.Node.Start_node _
-> Int.equal (List.length succs) 0 || List.length preds > 0
| Procdesc.Node.Exit_node _
-> List.length succs > 0 || Int.equal (List.length preds) 0
| Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Skip_node _
-> Int.equal (List.length succs) 0 || Int.equal (List.length preds) 0
| Procdesc.Node.Start_node _ ->
Int.equal (List.length succs) 0 || List.length preds > 0
| Procdesc.Node.Exit_node _ ->
List.length succs > 0 || Int.equal (List.length preds) 0
| Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Skip_node _ ->
Int.equal (List.length succs) 0 || Int.equal (List.length preds) 0
| Procdesc.Node.Join_node ->
(* Join node has the exception that it may be without predecessors
and pointing to an exit node *)
@ -89,14 +94,17 @@ let check_cfg_connectedness cfg =
let pdescs = get_all_procs cfg in
List.iter ~f:do_pdesc pdescs
(** Serializer for control flow graphs *)
let cfg_serializer : cfg Serialization.serializer =
Serialization.create_serializer Serialization.Key.cfg
(** Load a cfg from a file *)
let load_cfg_from_file (filename: DB.filename) : cfg option =
Serialization.read_from_file cfg_serializer filename
(** Save the .attr files for the procedures in the cfg. *)
let save_attributes source_file cfg =
let save_proc pdesc =
@ -110,6 +118,7 @@ let save_attributes source_file cfg =
in
List.iter ~f:save_proc (get_all_procs cfg)
(** Inline a synthetic (access or bridge) method. *)
let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option =
let modified = ref None in
@ -124,70 +133,72 @@ let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option =
match (instr, ret_id, etl) with
| ( Sil.Load (_, Exp.Lfield (Exp.Var _, fn, ft), bt, _)
, Some (ret_id, _)
, [(* getter for fields *) (e1, _)] )
-> let instr' = Sil.Load (ret_id, Exp.Lfield (e1, fn, ft), bt, loc_call) in
, [(* getter for fields *) (e1, _)] ) ->
let instr' = Sil.Load (ret_id, Exp.Lfield (e1, fn, ft), bt, loc_call) in
found instr instr'
| Sil.Load (_, Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _), Some (ret_id, _), []
when Pvar.is_global pvar
-> (* getter for static fields *)
when Pvar.is_global pvar ->
(* getter for static fields *)
let instr' = Sil.Load (ret_id, Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, loc_call) in
found instr instr'
| Sil.Store (Exp.Lfield (_, fn, ft), bt, _, _), _, [(* setter for fields *) (e1, _); (e2, _)]
-> let instr' = Sil.Store (Exp.Lfield (e1, fn, ft), bt, e2, loc_call) in
| Sil.Store (Exp.Lfield (_, fn, ft), bt, _, _), _, [(* setter for fields *) (e1, _); (e2, _)] ->
let instr' = Sil.Store (Exp.Lfield (e1, fn, ft), bt, e2, loc_call) in
found instr instr'
| Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _, _), _, [(e1, _)]
when Pvar.is_global pvar
-> (* setter for static fields *)
when Pvar.is_global pvar ->
(* setter for static fields *)
let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, e1, loc_call) in
found instr instr'
| Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _
when Bool.equal (is_none ret_id) (is_none ret_id')
&& Int.equal (List.length etl') (List.length etl)
-> let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl, loc_call, cf) in
&& Int.equal (List.length etl') (List.length etl) ->
let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl, loc_call, cf) in
found instr instr'
| Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _
when Bool.equal (is_none ret_id) (is_none ret_id')
&& Int.equal (List.length etl' + 1) (List.length etl)
-> let etl1 =
&& Int.equal (List.length etl' + 1) (List.length etl) ->
let etl1 =
match List.rev etl with
(* remove last element *)
| _ :: l
-> List.rev l
| []
-> assert false
| _ :: l ->
List.rev l
| [] ->
assert false
in
let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl1, loc_call, cf) in
found instr instr'
| _
-> ()
| _ ->
()
in
Procdesc.iter_instrs do_instr pdesc ; !modified
Procdesc.iter_instrs do_instr pdesc ;
!modified
(** Find synthetic (access or bridge) Java methods in the procedure and inline them in the cfg. *)
let proc_inline_synthetic_methods cfg pdesc : unit =
let instr_inline_synthetic_method = function
| Sil.Call (ret_id, Exp.Const Const.Cfun pn, etl, loc, _) -> (
match find_proc_desc_from_name cfg pn with
| Some pd
-> let is_access = Typ.Procname.java_is_access_method pn in
| Some pd ->
let is_access = Typ.Procname.java_is_access_method pn in
let attributes = Procdesc.get_attributes pd in
let is_synthetic = attributes.is_synthetic_method in
let is_bridge = attributes.is_bridge_method in
if is_access || is_bridge || is_synthetic then inline_synthetic_method ret_id etl pd loc
else None
| None
-> None )
| _
-> None
| None ->
None )
| _ ->
None
in
let node_inline_synthetic_methods node =
let modified = ref false in
let do_instr instr =
match instr_inline_synthetic_method instr with
| None
-> instr
| Some instr'
-> modified := true ;
| None ->
instr
| Some instr' ->
modified := true ;
instr'
in
let instrs = Procdesc.Node.get_instrs node in
@ -196,11 +207,13 @@ let proc_inline_synthetic_methods cfg pdesc : unit =
in
Procdesc.iter_nodes node_inline_synthetic_methods pdesc
(** Inline the java synthetic methods in the cfg *)
let inline_java_synthetic_methods cfg =
let f pname pdesc = if Typ.Procname.is_java pname then proc_inline_synthetic_methods cfg pdesc in
iter_proc_desc cfg f
(** compute the list of procedures added or changed in [cfg_new] over [cfg_old] *)
let mark_unchanged_pdescs cfg_new cfg_old =
let pdescs_eq (pd1: Procdesc.t) (pd2: Procdesc.t) =
@ -263,19 +276,22 @@ let mark_unchanged_pdescs cfg_new cfg_old =
in
Typ.Procname.Hash.iter mark_pdesc_if_unchanged new_procs
(** Save a cfg into a file *)
let store_cfg_to_file ~source_file (filename: DB.filename) (cfg: cfg) =
inline_java_synthetic_methods cfg ;
( if Config.incremental_procs then
match load_cfg_from_file filename with
| Some old_cfg
-> mark_unchanged_pdescs cfg old_cfg
| None
-> () ) ;
| Some old_cfg ->
mark_unchanged_pdescs cfg old_cfg
| None ->
() ) ;
(* NOTE: it's important to write attribute files to disk before writing .cfg file to disk.
OndemandCapture module relies on it - it uses existance of .cfg file as a barrier to make
sure that all attributes were written to disk (but not necessarily flushed) *)
save_attributes source_file cfg ; Serialization.write_to_file cfg_serializer filename ~data:cfg
save_attributes source_file cfg ;
Serialization.write_to_file cfg_serializer filename ~data:cfg
(** clone a procedure description and apply the type substitutions where
the parameters are used *)
@ -289,10 +305,10 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
Typ.mk (Tptr (Typ.mk (Tstruct typename), Typ.Pk_pointer))
in
let convert_exp = function
| Exp.Lvar origin_pvar
-> Exp.Lvar (convert_pvar origin_pvar)
| exp
-> exp
| Exp.Lvar origin_pvar ->
Exp.Lvar (convert_pvar origin_pvar)
| exp ->
exp
in
let subst_map = ref Ident.IdentMap.empty in
let redirect_typename origin_id =
@ -304,23 +320,23 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
( id
, (Exp.Lvar origin_pvar as origin_exp)
, {Typ.desc= Tptr ({desc= Tstruct origin_typename}, Pk_pointer)}
, loc )
-> let specialized_typname =
, loc ) ->
let specialized_typname =
try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions
with Not_found -> origin_typename
in
subst_map := Ident.IdentMap.add id specialized_typname !subst_map ;
Sil.Load (id, convert_exp origin_exp, mk_ptr_typ specialized_typname, loc) :: instrs
| Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc)
-> let updated_typ : Typ.t =
| Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc) ->
let updated_typ : Typ.t =
try Typ.mk ~default:origin_typ (Tstruct (Ident.IdentMap.find origin_id !subst_map))
with Not_found -> origin_typ
in
Sil.Load (id, convert_exp origin_exp, updated_typ, loc) :: instrs
| Sil.Load (id, origin_exp, origin_typ, loc)
-> Sil.Load (id, convert_exp origin_exp, origin_typ, loc) :: instrs
| Sil.Store (assignee_exp, origin_typ, origin_exp, loc)
-> let set_instr =
| Sil.Load (id, origin_exp, origin_typ, loc) ->
Sil.Load (id, convert_exp origin_exp, origin_typ, loc) :: instrs
| Sil.Store (assignee_exp, origin_typ, origin_exp, loc) ->
let set_instr =
Sil.Store (convert_exp assignee_exp, origin_typ, convert_exp origin_exp, loc)
in
set_instr :: instrs
@ -330,8 +346,8 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
, (Exp.Var id, _) :: origin_args
, loc
, call_flags )
when call_flags.CallFlags.cf_virtual && redirect_typename id <> None
-> let redirected_typename = Option.value_exn (redirect_typename id) in
when call_flags.CallFlags.cf_virtual && redirect_typename id <> None ->
let redirected_typename = Option.value_exn (redirect_typename id) in
let redirected_typ = mk_ptr_typ redirected_typename in
let redirected_pname =
Typ.Procname.replace_class (Typ.Procname.Java callee_pname_java) redirected_typename
@ -344,30 +360,30 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
Sil.Call (return_ids, Exp.Const (Const.Cfun redirected_pname), args, loc, call_flags)
in
call_instr :: instrs
| Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags)
-> let converted_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in
| Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags) ->
let converted_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in
let call_instr =
Sil.Call (return_ids, convert_exp origin_call_exp, converted_args, loc, call_flags)
in
call_instr :: instrs
| Sil.Prune (origin_exp, loc, is_true_branch, if_kind)
-> Sil.Prune (convert_exp origin_exp, loc, is_true_branch, if_kind) :: instrs
| Sil.Declare_locals (typed_vars, loc)
-> let new_typed_vars =
| Sil.Prune (origin_exp, loc, is_true_branch, if_kind) ->
Sil.Prune (convert_exp origin_exp, loc, is_true_branch, if_kind) :: instrs
| Sil.Declare_locals (typed_vars, loc) ->
let new_typed_vars =
List.map ~f:(fun (pvar, typ) -> (convert_pvar pvar, typ)) typed_vars
in
Sil.Declare_locals (new_typed_vars, loc) :: instrs
| Sil.Nullify _ | Abstract _ | Sil.Remove_temps _
-> (* these are generated instructions that will be replaced by the preanalysis *)
| Sil.Nullify _ | Abstract _ | Sil.Remove_temps _ ->
(* these are generated instructions that will be replaced by the preanalysis *)
instrs
in
let convert_node_kind = function
| Procdesc.Node.Start_node _
-> Procdesc.Node.Start_node resolved_pname
| Procdesc.Node.Exit_node _
-> Procdesc.Node.Exit_node resolved_pname
| node_kind
-> node_kind
| Procdesc.Node.Start_node _ ->
Procdesc.Node.Start_node resolved_pname
| Procdesc.Node.Exit_node _ ->
Procdesc.Node.Exit_node resolved_pname
| node_kind ->
node_kind
in
let node_map = ref Procdesc.NodeMap.empty in
let rec convert_node node =
@ -377,10 +393,10 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
Procdesc.create_node resolved_pdesc loc kind instrs
and loop callee_nodes =
match callee_nodes with
| []
-> []
| node :: other_node
-> let converted_node =
| [] ->
[]
| node :: other_node ->
let converted_node =
try Procdesc.NodeMap.find node !node_map
with Not_found ->
let new_node = convert_node node
@ -399,6 +415,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
ignore (loop [callee_start_node]) ;
resolved_pdesc
(** Creates a copy of a procedure description and a list of type substitutions of the form
(name, typ) where name is a parameter. The resulting proc desc is isomorphic but
all the type of the parameters are replaced in the instructions according to the list.
@ -409,11 +426,11 @@ let specialize_types callee_pdesc resolved_pname args =
List.fold2_exn
~f:(fun (params, subts) (param_name, param_typ) (_, arg_typ) ->
match arg_typ.Typ.desc with
| Tptr ({desc= Tstruct typename}, Pk_pointer)
-> (* Replace the type of the parameter by the type of the argument *)
| Tptr ({desc= Tstruct typename}, Pk_pointer) ->
(* Replace the type of the parameter by the type of the argument *)
((param_name, arg_typ) :: params, Mangled.Map.add param_name typename subts)
| _
-> ((param_name, param_typ) :: params, subts))
| _ ->
((param_name, param_typ) :: params, subts))
~init:([], Mangled.Map.empty) callee_attributes.formals args
in
let resolved_attributes =
@ -430,7 +447,9 @@ let specialize_types callee_pdesc resolved_pname args =
in
specialize_types_proc callee_pdesc resolved_pdesc substitutions
let pp_proc_signatures fmt cfg =
F.fprintf fmt "METHOD SIGNATURES@\n@." ;
let sorted_procs = List.sort ~cmp:Procdesc.compare (get_all_procs cfg) in
List.iter ~f:(fun pdesc -> F.fprintf fmt "%a@." Procdesc.pp_signature pdesc) sorted_procs

83
infer/src/IR/Cg.ml
Unescape View File

@ -56,12 +56,14 @@ let add_node g n ~defined =
in
Typ.Procname.Hash.add g.node_map n info
let remove_node_defined g n =
try
let info = Typ.Procname.Hash.find g.node_map n in
info.defined <- false
with Not_found -> ()
let add_defined_node g n = add_node g n ~defined:true
(** Compute the ancestors of the node, if not already computed *)
@ -76,14 +78,15 @@ let compute_ancestors g node =
seen := Typ.Procname.Set.add current !seen ;
let info = Typ.Procname.Hash.find g current in
match info.ancestors with
| Some ancestors
-> result := Typ.Procname.Set.union !result ancestors
| None
-> result := Typ.Procname.Set.union !result info.parents ;
| Some ancestors ->
result := Typ.Procname.Set.union !result ancestors
| None ->
result := Typ.Procname.Set.union !result info.parents ;
todo := Typ.Procname.Set.union !todo info.parents )
done ;
!result
(** Compute the heirs of the node, if not already computed *)
let compute_heirs g node =
let todo = ref (Typ.Procname.Set.singleton node) in
@ -96,40 +99,43 @@ let compute_heirs g node =
seen := Typ.Procname.Set.add current !seen ;
let info = Typ.Procname.Hash.find g current in
match info.heirs with
| Some heirs
-> result := Typ.Procname.Set.union !result heirs
| None
-> result := Typ.Procname.Set.union !result info.children ;
| Some heirs ->
result := Typ.Procname.Set.union !result heirs
| None ->
result := Typ.Procname.Set.union !result info.children ;
todo := Typ.Procname.Set.union !todo info.children )
done ;
!result
(** Compute the ancestors of the node, if not pre-computed already *)
let get_ancestors (g: t) node =
let info = Typ.Procname.Hash.find g.node_map node in
match info.ancestors with
| None
-> let ancestors = compute_ancestors g.node_map node in
| None ->
let ancestors = compute_ancestors g.node_map node in
info.ancestors <- Some ancestors ;
let size = Typ.Procname.Set.cardinal ancestors in
if size > 1000 then
L.(debug Analysis Medium) "%a has %d ancestors@." Typ.Procname.pp node size ;
ancestors
| Some ancestors
-> ancestors
| Some ancestors ->
ancestors
(** Compute the heirs of the node, if not pre-computed already *)
let get_heirs (g: t) node =
let info = Typ.Procname.Hash.find g.node_map node in
match info.heirs with
| None
-> let heirs = compute_heirs g.node_map node in
| None ->
let heirs = compute_heirs g.node_map node in
info.heirs <- Some heirs ;
let size = Typ.Procname.Set.cardinal heirs in
if size > 1000 then L.(debug Analysis Medium) "%a has %d heirs@." Typ.Procname.pp node size ;
heirs
| Some heirs
-> heirs
| Some heirs ->
heirs
let node_defined (g: t) n =
try
@ -137,6 +143,7 @@ let node_defined (g: t) n =
info.defined
with Not_found -> false
let add_edge g nfrom nto =
add_node g nfrom ~defined:false ;
add_node g nto ~defined:false ;
@ -145,6 +152,7 @@ let add_edge g nfrom nto =
info_from.children <- Typ.Procname.Set.add nto info_from.children ;
info_to.parents <- Typ.Procname.Set.add nfrom info_to.parents
(** iterate over the elements of a node_map in node order *)
let node_map_iter f g =
let table = ref [] in
@ -152,30 +160,35 @@ let node_map_iter f g =
let cmp ((n1: Typ.Procname.t), _) ((n2: Typ.Procname.t), _) = Typ.Procname.compare n1 n2 in
List.iter ~f:(fun (n, info) -> f n info) (List.sort ~cmp !table)
let get_nodes (g: t) =
let nodes = ref Typ.Procname.Set.empty in
let f node _ = nodes := Typ.Procname.Set.add node !nodes in
node_map_iter f g ; !nodes
let compute_calls g node =
{ in_calls= Typ.Procname.Set.cardinal (get_ancestors g node)
; out_calls= Typ.Procname.Set.cardinal (get_heirs g node) }
(** Compute the calls of the node, if not pre-computed already *)
let get_calls (g: t) node =
let info = Typ.Procname.Hash.find g.node_map node in
match info.in_out_calls with
| None
-> let calls = compute_calls g node in
| None ->
let calls = compute_calls g node in
info.in_out_calls <- Some calls ;
calls
| Some calls
-> calls
| Some calls ->
calls
let get_all_nodes (g: t) =
let nodes = Typ.Procname.Set.elements (get_nodes g) in
List.map ~f:(fun node -> (node, get_calls g node)) nodes
let get_nodes_and_calls (g: t) = List.filter ~f:(fun (n, _) -> node_defined g n) (get_all_nodes g)
let node_get_num_ancestors g n = (n, Typ.Procname.Set.cardinal (get_ancestors g n))
@ -189,6 +202,7 @@ let get_edges (g: t) : ((node * int) * (node * int)) list =
in
node_map_iter f g ; !edges
(** Return all the children of [n], whether defined or not *)
let get_all_children (g: t) n = (Typ.Procname.Hash.find g.node_map n).children
@ -208,6 +222,7 @@ let get_nonrecursive_dependents (g: t) n =
let res = Typ.Procname.Set.filter (node_defined g) res0 in
res
(** Return the ancestors of [n] which are also heirs of [n] *)
let compute_recursive_dependents (g: t) n =
let reached_from_n pn = Typ.Procname.Set.mem n (get_ancestors g pn) in
@ -215,21 +230,24 @@ let compute_recursive_dependents (g: t) n =
let res = Typ.Procname.Set.filter (node_defined g) res0 in
res
(** Compute the ancestors of [n] which are also heirs of [n], if not pre-computed already *)
let get_recursive_dependents (g: t) n =
let info = Typ.Procname.Hash.find g.node_map n in
match info.recursive_dependents with
| None
-> let recursive_dependents = compute_recursive_dependents g n in
| None ->
let recursive_dependents = compute_recursive_dependents g n in
info.recursive_dependents <- Some recursive_dependents ;
recursive_dependents
| Some recursive_dependents
-> recursive_dependents
| Some recursive_dependents ->
recursive_dependents
(** Return the nodes dependent on [n] *)
let get_dependents (g: t) n =
Typ.Procname.Set.union (get_nonrecursive_dependents g n) (get_recursive_dependents g n)
(** Return all the nodes with their defined children *)
let get_nodes_and_defined_children (g: t) =
let nodes = ref Typ.Procname.Set.empty in
@ -237,6 +255,7 @@ let get_nodes_and_defined_children (g: t) =
let nodes_list = Typ.Procname.Set.elements !nodes in
List.map ~f:(fun n -> (n, get_defined_children g n)) nodes_list
(** nodes with defined flag, and edges *)
type nodes_and_edges = (node * bool) list * (node * node) list
@ -251,12 +270,14 @@ let get_nodes_and_edges (g: t) : nodes_and_edges =
in
node_map_iter f g ; (!nodes, !edges)
(** Return the list of nodes which are defined *)
let get_defined_nodes (g: t) =
let nodes, _ = get_nodes_and_edges g in
let get_node (node, _) = node in
List.map ~f:get_node (List.filter ~f:(fun (_, defined) -> defined) nodes)
(** Return the path of the source file *)
let get_source (g: t) = g.source
@ -267,26 +288,30 @@ let extend cg_old cg_new =
List.iter ~f:(fun (node, defined) -> add_node cg_old node ~defined) nodes ;
List.iter ~f:(fun (nfrom, nto) -> add_edge cg_old nfrom nto) edges
(** Begin support for serialization *)
let callgraph_serializer : (SourceFile.t * nodes_and_edges) Serialization.serializer =
Serialization.create_serializer Serialization.Key.cg
(** Load a call graph from a file *)
let load_from_file (filename: DB.filename) : t option =
match Serialization.read_from_file callgraph_serializer filename with
| None
-> None
| Some (source, (nodes, edges))
-> let g = create source in
| None ->
None
| Some (source, (nodes, edges)) ->
let g = create source in
List.iter ~f:(fun (node, defined) -> if defined then add_defined_node g node) nodes ;
List.iter ~f:(fun (nfrom, nto) -> add_edge g nfrom nto) edges ;
Some g
(** Save a call graph into a file *)
let store_to_file (filename: DB.filename) (call_graph: t) =
Serialization.write_to_file callgraph_serializer filename
~data:(call_graph.source, get_nodes_and_edges call_graph)
let pp_graph_dotty (g: t) fmt =
let nodes_with_calls = get_all_nodes g in
let get_shape (n, _) = if node_defined g n then "box" else "diamond" in
@ -303,6 +328,7 @@ let pp_graph_dotty (g: t) fmt =
List.iter ~f:(fun (s, d) -> F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) (get_edges g) ;
F.fprintf fmt "}@."
(** Print the call graph as a dotty file. *)
let save_call_graph_dotty source (g: t) =
let fname_dot =
@ -311,3 +337,4 @@ let save_call_graph_dotty source (g: t) =
let outc = Out_channel.create (DB.filename_to_string fname_dot) in
let fmt = F.formatter_of_out_channel outc in
pp_graph_dotty g fmt ; Out_channel.close outc

59
infer/src/IR/Const.ml
Unescape View File

@ -26,34 +26,36 @@ let equal = [%compare.equal : t]
let kind_equal c1 c2 =
let const_kind_number = function
| Cint _
-> 1
| Cfun _
-> 2
| Cstr _
-> 3
| Cfloat _
-> 4
| Cclass _
-> 5
| Cint _ ->
1
| Cfun _ ->
2
| Cstr _ ->
3
| Cfloat _ ->
4
| Cclass _ ->
5
in
Int.equal (const_kind_number c1) (const_kind_number c2)
let pp pe f = function
| Cint i
-> IntLit.pp f i
| Cint i ->
IntLit.pp f i
| Cfun fn -> (
match pe.Pp.kind with
| HTML
-> F.fprintf f "_fun_%s" (Escape.escape_xml (Typ.Procname.to_string fn))
| _
-> F.fprintf f "_fun_%s" (Typ.Procname.to_string fn) )
| Cstr s
-> F.fprintf f "\"%s\"" (String.escaped s)
| Cfloat v
-> F.fprintf f "%f" v
| Cclass c
-> F.fprintf f "%a" Ident.pp_name c
| HTML ->
F.fprintf f "_fun_%s" (Escape.escape_xml (Typ.Procname.to_string fn))
| _ ->
F.fprintf f "_fun_%s" (Typ.Procname.to_string fn) )
| Cstr s ->
F.fprintf f "\"%s\"" (String.escaped s)
| Cfloat v ->
F.fprintf f "%f" v
| Cclass c ->
F.fprintf f "%a" Ident.pp_name c
let to_string c = F.asprintf "%a" (pp Pp.text) c
@ -62,9 +64,10 @@ let iszero_int_float = function Cint i -> IntLit.iszero i | Cfloat 0.0 -> true |
let isone_int_float = function Cint i -> IntLit.isone i | Cfloat 1.0 -> true | _ -> false
let isminusone_int_float = function
| Cint i
-> IntLit.isminusone i
| Cfloat -1.0
-> true
| _
-> false
| Cint i ->
IntLit.isminusone i
| Cfloat -1.0 ->
true
| _ ->
false

115
infer/src/IR/DecompiledExp.ml
Unescape View File

@ -40,80 +40,81 @@ let eradicate_java () = Config.eradicate && java ()
(** convert a dexp to a string *)
let rec to_string = function
| Darray (de1, de2)
-> to_string de1 ^ "[" ^ to_string de2 ^ "]"
| Dbinop (op, de1, de2)
-> "(" ^ to_string de1 ^ Binop.str Pp.text op ^ to_string de2 ^ ")"
| Dconst Cfun pn
-> Typ.Procname.to_simplified_string pn
| Dconst c
-> Const.to_string c
| Dderef de
-> "*" ^ to_string de
| Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual})
-> let pp_arg fmt de = F.fprintf fmt "%s" (to_string de) in
| Darray (de1, de2) ->
to_string de1 ^ "[" ^ to_string de2 ^ "]"
| Dbinop (op, de1, de2) ->
"(" ^ to_string de1 ^ Binop.str Pp.text op ^ to_string de2 ^ ")"
| Dconst Cfun pn ->
Typ.Procname.to_simplified_string pn
| Dconst c ->
Const.to_string c
| Dderef de ->
"*" ^ to_string de
| Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual}) ->
let pp_arg fmt de = F.fprintf fmt "%s" (to_string de) in
let pp_args fmt des =
if eradicate_java () then ( if des <> [] then F.fprintf fmt "..." )
else Pp.comma_seq pp_arg fmt des
in
let pp_fun fmt = function
| Dconst Cfun pname
-> let s =
| Dconst Cfun pname ->
let s =
match pname with
| Typ.Procname.Java pname_java
-> Typ.Procname.java_get_method pname_java
| _
-> Typ.Procname.to_string pname
| Typ.Procname.Java pname_java ->
Typ.Procname.java_get_method pname_java
| _ ->
Typ.Procname.to_string pname
in
F.fprintf fmt "%s" s
| de
-> F.fprintf fmt "%s" (to_string de)
| de ->
F.fprintf fmt "%s" (to_string de)
in
let receiver, args' =
match args with
| (Dpvar pv) :: args' when isvirtual && Pvar.is_this pv
-> (None, args')
| a :: args' when isvirtual
-> (Some a, args')
| _
-> (None, args)
| (Dpvar pv) :: args' when isvirtual && Pvar.is_this pv ->
(None, args')
| a :: args' when isvirtual ->
(Some a, args')
| _ ->
(None, args)
in
let pp fmt =
let pp_receiver fmt = function None -> () | Some arg -> F.fprintf fmt "%a." pp_arg arg in
F.fprintf fmt "%a%a(%a)" pp_receiver receiver pp_fun fun_dexp pp_args args'
in
F.asprintf "%t" pp
| Darrow (Dpvar pv, f) when Pvar.is_this pv
-> (* this->fieldname *)
| Darrow (Dpvar pv, f) when Pvar.is_this pv ->
(* this->fieldname *)
Typ.Fieldname.to_simplified_string f
| Darrow (de, f)
-> if Typ.Fieldname.is_hidden f then to_string de
| Darrow (de, f) ->
if Typ.Fieldname.is_hidden f then to_string de
else if java () then to_string de ^ "." ^ Typ.Fieldname.to_flat_string f
else to_string de ^ "->" ^ Typ.Fieldname.to_string f
| Ddot (Dpvar _, fe) when eradicate_java ()
-> (* static field access *)
| Ddot (Dpvar _, fe) when eradicate_java () ->
(* static field access *)
Typ.Fieldname.to_simplified_string fe
| Ddot (de, f)
-> if Typ.Fieldname.is_hidden f then "&" ^ to_string de
| Ddot (de, f) ->
if Typ.Fieldname.is_hidden f then "&" ^ to_string de
else if java () then to_string de ^ "." ^ Typ.Fieldname.to_flat_string f
else to_string de ^ "." ^ Typ.Fieldname.to_string f
| Dpvar pv
-> Mangled.to_string (Pvar.get_name pv)
| Dpvaraddr pv
-> let s =
| Dpvar pv ->
Mangled.to_string (Pvar.get_name pv)
| Dpvaraddr pv ->
let s =
if eradicate_java () then Pvar.get_simplified_name pv
else Mangled.to_string (Pvar.get_name pv)
in
let ampersand = if eradicate_java () then "" else "&" in
ampersand ^ s
| Dunop (op, de)
-> Unop.str op ^ to_string de
| Dsizeof (typ, _, _)
-> F.asprintf "%a" (Typ.pp_full Pp.text) typ
| Dunknown
-> "unknown"
| Dretcall (de, _, _, _)
-> "returned by " ^ to_string de
| Dunop (op, de) ->
Unop.str op ^ to_string de
| Dsizeof (typ, _, _) ->
F.asprintf "%a" (Typ.pp_full Pp.text) typ
| Dunknown ->
"unknown"
| Dretcall (de, _, _, _) ->
"returned by " ^ to_string de
(** Pretty print a dexp. *)
let pp fmt de = F.fprintf fmt "%s" (to_string de)
@ -126,14 +127,16 @@ let pp_vpath pe fmt vpath =
Io_infer.Html.pp_end_color ()
else F.fprintf fmt "%a" pp vpath
let rec has_tmp_var = function
| Dpvar pvar | Dpvaraddr pvar
-> Pvar.is_frontend_tmp pvar
| Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _)
-> has_tmp_var dexp
| Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2)
-> has_tmp_var dexp1 || has_tmp_var dexp2
| Dretcall (dexp, dexp_list, _, _) | Dfcall (dexp, dexp_list, _, _)
-> has_tmp_var dexp || List.exists ~f:has_tmp_var dexp_list
| Dconst _ | Dunknown | Dsizeof (_, None, _)
-> false
| Dpvar pvar | Dpvaraddr pvar ->
Pvar.is_frontend_tmp pvar
| Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) ->
has_tmp_var dexp
| Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) ->
has_tmp_var dexp1 || has_tmp_var dexp2
| Dretcall (dexp, dexp_list, _, _) | Dfcall (dexp, dexp_list, _, _) ->
has_tmp_var dexp || List.exists ~f:has_tmp_var dexp_list
| Dconst _ | Dunknown | Dsizeof (_, None, _) ->
false

110
infer/src/IR/Errlog.ml
Unescape View File

@ -32,36 +32,39 @@ let pp_loc_trace fmt l = PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_ele
let contains_exception loc_trace_elem =
let pred nt =
match nt with
| Exception _
-> true
| Condition _ | Procedure_start _ | Procedure_end _
-> false
| Exception _ ->
true
| Condition _ | Procedure_start _ | Procedure_end _ ->
false
in
List.exists ~f:pred loc_trace_elem.lt_node_tags
let make_trace_element lt_level lt_loc lt_description lt_node_tags =
{lt_level; lt_loc; lt_description; lt_node_tags}
(** Trace of locations *)
type loc_trace = loc_trace_elem list
let compute_local_exception_line loc_trace =
let compute_local_exception_line state step =
match state with
| `Stop _
-> state
| `Continue (last_known_step_at_level_zero_opt, line_opt)
-> let last_known_step_at_level_zero_opt' =
| `Stop _ ->
state
| `Continue (last_known_step_at_level_zero_opt, line_opt) ->
let last_known_step_at_level_zero_opt' =
if Int.equal step.lt_level 0 then Some step else last_known_step_at_level_zero_opt
in
match last_known_step_at_level_zero_opt' with
| Some step_zero when contains_exception step
-> `Stop (last_known_step_at_level_zero_opt', Some step_zero.lt_loc.line)
| _
-> `Continue (last_known_step_at_level_zero_opt', line_opt)
| Some step_zero when contains_exception step ->
`Stop (last_known_step_at_level_zero_opt', Some step_zero.lt_loc.line)
| _ ->
`Continue (last_known_step_at_level_zero_opt', line_opt)
in
snd (List_.fold_until ~init:(`Continue (None, None)) ~f:compute_local_exception_line loc_trace)
type node_id_key = {node_id: int; node_key: int}
type err_key =
@ -103,11 +106,13 @@ module ErrLogHash = struct
Hashtbl.hash
(key.err_kind, key.in_footprint, key.err_name, Localise.error_desc_hash key.err_desc)
let equal key1 key2 =
[%compare.equal : Exceptions.err_kind * bool * IssueType.t]
(key1.err_kind, key1.in_footprint, key1.err_name)
(key2.err_kind, key2.in_footprint, key2.err_name)
&& Localise.error_desc_equal key1.err_desc key2.err_desc
end
include Hashtbl.Make (Key)
@ -122,6 +127,7 @@ let compare x y =
let bindings x = ErrLogHash.fold (fun k d l -> (k, d) :: l) x [] in
[%compare : (ErrLogHash.Key.t * ErrDataSet.t) list] (bindings x) (bindings y)
(** Empty error log *)
let empty () = ErrLogHash.create 13
@ -134,11 +140,13 @@ let iter (f: iter_fun) (err_log: t) =
(fun err_key set -> ErrDataSet.iter (fun err_data -> f err_key err_data) set)
err_log
let fold (f: err_key -> err_data -> 'a -> 'a) t acc =
ErrLogHash.fold
(fun err_key set acc -> ErrDataSet.fold (fun err_data acc -> f err_key err_data acc) set acc)
t acc
(** Return the number of elements in the error log which satisfy [filter] *)
let size filter (err_log: t) =
let count = ref 0 in
@ -148,6 +156,7 @@ let size filter (err_log: t) =
err_log ;
!count
(** Print errors from error log *)
let pp_errors fmt (errlog: t) =
let f key _ =
@ -156,6 +165,7 @@ let pp_errors fmt (errlog: t) =
in
ErrLogHash.iter f errlog
(** Print warnings from error log *)
let pp_warnings fmt (errlog: t) =
let f key _ =
@ -164,6 +174,7 @@ let pp_warnings fmt (errlog: t) =
in
ErrLogHash.iter f errlog
(** Print an error log in html format *)
let pp_html source path_to_root fmt (errlog: t) =
let pp_eds fmt err_datas =
@ -191,15 +202,17 @@ let pp_html source path_to_root fmt (errlog: t) =
F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline () ;
ErrLogHash.iter (pp_err_log false Exceptions.Kinfo) errlog
(* I use string in case we want to display a different name to the user*)
let severity_to_str severity =
match severity with
| Exceptions.High
-> "HIGH"
| Exceptions.Medium
-> "MEDIUM"
| Exceptions.Low
-> "LOW"
| Exceptions.High ->
"HIGH"
| Exceptions.Medium ->
"MEDIUM"
| Exceptions.Low ->
"LOW"
(** Add an error description to the error log unless there is
one already at the same node + session; return true if added *)
@ -210,12 +223,16 @@ let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool =
else (
ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds) ;
true )
with Not_found -> ErrLogHash.add tbl err_key err_datas ; true
with Not_found ->
ErrLogHash.add tbl err_key err_datas ;
true
(** Update an old error log with a new one *)
let update errlog_old errlog_new =
ErrLogHash.iter (fun err_key l -> ignore (add_issue errlog_old err_key l)) errlog_new
let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_file ?doc_url exn =
let error = Exceptions.recognize_exception exn in
let err_kind = match error.kind with Some err_kind -> err_kind | _ -> err_kind in
@ -226,10 +243,10 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_
in
let hide_memory_error =
match Localise.error_desc_get_bucket error.description with
| Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin
-> not Mleak_buckets.should_raise_leak_unknown_origin
| _
-> false
| Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin ->
not Mleak_buckets.should_raise_leak_unknown_origin
| _ ->
false
in
let log_it =
Exceptions.equal_visibility error.visibility Exceptions.Exn_user
@ -263,7 +280,8 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_
let print_now () =
L.(debug Analysis Medium)
"@\n%a@\n@?"
(Exceptions.pp_err ~node_key loc err_kind error.name error.description error.ml_loc) () ;
(Exceptions.pp_err ~node_key loc err_kind error.name error.description error.ml_loc)
() ;
if err_kind <> Exceptions.Kerror then
let warn_str =
let pp fmt =
@ -274,17 +292,18 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_
in
let d =
match err_kind with
| Exceptions.Kerror
-> L.d_error
| Exceptions.Kwarning
-> L.d_warning
| Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike
-> L.d_info
| Exceptions.Kerror ->
L.d_error
| Exceptions.Kwarning ->
L.d_warning
| Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike ->
L.d_info
in
d warn_str ; L.d_ln ()
in
if should_print_now then print_now ()
type err_log = t
(** Global per-file error table *)
@ -316,6 +335,7 @@ module Err_table = struct
let pp ~key:err_string ~data:count = F.fprintf fmt " %s:%d" err_string count in
String.Map.iteri ~f:pp !err_name_map
module LocMap = Caml.Map.Make (struct
type t = ErrDataSet.elt
@ -333,20 +353,20 @@ module Err_table = struct
let add_err nslm key =
let map =
match (key.in_footprint, key.err_kind) with
| true, Exceptions.Kerror
-> map_err_fp
| false, Exceptions.Kerror
-> map_err_re
| true, Exceptions.Kwarning
-> map_warn_fp
| false, Exceptions.Kwarning
-> map_warn_re
| _, Exceptions.Kinfo
-> map_info
| _, Exceptions.Kadvice
-> map_advice
| _, Exceptions.Klike
-> map_likes
| true, Exceptions.Kerror ->
map_err_fp
| false, Exceptions.Kerror ->
map_err_re
| true, Exceptions.Kwarning ->
map_warn_fp
| false, Exceptions.Kwarning ->
map_warn_re
| _, Exceptions.Kinfo ->
map_info
| _, Exceptions.Kadvice ->
map_advice
| _, Exceptions.Klike ->
map_likes
in
try
let err_list = LocMap.find nslm !map in
@ -378,6 +398,7 @@ module Err_table = struct
LocMap.iter
(fun nslm err_names -> F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names)
!map_warn_re
end
type err_table = Err_table.t
@ -393,6 +414,7 @@ let err_table_size_footprint ekind =
let filter ekind' in_footprint = Exceptions.equal_err_kind ekind ekind' && in_footprint in
Err_table.table_size filter
(** Print stats for the global per-file error table *)
let pp_err_table_stats ekind = Err_table.pp_stats_footprint ekind

291
infer/src/IR/Exceptions.ml
Unescape View File

@ -24,6 +24,7 @@ let equal_visibility = [%compare.equal : visibility]
let string_of_visibility vis =
match vis with Exn_user -> "user" | Exn_developer -> "developer" | Exn_system -> "system"
(** severity of bugs *)
type severity =
| High (** high severity bug *)
@ -160,24 +161,24 @@ type t =
let recognize_exception exn =
match exn with
(* all the static names of errors must be defined in Config.IssueType *)
| Abduction_case_not_implemented ml_loc
-> { name= IssueType.abduction_case_not_implemented
| Abduction_case_not_implemented ml_loc ->
{ name= IssueType.abduction_case_not_implemented
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Context_leak (desc, _)
-> { name= IssueType.context_leak
| Context_leak (desc, _) ->
{ name= IssueType.context_leak
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Nocat }
| Analysis_stops (desc, ml_loc_opt)
-> let visibility = if Config.analysis_stops then Exn_user else Exn_developer in
| Analysis_stops (desc, ml_loc_opt) ->
let visibility = if Config.analysis_stops then Exn_user else Exn_developer in
{ name= IssueType.analysis_stops
; description= desc
; ml_loc= ml_loc_opt
@ -185,40 +186,40 @@ let recognize_exception exn =
; severity= Medium
; kind= None
; category= Nocat }
| Array_of_pointsto ml_loc
-> { name= IssueType.array_of_pointsto
| Array_of_pointsto ml_loc ->
{ name= IssueType.array_of_pointsto
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Array_out_of_bounds_l1 (desc, ml_loc)
-> { name= IssueType.array_out_of_bounds_l1
| Array_out_of_bounds_l1 (desc, ml_loc) ->
{ name= IssueType.array_out_of_bounds_l1
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Checker }
| Array_out_of_bounds_l2 (desc, ml_loc)
-> { name= IssueType.array_out_of_bounds_l2
| Array_out_of_bounds_l2 (desc, ml_loc) ->
{ name= IssueType.array_out_of_bounds_l2
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Array_out_of_bounds_l3 (desc, ml_loc)
-> { name= IssueType.array_out_of_bounds_l3
| Array_out_of_bounds_l3 (desc, ml_loc) ->
{ name= IssueType.array_out_of_bounds_l3
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Medium
; kind= None
; category= Nocat }
| Assert_failure (f, l, c)
-> let ml_loc = (f, l, c, c) in
| Assert_failure (f, l, c) ->
let ml_loc = (f, l, c, c) in
{ name= IssueType.assert_failure
; description= Localise.no_desc
; ml_loc= Some ml_loc
@ -226,48 +227,48 @@ let recognize_exception exn =
; severity= High
; kind= None
; category= Nocat }
| Bad_footprint ml_loc
-> { name= IssueType.bad_footprint
| Bad_footprint ml_loc ->
{ name= IssueType.bad_footprint
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Cannot_star ml_loc
-> { name= IssueType.cannot_star
| Cannot_star ml_loc ->
{ name= IssueType.cannot_star
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Class_cast_exception (desc, ml_loc)
-> { name= IssueType.class_cast_exception
| Class_cast_exception (desc, ml_loc) ->
{ name= IssueType.class_cast_exception
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Codequery desc
-> { name= IssueType.codequery
| Codequery desc ->
{ name= IssueType.codequery
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Comparing_floats_for_equality (desc, ml_loc)
-> { name= IssueType.comparing_floats_for_equality
| Comparing_floats_for_equality (desc, ml_loc) ->
{ name= IssueType.comparing_floats_for_equality
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Condition_always_true_false (desc, b, ml_loc)
-> let name = if b then IssueType.condition_always_true else IssueType.condition_always_false in
| Condition_always_true_false (desc, b, ml_loc) ->
let name = if b then IssueType.condition_always_true else IssueType.condition_always_false in
{ name
; description= desc
; ml_loc= Some ml_loc
@ -275,21 +276,21 @@ let recognize_exception exn =
; severity= Medium
; kind= None
; category= Nocat }
| Custom_error (error_msg, desc)
-> { name= IssueType.from_string error_msg
| Custom_error (error_msg, desc) ->
{ name= IssueType.from_string error_msg
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Checker }
| Dangling_pointer_dereference (dko, desc, ml_loc)
-> let visibility =
| Dangling_pointer_dereference (dko, desc, ml_loc) ->
let visibility =
match dko with
| Some _
-> Exn_user (* only show to the user if the category was identified *)
| None
-> Exn_developer
| Some _ ->
Exn_user (* only show to the user if the category was identified *)
| None ->
Exn_developer
in
{ name= IssueType.dangling_pointer_dereference
; description= desc
@ -298,128 +299,128 @@ let recognize_exception exn =
; severity= High
; kind= None
; category= Prover }
| Deallocate_stack_variable desc
-> { name= IssueType.deallocate_stack_variable
| Deallocate_stack_variable desc ->
{ name= IssueType.deallocate_stack_variable
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Deallocate_static_memory desc
-> { name= IssueType.deallocate_static_memory
| Deallocate_static_memory desc ->
{ name= IssueType.deallocate_static_memory
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Deallocation_mismatch (desc, ml_loc)
-> { name= IssueType.deallocation_mismatch
| Deallocation_mismatch (desc, ml_loc) ->
{ name= IssueType.deallocation_mismatch
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Divide_by_zero (desc, ml_loc)
-> { name= IssueType.divide_by_zero
| Divide_by_zero (desc, ml_loc) ->
{ name= IssueType.divide_by_zero
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Checker }
| Double_lock (desc, ml_loc)
-> { name= IssueType.double_lock
| Double_lock (desc, ml_loc) ->
{ name= IssueType.double_lock
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Prover }
| Eradicate (kind_s, desc)
-> { name= IssueType.from_string kind_s
| Eradicate (kind_s, desc) ->
{ name= IssueType.from_string kind_s
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Empty_vector_access (desc, ml_loc)
-> { name= IssueType.empty_vector_access
| Empty_vector_access (desc, ml_loc) ->
{ name= IssueType.empty_vector_access
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Prover }
| Field_not_null_checked (desc, ml_loc)
-> { name= IssueType.field_not_null_checked
| Field_not_null_checked (desc, ml_loc) ->
{ name= IssueType.field_not_null_checked
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= Some Kwarning
; category= Nocat }
| Frontend_warning ((name, hum), desc, ml_loc)
-> { name= IssueType.from_string name ?hum
| Frontend_warning ((name, hum), desc, ml_loc) ->
{ name= IssueType.from_string name ?hum
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Linters }
| Checkers (kind_s, desc)
-> { name= IssueType.from_string kind_s
| Checkers (kind_s, desc) ->
{ name= IssueType.from_string kind_s
; description= desc
; ml_loc= None
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Null_dereference (desc, ml_loc)
-> { name= IssueType.null_dereference
| Null_dereference (desc, ml_loc) ->
{ name= IssueType.null_dereference
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Null_test_after_dereference (desc, ml_loc)
-> { name= IssueType.null_test_after_dereference
| Null_test_after_dereference (desc, ml_loc) ->
{ name= IssueType.null_test_after_dereference
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Nocat }
| Pointer_size_mismatch (desc, ml_loc)
-> { name= IssueType.pointer_size_mismatch
| Pointer_size_mismatch (desc, ml_loc) ->
{ name= IssueType.pointer_size_mismatch
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Checker }
| Inherently_dangerous_function desc
-> { name= IssueType.inherently_dangerous_function
| Inherently_dangerous_function desc ->
{ name= IssueType.inherently_dangerous_function
; description= desc
; ml_loc= None
; visibility= Exn_developer
; severity= Medium
; kind= None
; category= Nocat }
| Internal_error desc
-> { name= IssueType.internal_error
| Internal_error desc ->
{ name= IssueType.internal_error
; description= desc
; ml_loc= None
; visibility= Exn_developer
; severity= High
; kind= None
; category= Nocat }
| Java_runtime_exception (exn_name, _, desc)
-> let exn_str = Typ.Name.name exn_name in
| Java_runtime_exception (exn_name, _, desc) ->
let exn_str = Typ.Name.name exn_name in
{ name= IssueType.from_string exn_str
; description= desc
; ml_loc= None
@ -427,8 +428,8 @@ let recognize_exception exn =
; severity= High
; kind= None
; category= Prover }
| Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc)
-> if done_array_abstraction then
| Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) ->
if done_array_abstraction then
{ name= IssueType.leak_after_array_abstraction
; description= error_desc
; ml_loc= Some ml_loc
@ -447,14 +448,14 @@ let recognize_exception exn =
else
let name =
match resource with
| PredSymb.Rmemory _
-> IssueType.memory_leak
| PredSymb.Rfile
-> IssueType.resource_leak
| PredSymb.Rlock
-> IssueType.resource_leak
| PredSymb.Rignore
-> IssueType.memory_leak
| PredSymb.Rmemory _ ->
IssueType.memory_leak
| PredSymb.Rfile ->
IssueType.resource_leak
| PredSymb.Rlock ->
IssueType.resource_leak
| PredSymb.Rignore ->
IssueType.memory_leak
in
{ name
; description= error_desc
@ -463,8 +464,8 @@ let recognize_exception exn =
; severity= High
; kind= None
; category= Prover }
| Missing_fld (fld, ml_loc)
-> let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
| Missing_fld (fld, ml_loc) ->
let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
{ name= IssueType.missing_fld
; description= desc
; ml_loc= Some ml_loc
@ -472,32 +473,32 @@ let recognize_exception exn =
; severity= Medium
; kind= None
; category= Nocat }
| Premature_nil_termination (desc, ml_loc)
-> { name= IssueType.premature_nil_termination
| Premature_nil_termination (desc, ml_loc) ->
{ name= IssueType.premature_nil_termination
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Parameter_not_null_checked (desc, ml_loc)
-> { name= IssueType.parameter_not_null_checked
| Parameter_not_null_checked (desc, ml_loc) ->
{ name= IssueType.parameter_not_null_checked
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= Some Kwarning
; category= Nocat }
| Precondition_not_found (desc, ml_loc)
-> { name= IssueType.precondition_not_found
| Precondition_not_found (desc, ml_loc) ->
{ name= IssueType.precondition_not_found
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Precondition_not_met (desc, ml_loc)
-> { name= IssueType.precondition_not_met
| Precondition_not_met (desc, ml_loc) ->
{ name= IssueType.precondition_not_met
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
@ -505,72 +506,72 @@ let recognize_exception exn =
; kind= Some Kwarning
; category= Nocat }
(* always a warning *)
| Retain_cycle (_, desc, ml_loc)
-> { name= IssueType.retain_cycle
| Retain_cycle (_, desc, ml_loc) ->
{ name= IssueType.retain_cycle
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Registered_observer_being_deallocated (desc, ml_loc)
-> { name= IssueType.registered_observer_being_deallocated
| Registered_observer_being_deallocated (desc, ml_loc) ->
{ name= IssueType.registered_observer_being_deallocated
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Nocat }
| Return_expression_required (desc, ml_loc)
-> { name= IssueType.return_expression_required
| Return_expression_required (desc, ml_loc) ->
{ name= IssueType.return_expression_required
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Stack_variable_address_escape (desc, ml_loc)
-> { name= IssueType.stack_variable_address_escape
| Stack_variable_address_escape (desc, ml_loc) ->
{ name= IssueType.stack_variable_address_escape
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= Some Kerror
; category= Nocat }
| Return_statement_missing (desc, ml_loc)
-> { name= IssueType.return_statement_missing
| Return_statement_missing (desc, ml_loc) ->
{ name= IssueType.return_statement_missing
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Return_value_ignored (desc, ml_loc)
-> { name= IssueType.return_value_ignored
| Return_value_ignored (desc, ml_loc) ->
{ name= IssueType.return_value_ignored
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| SymOp.Analysis_failure_exe _
-> { name= IssueType.failure_exe
| SymOp.Analysis_failure_exe _ ->
{ name= IssueType.failure_exe
; description= Localise.no_desc
; ml_loc= None
; visibility= Exn_system
; severity= Low
; kind= None
; category= Nocat }
| Skip_function desc
-> { name= IssueType.skip_function
| Skip_function desc ->
{ name= IssueType.skip_function
; description= desc
; ml_loc= None
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Skip_pointer_dereference (desc, ml_loc)
-> { name= IssueType.skip_pointer_dereference
| Skip_pointer_dereference (desc, ml_loc) ->
{ name= IssueType.skip_pointer_dereference
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
@ -578,72 +579,72 @@ let recognize_exception exn =
; kind= Some Kinfo
; category= Nocat }
(* always an info *)
| Symexec_memory_error ml_loc
-> { name= IssueType.symexec_memory_error
| Symexec_memory_error ml_loc ->
{ name= IssueType.symexec_memory_error
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Uninitialized_value (desc, ml_loc)
-> { name= IssueType.uninitialized_value
| Uninitialized_value (desc, ml_loc) ->
{ name= IssueType.uninitialized_value
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Unary_minus_applied_to_unsigned_expression (desc, ml_loc)
-> { name= IssueType.unary_minus_applied_to_unsigned_expression
| Unary_minus_applied_to_unsigned_expression (desc, ml_loc) ->
{ name= IssueType.unary_minus_applied_to_unsigned_expression
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Unknown_proc
-> { name= IssueType.unknown_proc
| Unknown_proc ->
{ name= IssueType.unknown_proc
; description= Localise.no_desc
; ml_loc= None
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| Unreachable_code_after (desc, ml_loc)
-> { name= IssueType.unreachable_code_after
| Unreachable_code_after (desc, ml_loc) ->
{ name= IssueType.unreachable_code_after
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= Medium
; kind= None
; category= Nocat }
| Unsafe_guarded_by_access (desc, ml_loc)
-> { name= IssueType.unsafe_guarded_by_access
| Unsafe_guarded_by_access (desc, ml_loc) ->
{ name= IssueType.unsafe_guarded_by_access
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Use_after_free (desc, ml_loc)
-> { name= IssueType.use_after_free
| Use_after_free (desc, ml_loc) ->
{ name= IssueType.use_after_free
; description= desc
; ml_loc= Some ml_loc
; visibility= Exn_user
; severity= High
; kind= None
; category= Prover }
| Wrong_argument_number ml_loc
-> { name= IssueType.wrong_argument_number
| Wrong_argument_number ml_loc ->
{ name= IssueType.wrong_argument_number
; description= Localise.no_desc
; ml_loc= Some ml_loc
; visibility= Exn_developer
; severity= Low
; kind= None
; category= Nocat }
| exn
-> { name= IssueType.failure_exe
| exn ->
{ name= IssueType.failure_exe
; description=
Localise.verbatim_desc (F.asprintf "%a: %s" Exn.pp exn (Caml.Printexc.get_backtrace ()))
; ml_loc= None
@ -652,6 +653,7 @@ let recognize_exception exn =
; kind= None
; category= Nocat }
(** print a description of the exception to the html output *)
let print_exception_html s exn =
let error = recognize_exception exn in
@ -661,29 +663,32 @@ let print_exception_html s exn =
let desc_str = F.asprintf "%a" Localise.pp_error_desc error.description in
L.d_strln_color Red (s ^ error.name.IssueType.unique_id ^ " " ^ desc_str ^ ml_loc_string)
(** string describing an error kind *)
let err_kind_string = function
| Kwarning
-> "WARNING"
| Kerror
-> "ERROR"
| Kinfo
-> "INFO"
| Kadvice
-> "ADVICE"
| Klike
-> "LIKE"
| Kwarning ->
"WARNING"
| Kerror ->
"ERROR"
| Kinfo ->
"INFO"
| Kadvice ->
"ADVICE"
| Klike ->
"LIKE"
(** string describing an error class *)
let err_class_string = function
| Checker
-> "CHECKER"
| Prover
-> "PROVER"
| Nocat
-> ""
| Linters
-> "Linters"
| Checker ->
"CHECKER"
| Prover ->
"PROVER"
| Nocat ->
""
| Linters ->
"Linters"
(** whether to print the bug key together with the error message *)
let print_key = false
@ -695,7 +700,9 @@ let pp_err ~node_key loc ekind ex_name desc ml_loc_opt fmt () =
F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n" SourceFile.pp loc.Location.file loc.Location.line kind
IssueType.pp ex_name Localise.pp_error_desc desc pp_key node_key L.pp_ml_loc_opt ml_loc_opt
(** Return true if the exception is not serious and should be handled in timeout mode *)
let handle_exception exn =
let error = recognize_exception exn in
equal_visibility error.visibility Exn_user || equal_visibility error.visibility Exn_developer

6
infer/src/IR/Exceptions.mli
Unescape View File

@ -67,8 +67,7 @@ exception Context_leak of Localise.error_desc * Logging.ml_loc
exception Custom_error of string * Localise.error_desc
exception
Dangling_pointer_dereference of
exception Dangling_pointer_dereference of
PredSymb.dangling_kind option * Localise.error_desc * Logging.ml_loc
exception Deallocate_stack_variable of Localise.error_desc
@ -97,8 +96,7 @@ exception Internal_error of Localise.error_desc
exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc
exception
Leak of
exception Leak of
bool * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * Logging.ml_loc
exception Missing_fld of Typ.Fieldname.t * Logging.ml_loc

189
infer/src/IR/Exp.ml
Unescape View File

@ -77,6 +77,7 @@ end)
let rec is_array_index_of exp1 exp2 =
match exp1 with Lindex (exp, _) -> is_array_index_of exp exp2 | _ -> equal exp1 exp2
let is_null_literal = function Const Cint n -> IntLit.isnull n | _ -> false
let is_this = function Lvar pvar -> Pvar.is_this pvar | _ -> false
@ -88,65 +89,71 @@ let is_zero = function Const Cint n -> IntLit.iszero n | _ -> false
(** Turn an expression representing a type into the type it represents
If not a sizeof, return the default type if given, otherwise raise an exception *)
let texp_to_typ default_opt = function
| Sizeof {typ}
-> typ
| _
-> Typ.unsome "texp_to_typ" default_opt
| Sizeof {typ} ->
typ
| _ ->
Typ.unsome "texp_to_typ" default_opt
(** Return the root of [lexp]. *)
let rec root_of_lexp lexp =
match (lexp : t) with
| Var _
-> lexp
| Const _
-> lexp
| Cast (_, e)
-> root_of_lexp e
| UnOp _ | BinOp _ | Exn _ | Closure _
-> lexp
| Lvar _
-> lexp
| Lfield (e, _, _)
-> root_of_lexp e
| Lindex (e, _)
-> root_of_lexp e
| Sizeof _
-> lexp
| Var _ ->
lexp
| Const _ ->
lexp
| Cast (_, e) ->
root_of_lexp e
| UnOp _ | BinOp _ | Exn _ | Closure _ ->
lexp
| Lvar _ ->
lexp
| Lfield (e, _, _) ->
root_of_lexp e
| Lindex (e, _) ->
root_of_lexp e
| Sizeof _ ->
lexp
(** Checks whether an expression denotes a location by pointer arithmetic.
Currently, catches array - indexing expressions such as a[i] only. *)
let rec pointer_arith = function
| Lfield (e, _, _)
-> pointer_arith e
| Lindex _
-> true
| _
-> false
| Lfield (e, _, _) ->
pointer_arith e
| Lindex _ ->
true
| _ ->
false
let get_undefined footprint =
Var (Ident.create_fresh (if footprint then Ident.kfootprint else Ident.kprimed))
(** returns true if the expression represents a stack-directed address *)
let rec is_stack_addr e =
match (e : t) with
| Lvar pv
-> not (Pvar.is_global pv)
| UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) | Lindex (e', _)
-> is_stack_addr e'
| _
-> false
| Lvar pv ->
not (Pvar.is_global pv)
| UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) | Lindex (e', _) ->
is_stack_addr e'
| _ ->
false
(** returns true if the express operates on address of local variable *)
let rec has_local_addr e =
match (e : t) with
| Lvar pv
-> Pvar.is_local pv
| UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _)
-> has_local_addr e'
| BinOp (_, e0, e1) | Lindex (e0, e1)
-> has_local_addr e0 || has_local_addr e1
| _
-> false
| Lvar pv ->
Pvar.is_local pv
| UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) ->
has_local_addr e'
| BinOp (_, e0, e1) | Lindex (e0, e1) ->
has_local_addr e0 || has_local_addr e1
| _ ->
false
(** Create integer constant *)
let int i = Const (Cint i)
@ -185,69 +192,70 @@ let lt e1 e2 = BinOp (Lt, e1, e2)
let get_vars exp =
let rec get_vars_ exp vars =
match exp with
| Lvar pvar
-> (fst vars, pvar :: snd vars)
| Var id
-> (id :: fst vars, snd vars)
| Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) | Exn e | Sizeof {dynamic_length= Some e}
-> get_vars_ e vars
| BinOp (_, e1, e2) | Lindex (e1, e2)
-> get_vars_ e1 vars |> get_vars_ e2
| Closure {captured_vars}
-> List.fold
| Lvar pvar ->
(fst vars, pvar :: snd vars)
| Var id ->
(id :: fst vars, snd vars)
| Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) | Exn e | Sizeof {dynamic_length= Some e} ->
get_vars_ e vars
| BinOp (_, e1, e2) | Lindex (e1, e2) ->
get_vars_ e1 vars |> get_vars_ e2
| Closure {captured_vars} ->
List.fold
~f:(fun vars_acc (captured_exp, _, _) -> get_vars_ captured_exp vars_acc)
~init:vars captured_vars
| Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _)
-> vars
| Sizeof _
-> vars
| Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) ->
vars
| Sizeof _ ->
vars
in
get_vars_ exp ([], [])
(** Pretty print an expression. *)
let rec pp_ pe pp_t f e =
let pp_exp = pp_ pe pp_t in
let print_binop_stm_output e1 op e2 =
match (op : Binop.t) with
| Eq | Ne | PlusA | Mult
-> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe op) pp_exp e1
| Lt
-> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Gt) pp_exp e1
| Gt
-> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Lt) pp_exp e1
| Le
-> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Ge) pp_exp e1
| Ge
-> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Le) pp_exp e1
| _
-> F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2
| Eq | Ne | PlusA | Mult ->
F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe op) pp_exp e1
| Lt ->
F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Gt) pp_exp e1
| Gt ->
F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Lt) pp_exp e1
| Le ->
F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Ge) pp_exp e1
| Ge ->
F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Le) pp_exp e1
| _ ->
F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2
in
match (e : t) with
| Var id
-> Ident.pp pe f id
| Const c
-> F.fprintf f "%a" (Const.pp pe) c
| Cast (typ, e)
-> F.fprintf f "(%a)%a" pp_t typ pp_exp e
| UnOp (op, e, _)
-> F.fprintf f "%s%a" (Unop.str op) pp_exp e
| BinOp (op, Const c, e2) when Config.smt_output
-> print_binop_stm_output (Const c) op e2
| BinOp (op, e1, e2)
-> F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2
| Exn e
-> F.fprintf f "EXN %a" pp_exp e
| Closure {name; captured_vars}
-> let id_exps = List.map ~f:(fun (id_exp, _, _) -> id_exp) captured_vars in
| Var id ->
Ident.pp pe f id
| Const c ->
F.fprintf f "%a" (Const.pp pe) c
| Cast (typ, e) ->
F.fprintf f "(%a)%a" pp_t typ pp_exp e
| UnOp (op, e, _) ->
F.fprintf f "%s%a" (Unop.str op) pp_exp e
| BinOp (op, Const c, e2) when Config.smt_output ->
print_binop_stm_output (Const c) op e2
| BinOp (op, e1, e2) ->
F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2
| Exn e ->
F.fprintf f "EXN %a" pp_exp e
| Closure {name; captured_vars} ->
let id_exps = List.map ~f:(fun (id_exp, _, _) -> id_exp) captured_vars in
F.fprintf f "(%a)" (Pp.comma_seq pp_exp) (Const (Cfun name) :: id_exps)
| Lvar pv
-> Pvar.pp pe f pv
| Lfield (e, fld, _)
-> F.fprintf f "%a.%a" pp_exp e Typ.Fieldname.pp fld
| Lindex (e1, e2)
-> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2
| Sizeof {typ; nbytes; dynamic_length; subtype}
-> let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" pp_exp) l in
| Lvar pv ->
Pvar.pp pe f pv
| Lfield (e, fld, _) ->
F.fprintf f "%a.%a" pp_exp e Typ.Fieldname.pp fld
| Lindex (e1, e2) ->
F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2
| Sizeof {typ; nbytes; dynamic_length; subtype} ->
let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" pp_exp) l in
let pp_size f size = Option.iter ~f:(Int.pp f) size in
let pp_if b pp label f v = if b then F.fprintf f ";%s=%a" label pp v in
let pp_if_some pp_opt label f opt = pp_if (Option.is_some opt) pp_opt label f opt in
@ -257,6 +265,7 @@ let rec pp_ pe pp_t f e =
(pp_if (not (String.equal "" subt_s)) Subtype.pp "sub_t")
subtype
let pp_printenv pe pp_typ f e = pp_ pe (pp_typ pe) f e
let pp f e = pp_printenv Pp.text Typ.pp f e

172
infer/src/IR/HilExp.ml
Unescape View File

@ -23,78 +23,81 @@ type t =
[@@deriving compare]
let rec pp fmt = function
| AccessPath access_path
-> AccessPath.pp fmt access_path
| UnaryOperator (op, e, _)
-> F.fprintf fmt "%s%a" (Unop.str op) pp e
| BinaryOperator (op, e1, e2)
-> F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2
| Exception e
-> F.fprintf fmt "exception %a" pp e
| Closure (pname, _)
-> F.fprintf fmt "closure(%a)" Typ.Procname.pp pname
| Constant c
-> Const.pp Pp.text fmt c
| Cast (typ, e)
-> F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e
| Sizeof (typ, length)
-> let pp_length fmt = Option.iter ~f:(F.fprintf fmt "[%a]" pp) in
| AccessPath access_path ->
AccessPath.pp fmt access_path
| UnaryOperator (op, e, _) ->
F.fprintf fmt "%s%a" (Unop.str op) pp e
| BinaryOperator (op, e1, e2) ->
F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2
| Exception e ->
F.fprintf fmt "exception %a" pp e
| Closure (pname, _) ->
F.fprintf fmt "closure(%a)" Typ.Procname.pp pname
| Constant c ->
Const.pp Pp.text fmt c
| Cast (typ, e) ->
F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e
| Sizeof (typ, length) ->
let pp_length fmt = Option.iter ~f:(F.fprintf fmt "[%a]" pp) in
F.fprintf fmt "sizeof(%a%a)" (Typ.pp_full Pp.text) typ pp_length length
let rec get_typ tenv = function
| AccessPath access_path
-> AccessPath.get_typ access_path tenv
| UnaryOperator (_, _, typ_opt)
-> typ_opt
| BinaryOperator ((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr), _, _)
-> Some (Typ.mk (Typ.Tint Typ.IBool))
| AccessPath access_path ->
AccessPath.get_typ access_path tenv
| UnaryOperator (_, _, typ_opt) ->
typ_opt
| BinaryOperator ((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr), _, _) ->
Some (Typ.mk (Typ.Tint Typ.IBool))
| BinaryOperator (_, e1, e2) -> (
match
(* TODO: doing this properly will require taking account of language-specific coercion
semantics. Only return a type when the operands have the same type for now *)
(get_typ tenv e1, get_typ tenv e2)
with
| Some typ1, Some typ2 when Typ.equal typ1 typ2
-> Some typ1
| _
-> None )
| Exception t
-> get_typ tenv t
| Closure _ | Constant Cfun _
-> (* We don't have a way to represent function types *)
| Some typ1, Some typ2 when Typ.equal typ1 typ2 ->
Some typ1
| _ ->
None )
| Exception t ->
get_typ tenv t
| Closure _ | Constant Cfun _ ->
(* We don't have a way to represent function types *)
None
| Constant Cint _
-> (* TODO: handle signedness *)
| Constant Cint _ ->
(* TODO: handle signedness *)
Some (Typ.mk (Typ.Tint Typ.IInt))
| Constant Cfloat _
-> Some (Typ.mk (Typ.Tfloat Typ.FFloat))
| Constant Cclass _
-> (* TODO: this only happens in Java. We probably need to change it to `Cclass of Typ.Name.t`
| Constant Cfloat _ ->
Some (Typ.mk (Typ.Tfloat Typ.FFloat))
| Constant Cclass _ ->
(* TODO: this only happens in Java. We probably need to change it to `Cclass of Typ.Name.t`
to give a useful result here *)
None
| Constant Cstr _
-> (* TODO: this will need to behave differently depending on whether we're in C++ or Java *)
| Constant Cstr _ ->
(* TODO: this will need to behave differently depending on whether we're in C++ or Java *)
None
| Cast (typ, _)
-> Some typ
| Sizeof _
-> (* sizeof returns a size_t, which is an unsigned int *)
| Cast (typ, _) ->
Some typ
| Sizeof _ ->
(* sizeof returns a size_t, which is an unsigned int *)
Some (Typ.mk (Typ.Tint Typ.IUInt))
let get_access_paths exp0 =
let rec get_access_paths_ exp acc =
match exp with
| AccessPath ap
-> ap :: acc
| Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e)
-> get_access_paths_ e acc
| BinaryOperator (_, e1, e2)
-> get_access_paths_ e1 acc |> get_access_paths_ e2
| Closure _ | Constant _ | Sizeof _
-> acc
| AccessPath ap ->
ap :: acc
| Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e) ->
get_access_paths_ e acc
| BinaryOperator (_, e1, e2) ->
get_access_paths_ e1 acc |> get_access_paths_ e2
| Closure _ | Constant _ | Sizeof _ ->
acc
in
get_access_paths_ exp0 []
(* convert an SIL expression into an HIL expression. the [f_resolve_id] function should map an SSA
temporary variable to the access path it represents. evaluating the HIL expression should
produce the same result as evaluating the SIL expression and replacing the temporary variables
@ -102,29 +105,29 @@ let get_access_paths exp0 =
let of_sil ~include_array_indexes ~f_resolve_id exp typ =
let rec of_sil_ (exp: Exp.t) typ =
match exp with
| Var id
-> let ap =
| Var id ->
let ap =
match f_resolve_id (Var.of_id id) with
| Some access_path
-> access_path
| None
-> AccessPath.of_id id typ
| Some access_path ->
access_path
| None ->
AccessPath.of_id id typ
in
AccessPath ap
| UnOp (op, e, typ_opt)
-> UnaryOperator (op, of_sil_ e typ, typ_opt)
| BinOp (op, e0, e1)
-> BinaryOperator (op, of_sil_ e0 typ, of_sil_ e1 typ)
| Exn e
-> Exception (of_sil_ e typ)
| Const c
-> Constant c
| Cast (cast_typ, e)
-> Cast (cast_typ, of_sil_ e typ)
| Sizeof {typ; dynamic_length}
-> Sizeof (typ, Option.map ~f:(fun e -> of_sil_ e typ) dynamic_length)
| Closure closure
-> let environment =
| UnOp (op, e, typ_opt) ->
UnaryOperator (op, of_sil_ e typ, typ_opt)
| BinOp (op, e0, e1) ->
BinaryOperator (op, of_sil_ e0 typ, of_sil_ e1 typ)
| Exn e ->
Exception (of_sil_ e typ)
| Const c ->
Constant c
| Cast (cast_typ, e) ->
Cast (cast_typ, of_sil_ e typ)
| Sizeof {typ; dynamic_length} ->
Sizeof (typ, Option.map ~f:(fun e -> of_sil_ e typ) dynamic_length)
| Closure closure ->
let environment =
List.map
~f:(fun (value, pvar, typ) -> (AccessPath.base_of_pvar pvar typ, of_sil_ value typ))
closure.captured_vars
@ -132,38 +135,39 @@ let of_sil ~include_array_indexes ~f_resolve_id exp typ =
Closure (closure.name, environment)
| Lfield (root_exp, fld, root_exp_typ) -> (
match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with
| Some access_path
-> AccessPath access_path
| None
-> (* unsupported field expression: represent with a dummy variable *)
| Some access_path ->
AccessPath access_path
| None ->
(* unsupported field expression: represent with a dummy variable *)
of_sil_
(Exp.Lfield
( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0)
, fld
, root_exp_typ )) typ )
| Lindex (Const Cstr s, index_exp)
-> (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable
| Lindex (Const Cstr s, index_exp) ->
(* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable
for the string literal. if you actually need to see the value of the string literal in the
analysis, you should probably be using SIL. this is unsound if the code modifies the
literal, e.g. using `const_cast<char*>` *)
of_sil_ (Exp.Lindex (Var (Ident.create_normal (Ident.string_to_name s) 0), index_exp)) typ
| Lindex (root_exp, index_exp) -> (
match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with
| Some access_path
-> AccessPath access_path
| None
-> (* unsupported index expression: represent with a dummy variable *)
| Some access_path ->
AccessPath access_path
| None ->
(* unsupported index expression: represent with a dummy variable *)
of_sil_
(Exp.Lindex
( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0)
, index_exp )) typ )
| Lvar _ ->
match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with
| Some access_path
-> AccessPath access_path
| None
-> L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp
| Some access_path ->
AccessPath access_path
| None ->
L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp
in
of_sil_ exp typ
let is_null_literal = function Constant Cint n -> IntLit.isnull n | _ -> false

99
infer/src/IR/HilInstr.ml
Unescape View File

@ -14,10 +14,11 @@ module L = Logging
type call = Direct of Typ.Procname.t | Indirect of AccessPath.t [@@deriving compare]
let pp_call fmt = function
| Direct pname
-> Typ.Procname.pp fmt pname
| Indirect access_path
-> F.fprintf fmt "*%a" AccessPath.pp access_path
| Direct pname ->
Typ.Procname.pp fmt pname
| Indirect access_path ->
F.fprintf fmt "*%a" AccessPath.pp access_path
type t =
| Assign of AccessPath.t * HilExp.t * Location.t
@ -26,15 +27,16 @@ type t =
[@@deriving compare]
let pp fmt = function
| Assign (access_path, exp, loc)
-> F.fprintf fmt "%a := %a [%a]" AccessPath.pp access_path HilExp.pp exp Location.pp loc
| Assume (exp, _, _, loc)
-> F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc
| Call (ret_opt, call, actuals, _, loc)
-> let pp_ret fmt = Option.iter ~f:(F.fprintf fmt "%a := " AccessPath.pp_base) in
| Assign (access_path, exp, loc) ->
F.fprintf fmt "%a := %a [%a]" AccessPath.pp access_path HilExp.pp exp Location.pp loc
| Assume (exp, _, _, loc) ->
F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc
| Call (ret_opt, call, actuals, _, loc) ->
let pp_ret fmt = Option.iter ~f:(F.fprintf fmt "%a := " AccessPath.pp_base) in
let pp_actuals fmt = PrettyPrintable.pp_collection ~pp_item:HilExp.pp fmt in
F.fprintf fmt "%a%a(%a) [%a]" pp_ret ret_opt pp_call call pp_actuals actuals Location.pp loc
type translation = Instr of t | Bind of Var.t * AccessPath.t | Unbind of Var.t list | Ignore
(* convert an SIL instruction into an HIL instruction. the [f_resolve_id] function should map an SSA
@ -46,29 +48,29 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) =
let analyze_id_assignment lhs_id rhs_exp rhs_typ loc =
let rhs_hil_exp = exp_of_sil rhs_exp rhs_typ in
match HilExp.get_access_paths rhs_hil_exp with
| [rhs_access_path]
-> Bind (lhs_id, rhs_access_path)
| _
-> Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc))
| [rhs_access_path] ->
Bind (lhs_id, rhs_access_path)
| _ ->
Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc))
in
match instr with
| Load (lhs_id, rhs_exp, rhs_typ, loc)
-> analyze_id_assignment (Var.of_id lhs_id) rhs_exp rhs_typ loc
| Store (Lvar lhs_pvar, lhs_typ, rhs_exp, loc) when Pvar.is_ssa_frontend_tmp lhs_pvar
-> analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc
| Load (lhs_id, rhs_exp, rhs_typ, loc) ->
analyze_id_assignment (Var.of_id lhs_id) rhs_exp rhs_typ loc
| Store (Lvar lhs_pvar, lhs_typ, rhs_exp, loc) when Pvar.is_ssa_frontend_tmp lhs_pvar ->
analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc
| Call
( Some (ret_id, _)
, Const Cfun callee_pname
, (target_exp, _) :: (Sizeof {typ= cast_typ}, _) :: _
, loc
, _ )
when Typ.Procname.equal callee_pname BuiltinDecl.__cast
-> analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc
| Store (lhs_exp, typ, rhs_exp, loc)
-> let lhs_access_path =
when Typ.Procname.equal callee_pname BuiltinDecl.__cast ->
analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc
| Store (lhs_exp, typ, rhs_exp, loc) ->
let lhs_access_path =
match exp_of_sil lhs_exp typ with
| AccessPath ap
-> ap
| AccessPath ap ->
ap
| BinaryOperator (_, exp0, exp1) -> (
match
(* pointer arithmetic. somewhere in one of the expressions, there should be at least
@ -77,42 +79,43 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) =
SIL instead *)
HilExp.get_access_paths exp0
with
| ap :: _
-> ap
| ap :: _ ->
ap
| [] ->
match HilExp.get_access_paths exp1 with
| ap :: _
-> ap
| []
-> L.(die InternalError)
| ap :: _ ->
ap
| [] ->
L.(die InternalError)
"Invalid pointer arithmetic expression %a used as LHS" Exp.pp lhs_exp )
| _
-> L.(die InternalError) "Non-assignable LHS expression %a" Exp.pp lhs_exp
| _ ->
L.(die InternalError) "Non-assignable LHS expression %a" Exp.pp lhs_exp
in
Instr (Assign (lhs_access_path, exp_of_sil rhs_exp typ, loc))
| Call (ret_opt, call_exp, formals, loc, call_flags)
-> let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> (Var.of_id ret_id, ret_typ)) ret_opt in
| Call (ret_opt, call_exp, formals, loc, call_flags) ->
let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> (Var.of_id ret_id, ret_typ)) ret_opt in
let hil_call =
match exp_of_sil call_exp (Typ.mk Tvoid) with
| Constant Cfun procname | Closure (procname, _)
-> Direct procname
| AccessPath access_path
-> Indirect access_path
| call_exp
-> L.(die InternalError) "Unexpected call expression %a" HilExp.pp call_exp
| Constant Cfun procname | Closure (procname, _) ->
Direct procname
| AccessPath access_path ->
Indirect access_path
| call_exp ->
L.(die InternalError) "Unexpected call expression %a" HilExp.pp call_exp
in
let formals = List.map ~f:(fun (exp, typ) -> exp_of_sil exp typ) formals in
Instr (Call (hil_ret, hil_call, formals, call_flags, loc))
| Prune (exp, loc, true_branch, if_kind)
-> let hil_exp = exp_of_sil exp (Typ.mk (Tint IBool)) in
| Prune (exp, loc, true_branch, if_kind) ->
let hil_exp = exp_of_sil exp (Typ.mk (Tint IBool)) in
let branch = if true_branch then `Then else `Else in
Instr (Assume (hil_exp, branch, if_kind, loc))
| Nullify (pvar, _)
-> Unbind [Var.of_pvar pvar]
| Remove_temps (ids, _)
-> Unbind (List.map ~f:Var.of_id ids)
| Nullify (pvar, _) ->
Unbind [Var.of_pvar pvar]
| Remove_temps (ids, _) ->
Unbind (List.map ~f:Var.of_id ids)
(* ignoring for now; will translate as builtin function call if needed *)
| Abstract _
| Declare_locals _
-> (* these don't seem useful for most analyses. can translate them later if we want to *)
| Declare_locals _ ->
(* these don't seem useful for most analyses. can translate them later if we want to *)
Ignore

42
infer/src/IR/Ident.ml
Unescape View File

@ -29,16 +29,17 @@ module Name = struct
let from_string s = FromString s
let to_string = function
| Primed
-> primed
| Normal
-> normal
| Footprint
-> footprint
| Spec
-> spec
| FromString s
-> s
| Primed ->
primed
| Normal ->
normal
| Footprint ->
footprint
| Spec ->
spec
| FromString s ->
s
end
type name = Name.t [@@deriving compare]
@ -75,6 +76,7 @@ type t = {kind: kind; name: Name.t; stamp: int} [@@deriving compare]
let equal i1 i2 =
Int.equal i1.stamp i2.stamp && equal_kind i1.kind i2.kind && equal_name i1.name i2.name
(** {2 Set for identifiers} *)
module IdentSet = Caml.Set.Make (struct
type nonrec t = t
@ -149,6 +151,7 @@ module NameGenerator = struct
in
{kind; name; stamp}
(** Make sure that fresh ids after whis one will be with different stamps *)
let update_name_hash name stamp =
try
@ -156,6 +159,7 @@ module NameGenerator = struct
let new_stamp = max curr_stamp stamp in
NameHash.replace !name_map name new_stamp
with Not_found -> NameHash.add !name_map name stamp
end
(** Name used for the return variable *)
@ -167,9 +171,12 @@ let standard_name kind =
else if equal_kind kind KFootprint then Name.Footprint
else Name.Primed
(** Every identifier with a given stamp should unltimately be created using this function *)
let create_with_stamp kind name stamp =
NameGenerator.update_name_hash name stamp ; {kind; name; stamp}
NameGenerator.update_name_hash name stamp ;
{kind; name; stamp}
(** Create an identifier with default name for the given kind *)
let create kind stamp = create_with_stamp kind (standard_name kind) stamp
@ -210,15 +217,18 @@ let make_unprimed id =
else if has_kind id KNone then {id with kind= KNone}
else {id with kind= KNormal}
(** Update the name generator so that the given id's are not generated again *)
let update_name_generator ids =
let upd id = ignore (create_with_stamp id.kind id.name id.stamp) in
List.iter ~f:upd ids
(** Generate a normal identifier whose name encodes a path given as a string. *)
let create_path pathstring =
create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp
(** {2 Pretty Printing} *)
(** Convert an identifier to a string. *)
@ -230,6 +240,7 @@ let to_string id =
let suffix = "$" ^ string_of_int id.stamp in
prefix ^ base_name ^ suffix
(** Pretty print a name. *)
let pp_name f name = F.fprintf f "%s" (name_to_string name)
@ -239,10 +250,10 @@ let pp_name_latex style f (name: name) = Latex.pp_string style f (name_to_string
(** Pretty print an identifier. *)
let pp pe f id =
match pe.Pp.kind with
| TEXT | HTML
-> F.fprintf f "%s" (to_string id)
| LATEX
-> let base_name = name_to_string id.name in
| TEXT | HTML ->
F.fprintf f "%s" (to_string id)
| LATEX ->
let base_name = name_to_string id.name in
let style =
if has_kind id KFootprint then Latex.Boldface
else if has_kind id KNormal then Latex.Roman
@ -250,6 +261,7 @@ let pp pe f id =
in
F.fprintf f "%a_{%s}" (Latex.pp_string style) base_name (string_of_int id.stamp)
(** pretty printer for lists of identifiers *)
let pp_list pe = Pp.comma_seq (pp pe)

36
infer/src/IR/IntLit.ml
Unescape View File

@ -21,24 +21,28 @@ exception OversizedShift
let area u i =
match (i < 0L, u) with
| true, false
-> (* only representable as signed *) 1
| false, _
-> (* in the intersection between signed and unsigned *) 2
| true, true
-> (* only representable as unsigned *) 3
| true, false ->
(* only representable as signed *) 1
| false, _ ->
(* in the intersection between signed and unsigned *) 2
| true, true ->
(* only representable as unsigned *) 3
let to_signed (unsigned, i, ptr) =
if Int.equal (area unsigned i) 3 then None
else (* not representable as signed *) Some (false, i, ptr)
let compare (unsigned1, i1, _) (unsigned2, i2, _) =
let n = Bool.compare unsigned1 unsigned2 in
if n <> 0 then n else Int64.compare i1 i2
let compare_value (unsigned1, i1, _) (unsigned2, i2, _) =
[%compare : int * Int64.t] (area unsigned1 i1, i1) (area unsigned2 i2, i2)
let eq i1 i2 = Int.equal (compare_value i1 i2) 0
let neq i1 i2 = compare_value i1 i2 <> 0
@ -86,6 +90,7 @@ let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr)
let lift binop (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) =
(unsigned1 || unsigned2, binop i1 i2, ptr1 || ptr2)
let lift1 unop (unsigned, i, ptr) = (unsigned, unop i, ptr)
let add i1 i2 = lift Int64.( + ) i1 i2
@ -108,25 +113,28 @@ let sub i1 i2 = add i1 (neg i2)
let shift_left (unsigned1, i1, ptr1) (_, i2, _) =
match Int64.to_int i2 with
| None
-> L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2
| Some i2
-> if i2 < 0 || i2 >= 64 then raise OversizedShift ;
| None ->
L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2
| Some i2 ->
if i2 < 0 || i2 >= 64 then raise OversizedShift ;
let res = Int64.shift_left i1 i2 in
(unsigned1, res, ptr1)
let shift_right (unsigned1, i1, ptr1) (_, i2, _) =
match Int64.to_int i2 with
| None
-> L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2
| Some i2
-> if i2 < 0 || i2 >= 64 then raise OversizedShift ;
| None ->
L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2
| Some i2 ->
if i2 < 0 || i2 >= 64 then raise OversizedShift ;
let res = Int64.shift_right i1 i2 in
(unsigned1, res, ptr1)
let pp f (unsigned, n, ptr) =
if ptr && Int64.equal n 0L then F.fprintf f "null"
else if unsigned then F.fprintf f "%Lu" n
else F.fprintf f "%Ld" n
let to_string i = F.asprintf "%a" pp i

55
infer/src/IR/Io_infer.ml
Unescape View File

@ -20,10 +20,10 @@ module Html = struct
let create pk path =
let fname, dir_path =
match List.rev path with
| fname :: path_rev
-> (fname, List.rev ((fname ^ ".html") :: path_rev))
| []
-> raise (Failure "Html.create")
| fname :: path_rev ->
(fname, List.rev ((fname ^ ".html") :: path_rev))
| [] ->
raise (Failure "Html.create")
in
let fd = DB.Results_dir.create_file pk dir_path in
let outc = Unix.out_channel_of_descr fd in
@ -84,22 +84,25 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
in
F.fprintf fmt "%s" s ; (fd, fmt)
(** Get the full html filename from a path *)
let get_full_fname source path =
let dir_path =
match List.rev path with
| fname :: path_rev
-> List.rev ((fname ^ ".html") :: path_rev)
| []
-> raise (Failure "Html.open_out")
| fname :: path_rev ->
List.rev ((fname ^ ".html") :: path_rev)
| [] ->
raise (Failure "Html.open_out")
in
DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) dir_path
(** Open an Html file to append data *)
let open_out source path =
let full_fname = get_full_fname source path in
let fd =
Unix.openfile (DB.filename_to_string full_fname)
Unix.openfile
(DB.filename_to_string full_fname)
~mode:Unix.([O_WRONLY; O_APPEND])
~perm:0o777
in
@ -107,14 +110,19 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
let fmt = F.formatter_of_out_channel outc in
(fd, fmt)
(** Return true if the html file was modified since the beginning of the analysis *)
let modified_during_analysis source path =
let fname = get_full_fname source path in
if DB.file_exists fname then DB.file_modified_time fname >= Config.initial_analysis_time
else false
(** Close an Html file *)
let close (fd, fmt) = F.fprintf fmt "</body>@\n</html>@." ; Unix.close fd
let close (fd, fmt) =
F.fprintf fmt "</body>@\n</html>@." ;
Unix.close fd
(** Print a horizontal line *)
let pp_hline fmt () = F.fprintf fmt "<hr width=\"100%%\">@\n"
@ -136,6 +144,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
let pr_str = "<a " ^ name_str ^ "href=\"" ^ link_str ^ "\">" ^ text ^ "</a>" in
F.fprintf fmt " %s" pr_str
(** File name for the node, given the procedure name and node id *)
let node_filename pname id = Typ.Procname.to_filename pname ^ "_node" ^ string_of_int id
@ -161,10 +170,12 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
in
pp_link ~path:(path_to_root @ ["nodes"; node_fname]) fmt node_text
(** Print an html link to the given proc *)
let pp_proc_link path_to_root proc_name fmt text =
pp_link ~path:(path_to_root @ [Typ.Procname.to_filename proc_name]) fmt text
(** Print an html link to the given line number of the current source file *)
let pp_line_link ?(with_name= false) ?(text= None) source path_to_root fmt linenum =
let fname = DB.source_file_encoding source in
@ -177,6 +188,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
fmt
(match text with Some s -> s | None -> linenum_str)
(** Print an html link given node id and session *)
let pp_session_link ?(with_name= false) ?proc_name source path_to_root fmt
(node_id, session, linenum) =
@ -191,6 +203,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
~pos:(Some pos) ~path:path_to_node fmt
(node_name ^ "#" ^ pos) ;
F.fprintf fmt "(%a)" (pp_line_link source path_to_root) linenum
end
(* =============== END of module Html =============== *)
@ -294,22 +307,23 @@ module Xml = struct
(** print an xml node *)
let rec pp_node newline indent fmt = function
| Tree {name; attributes; forest}
-> let indent' = if String.equal newline "" then "" else indent ^ " " in
| Tree {name; attributes; forest} ->
let indent' = if String.equal newline "" then "" else indent ^ " " in
let space = if List.is_empty attributes then "" else " " in
let pp_inside fmt () =
match forest with
| []
-> ()
| [(String s)]
-> pp fmt "%s" s
| _
-> pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent
| [] ->
()
| [(String s)] ->
pp fmt "%s" s
| _ ->
pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent
in
pp fmt "%s<%s%s%a>%a</%s>%s" indent name space pp_attributes attributes pp_inside () name
newline
| String s
-> F.fprintf fmt "%s%s%s" indent s newline
| String s ->
F.fprintf fmt "%s%s%s" indent s newline
and pp_forest newline indent fmt forest = List.iter ~f:(pp_node newline indent fmt) forest
@ -327,6 +341,7 @@ module Xml = struct
if on_several_lines then pp_prelude fmt ;
pp_node newline "" fmt node ;
if on_several_lines then pp fmt "@."
end
(* =============== END of module Xml =============== *)

28
infer/src/IR/LintIssues.ml
Unescape View File

@ -22,13 +22,16 @@ let get_err_log procname =
errLogMap := Typ.Procname.Map.add procname errlog !errLogMap ;
errlog
let lint_issues_serializer : Errlog.t Typ.Procname.Map.t Serialization.serializer =
Serialization.create_serializer Serialization.Key.lint_issues
(** Save issues to a file *)
let store_issues filename errLogMap =
Serialization.write_to_file lint_issues_serializer filename ~data:errLogMap
(** Load issues from the given file *)
let load_issues issues_file = Serialization.read_from_file lint_issues_serializer issues_file
@ -42,21 +45,22 @@ let load_issues_to_errlog_map dir =
let load_issues_to_map issues_file =
let file = DB.filename_from_string (Filename.concat issues_dir issues_file) in
match load_issues file with
| Some map
-> errLogMap
| Some map ->
errLogMap
:= Typ.Procname.Map.merge
(fun _ issues1 issues2 ->
match (issues1, issues2) with
| Some issues1, Some issues2
-> Errlog.update issues1 issues2 ; Some issues1
| Some issues1, None
-> Some issues1
| None, Some issues2
-> Some issues2
| None, None
-> None)
| Some issues1, Some issues2 ->
Errlog.update issues1 issues2 ; Some issues1
| Some issues1, None ->
Some issues1
| None, Some issues2 ->
Some issues2
| None, None ->
None)
!errLogMap map
| None
-> ()
| None ->
()
in
match children_opt with Some children -> Array.iter ~f:load_issues_to_map children | None -> ()

383
infer/src/IR/Localise.ml
Unescape View File

@ -100,11 +100,13 @@ module Tags = struct
let get tags tag = List.Assoc.find ~equal:String.equal tags tag
let tag_value_records_of_tags tags =
List.map ~f:(fun (tag, value) -> {Jsonbug_t.tag= tag; value}) tags
List.map ~f:(fun (tag, value) -> {Jsonbug_t.tag; value}) tags
let tags_of_tag_value_records (tag_value_records: Jsonbug_t.tag_value_record list) =
List.map ~f:(fun {Jsonbug_t.tag; value} -> (tag, value)) tag_value_records
let lines_of_tags (tags: t) =
let line_tags =
String.Set.of_list
@ -114,6 +116,7 @@ module Tags = struct
~f:(fun (tag, value) ->
if String.Set.mem line_tags tag then Some (int_of_string value) else None)
tags
end
type error_desc =
@ -131,15 +134,18 @@ let custom_desc s tags = {no_desc with descriptions= [s]; tags}
let custom_desc_with_advice description advice tags =
{no_desc with descriptions= [description]; advice= Some advice; tags}
(** pretty print an error description *)
let pp_error_desc fmt err_desc =
let pp_item fmt s = F.fprintf fmt "%s" s in
Pp.seq pp_item fmt err_desc.descriptions
(** pretty print an error advice *)
let pp_error_advice fmt err_desc =
match err_desc.advice with Some advice -> F.fprintf fmt "%s" advice | None -> ()
(** get tags of error description *)
let error_desc_get_tags err_desc = err_desc.tags
@ -165,6 +171,7 @@ let error_desc_extract_tag_value err_desc tag_to_extract =
let find_value tag v = match v with t, _ when String.equal t tag -> true | _ -> false in
match List.find ~f:(find_value tag_to_extract) err_desc.tags with Some (_, s) -> s | None -> ""
let error_desc_to_tag_value_pairs err_desc = err_desc.tags
(** returns the content of the value tag of the error_desc *)
@ -174,6 +181,7 @@ let error_desc_get_tag_value error_desc = error_desc_extract_tag_value error_des
let error_desc_get_tag_call_procedure error_desc =
error_desc_extract_tag_value error_desc Tags.call_procedure
(** get the bucket value of an error_desc, if any *)
let error_desc_get_bucket err_desc = Tags.get err_desc.tags Tags.bucket
@ -186,6 +194,7 @@ let error_desc_set_bucket err_desc bucket =
in
{err_desc with descriptions; tags}
(** get the value tag, if any *)
let get_value_line_tag tags =
try
@ -194,10 +203,12 @@ let get_value_line_tag tags =
Some [value; line]
with Not_found -> None
(** extract from desc a value on which to apply polymorphic hash and equality *)
let desc_get_comparable err_desc =
match get_value_line_tag err_desc.tags with Some sl' -> sl' | None -> err_desc.descriptions
(** hash function for error_desc *)
let error_desc_hash desc = Hashtbl.hash (desc_get_comparable desc)
@ -205,6 +216,7 @@ let error_desc_hash desc = Hashtbl.hash (desc_get_comparable desc)
let error_desc_equal desc1 desc2 =
[%compare.equal : string list] (desc_get_comparable desc1) (desc_get_comparable desc2)
let _line_tag tags tag loc =
let line_str = string_of_int loc.Location.line in
Tags.update tags tag line_str ;
@ -214,6 +226,7 @@ let _line_tag tags tag loc =
s ^ ", column " ^ col_str
else s
let at_line_tag tags tag loc = "at " ^ _line_tag tags tag loc
let _line tags loc = _line_tag tags Tags.line loc
@ -225,39 +238,45 @@ let call_to tags proc_name =
Tags.update tags Tags.call_procedure proc_name_str ;
"call to " ^ MF.monospaced_to_string proc_name_str
let call_to_at_line tags proc_name loc =
call_to tags proc_name ^ " " ^ at_line_tag tags Tags.call_line loc
let by_call_to tags proc_name = "by " ^ call_to tags proc_name
let by_call_to_ra tags ra = "by " ^ call_to_at_line tags ra.PredSymb.ra_pname ra.PredSymb.ra_loc
let add_by_call_to_opt problem_str tags proc_name_opt =
match proc_name_opt with
| Some proc_name
-> problem_str ^ " " ^ by_call_to tags proc_name
| None
-> problem_str
| Some proc_name ->
problem_str ^ " " ^ by_call_to tags proc_name
| None ->
problem_str
let rec format_typ typ =
match typ.Typ.desc with
| Typ.Tptr (t, _) when Config.curr_language_is Config.Java
-> format_typ t
| Typ.Tstruct name
-> Typ.Name.name name
| _
-> Typ.to_string typ
| Typ.Tptr (t, _) when Config.curr_language_is Config.Java ->
format_typ t
| Typ.Tstruct name ->
Typ.Name.name name
| _ ->
Typ.to_string typ
let format_field f =
if Config.curr_language_is Config.Java then Typ.Fieldname.java_get_field f
else Typ.Fieldname.to_string f
let format_method pname =
match pname with
| Typ.Procname.Java pname_java
-> Typ.Procname.java_get_method pname_java
| _
-> Typ.Procname.to_string pname
| Typ.Procname.Java pname_java ->
Typ.Procname.java_get_method pname_java
| _ ->
Typ.Procname.to_string pname
let mem_dyn_allocated = "memory dynamically allocated"
@ -280,15 +299,18 @@ let _deref_str_null proc_name_opt _problem_str tags =
let problem_str = add_by_call_to_opt _problem_str tags proc_name_opt in
{tags; value_pre= Some (pointer_or_object ()); value_post= None; problem_str}
(** dereference strings for null dereference *)
let deref_str_null proc_name_opt =
let problem_str = "could be null and is dereferenced" in
_deref_str_null proc_name_opt problem_str (Tags.create ())
let access_str_empty proc_name_opt =
let problem_str = "could be empty and is accessed" in
_deref_str_null proc_name_opt problem_str (Tags.create ())
(** dereference strings for null dereference due to Nullable annotation *)
let deref_str_nullable proc_name_opt nullable_obj_str =
let tags = Tags.create () in
@ -297,6 +319,7 @@ let deref_str_nullable proc_name_opt nullable_obj_str =
let problem_str = "" in
_deref_str_null proc_name_opt problem_str tags
(** dereference strings for null dereference due to weak captured variable in block *)
let deref_str_weak_variable_in_block proc_name_opt nullable_obj_str =
let tags = Tags.create () in
@ -304,6 +327,7 @@ let deref_str_weak_variable_in_block proc_name_opt nullable_obj_str =
let problem_str = "" in
_deref_str_null proc_name_opt problem_str tags
(** dereference strings for nonterminal nil arguments in c/objc variadic methods *)
let deref_str_nil_argument_in_variadic_method pn total_args arg_number =
let tags = Tags.create () in
@ -313,11 +337,13 @@ let deref_str_nil_argument_in_variadic_method pn total_args arg_number =
let problem_str =
Printf.sprintf
"could be %s which results in a call to %s with %d arguments instead of %d (%s indicates that the last argument of this variadic %s has been reached)"
nil_null (Typ.Procname.to_simplified_string pn) arg_number (total_args - 1) nil_null
function_method
nil_null
(Typ.Procname.to_simplified_string pn)
arg_number (total_args - 1) nil_null function_method
in
_deref_str_null None problem_str tags
(** dereference strings for an undefined value coming from the given procedure *)
let deref_str_undef (proc_name, loc) =
let tags = Tags.create () in
@ -330,20 +356,21 @@ let deref_str_undef (proc_name, loc) =
"could be assigned by a call to skip function " ^ proc_name_str
^ at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed" }
(** dereference strings for a freed pointer dereference *)
let deref_str_freed ra =
let tags = Tags.create () in
let freed_or_closed_by_call =
let freed_or_closed =
match ra.PredSymb.ra_res with
| PredSymb.Rmemory _
-> "freed"
| PredSymb.Rfile
-> "closed"
| PredSymb.Rignore
-> "freed"
| PredSymb.Rlock
-> "locked"
| PredSymb.Rmemory _ ->
"freed"
| PredSymb.Rfile ->
"closed"
| PredSymb.Rignore ->
"freed"
| PredSymb.Rlock ->
"locked"
in
freed_or_closed ^ " " ^ by_call_to_ra tags ra
in
@ -352,24 +379,26 @@ let deref_str_freed ra =
; value_post= None
; problem_str= "was " ^ freed_or_closed_by_call ^ " and is dereferenced or freed" }
(** dereference strings for a dangling pointer dereference *)
let deref_str_dangling dangling_kind_opt =
let dangling_kind_prefix =
match dangling_kind_opt with
| Some PredSymb.DAuninit
-> "uninitialized "
| Some PredSymb.DAaddr_stack_var
-> "deallocated stack "
| Some PredSymb.DAminusone
-> "-1 "
| None
-> ""
| Some PredSymb.DAuninit ->
"uninitialized "
| Some PredSymb.DAaddr_stack_var ->
"deallocated stack "
| Some PredSymb.DAminusone ->
"-1 "
| None ->
""
in
{ tags= Tags.create ()
; value_pre= Some (dangling_kind_prefix ^ pointer_or_object ())
; value_post= None
; problem_str= "could be dangling and is dereferenced or freed" }
(** dereference strings for a pointer size mismatch *)
let deref_str_pointer_size_mismatch typ_from_instr typ_of_object =
let str_from_typ typ =
@ -382,52 +411,58 @@ let deref_str_pointer_size_mismatch typ_from_instr typ_of_object =
; problem_str= "could be used to access an object of smaller type " ^ str_from_typ typ_of_object
}
(** dereference strings for an array out of bound access *)
let deref_str_array_bound size_opt index_opt =
let tags = Tags.create () in
let size_str_opt =
match size_opt with
| Some n
-> let n_str = IntLit.to_string n in
Tags.update tags Tags.array_size n_str ; Some ("of size " ^ n_str)
| None
-> None
| Some n ->
let n_str = IntLit.to_string n in
Tags.update tags Tags.array_size n_str ;
Some ("of size " ^ n_str)
| None ->
None
in
let index_str =
match index_opt with
| Some n
-> let n_str = IntLit.to_string n in
Tags.update tags Tags.array_index n_str ; "index " ^ n_str
| None
-> "an index"
| Some n ->
let n_str = IntLit.to_string n in
Tags.update tags Tags.array_index n_str ;
"index " ^ n_str
| None ->
"an index"
in
{ tags
; value_pre= Some "array"
; value_post= size_str_opt
; problem_str= "could be accessed with " ^ index_str ^ " out of bounds" }
(** dereference strings for an uninitialized access whose lhs has the given attribute *)
let deref_str_uninitialized alloc_att_opt =
let tags = Tags.create () in
let creation_str =
match alloc_att_opt with
| Some Sil.Apred (Aresource ({ra_kind= Racquire} as ra), _)
-> "after allocation " ^ by_call_to_ra tags ra
| _
-> "after declaration"
| Some Sil.Apred (Aresource ({ra_kind= Racquire} as ra), _) ->
"after allocation " ^ by_call_to_ra tags ra
| _ ->
"after declaration"
in
{ tags
; value_pre= Some "value"
; value_post= None
; problem_str= "was not initialized " ^ creation_str ^ " and is used" }
(** Java unchecked exceptions errors *)
let java_unchecked_exn_desc proc_name exn_name pre_str : error_desc =
{ no_desc with
descriptions=
[ MF.monospaced_to_string (Typ.Procname.to_string proc_name)
; ("can throw " ^ MF.monospaced_to_string (Typ.Name.name exn_name))
; ("whenever " ^ pre_str) ] }
; "can throw " ^ MF.monospaced_to_string (Typ.Name.name exn_name)
; "whenever " ^ pre_str ] }
let desc_context_leak pname context_typ fieldname leak_path : error_desc =
let fld_str = Typ.Fieldname.to_string fieldname in
@ -435,10 +470,10 @@ let desc_context_leak pname context_typ fieldname leak_path : error_desc =
let leak_path_entry_to_str acc entry =
let entry_str =
match entry with
| Some fld, _
-> Typ.Fieldname.to_string fld
| None, typ
-> Typ.to_string typ
| Some fld, _ ->
Typ.Fieldname.to_string fld
| None, typ ->
Typ.to_string typ
in
(* intentionally omit space; [typ_to_string] adds an extra space *)
acc ^ entry_str ^ " |->\n"
@ -454,16 +489,18 @@ let desc_context_leak pname context_typ fieldname leak_path : error_desc =
let preamble =
let pname_str =
match pname with
| Typ.Procname.Java pname_java
-> MF.monospaced_to_string
(Printf.sprintf "%s.%s" (Typ.Procname.java_get_class_name pname_java)
| Typ.Procname.Java pname_java ->
MF.monospaced_to_string
(Printf.sprintf "%s.%s"
(Typ.Procname.java_get_class_name pname_java)
(Typ.Procname.java_get_method pname_java))
| _
-> ""
| _ ->
""
in
"Context " ^ context_str ^ " may leak during method " ^ pname_str ^ ":\n"
in
{no_desc with descriptions= [(preamble ^ MF.code_to_string (leak_root ^ path_str))]}
{no_desc with descriptions= [preamble ^ MF.code_to_string (leak_root ^ path_str)]}
let desc_double_lock pname_opt object_str loc =
let mutex_str = Format.sprintf "Mutex %s" object_str in
@ -474,6 +511,7 @@ let desc_double_lock pname_opt object_str loc =
let descriptions = [mutex_str; msg; at_line tags loc] in
{no_desc with descriptions; tags= !tags}
let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc =
let line_info = at_line (Tags.create ()) loc in
let accessed_fld_str = Typ.Fieldname.to_string accessed_fld in
@ -489,6 +527,7 @@ let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc =
in
{no_desc with descriptions= [msg]}
let desc_fragment_retains_view fragment_typ fieldname fld_typ pname : error_desc =
(* TODO: try advice *)
let problem =
@ -503,9 +542,11 @@ let desc_fragment_retains_view fragment_typ fieldname fld_typ pname : error_desc
in
{no_desc with descriptions= [problem; consequences; advice]}
let desc_custom_error loc : error_desc =
{no_desc with descriptions= ["detected"; at_line (Tags.create ()) loc]}
(** type of access *)
type access =
| Last_assigned of int * bool
@ -517,12 +558,13 @@ type access =
let nullable_annotation_name proc_name =
match Config.nullable_annotation with
| Some name
-> name
| None when Typ.Procname.is_java proc_name
-> "@Nullable"
| None (* default Clang annotation name *)
-> "_Nullable"
| Some name ->
name
| None when Typ.Procname.is_java proc_name ->
"@Nullable"
| None (* default Clang annotation name *) ->
"_Nullable"
let dereference_string proc_name deref_str value_str access_opt loc =
let tags = deref_str.tags in
@ -537,40 +579,43 @@ let dereference_string proc_name deref_str value_str access_opt loc =
in
let access_desc =
match access_opt with
| None
-> []
| Some Last_accessed (n, _)
-> let line_str = string_of_int n in
Tags.update tags Tags.accessed_line line_str ; [("last accessed on line " ^ line_str)]
| Some Last_assigned (n, _)
-> let line_str = string_of_int n in
Tags.update tags Tags.assigned_line line_str ; [("last assigned on line " ^ line_str)]
| Some Returned_from_call _
-> []
| Some Initialized_automatically
-> ["initialized automatically"]
| None ->
[]
| Some Last_accessed (n, _) ->
let line_str = string_of_int n in
Tags.update tags Tags.accessed_line line_str ;
["last accessed on line " ^ line_str]
| Some Last_assigned (n, _) ->
let line_str = string_of_int n in
Tags.update tags Tags.assigned_line line_str ;
["last assigned on line " ^ line_str]
| Some Returned_from_call _ ->
[]
| Some Initialized_automatically ->
["initialized automatically"]
in
let problem_desc =
let problem_str =
let annotation_name = nullable_annotation_name proc_name in
match (Tags.get !tags Tags.nullable_src, Tags.get !tags Tags.weak_captured_var_src) with
| Some nullable_src, _
-> if String.equal nullable_src value_str then "is annotated with " ^ annotation_name
| Some nullable_src, _ ->
if String.equal nullable_src value_str then "is annotated with " ^ annotation_name
^ " and is dereferenced without a null check"
else "is indirectly marked " ^ annotation_name ^ " (source: "
^ MF.monospaced_to_string nullable_src ^ ") and is dereferenced without a null check"
| None, Some weak_var_str
-> if String.equal weak_var_str value_str then
| None, Some weak_var_str ->
if String.equal weak_var_str value_str then
"is a weak pointer captured in the block and is dereferenced without a null check"
else "is equal to the variable " ^ MF.monospaced_to_string weak_var_str
^ ", a weak pointer captured in the block, and is dereferenced without a null check"
| None, None
-> deref_str.problem_str
| None, None ->
deref_str.problem_str
in
[(problem_str ^ " " ^ at_line tags loc)]
[problem_str ^ " " ^ at_line tags loc]
in
{no_desc with descriptions= value_desc :: access_desc @ problem_desc; tags= !tags}
let parameter_field_not_null_checked_desc (desc: error_desc) exp =
let parameter_not_nullable_desc var =
let var_s = Pvar.to_string var in
@ -585,12 +630,12 @@ let parameter_field_not_null_checked_desc (desc: error_desc) exp =
let field_not_nullable_desc exp =
let rec exp_to_string exp =
match exp with
| Exp.Lfield (exp', field, _)
-> exp_to_string exp' ^ " -> " ^ Typ.Fieldname.to_string field
| Exp.Lvar pvar
-> Mangled.to_string (Pvar.get_name pvar)
| _
-> ""
| Exp.Lfield (exp', field, _) ->
exp_to_string exp' ^ " -> " ^ Typ.Fieldname.to_string field
| Exp.Lvar pvar ->
Mangled.to_string (Pvar.get_name pvar)
| _ ->
""
in
let var_s = exp_to_string exp in
let field_not_null_desc =
@ -602,16 +647,18 @@ let parameter_field_not_null_checked_desc (desc: error_desc) exp =
; tags= (Tags.field_not_null_checked, var_s) :: desc.tags }
in
match exp with
| Exp.Lvar var
-> parameter_not_nullable_desc var
| Exp.Lfield _
-> field_not_nullable_desc exp
| _
-> desc
| Exp.Lvar var ->
parameter_not_nullable_desc var
| Exp.Lfield _ ->
field_not_nullable_desc exp
| _ ->
desc
let has_tag (desc: error_desc) tag =
List.exists ~f:(fun (tag', _) -> String.equal tag tag') desc.tags
let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked
let is_field_not_null_checked_desc desc = has_tag desc Tags.field_not_null_checked
@ -619,6 +666,7 @@ let is_field_not_null_checked_desc desc = has_tag desc Tags.field_not_null_check
let is_parameter_field_not_null_checked_desc desc =
is_parameter_not_null_checked_desc desc || is_field_not_null_checked_desc desc
let is_double_lock_desc desc = has_tag desc Tags.double_lock
let desc_allocation_mismatch alloc dealloc =
@ -645,9 +693,11 @@ let desc_allocation_mismatch alloc dealloc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_comparing_floats_for_equality loc =
let tags = Tags.create () in
{no_desc with descriptions= [("Comparing floats for equality " ^ at_line tags loc)]; tags= !tags}
{no_desc with descriptions= ["Comparing floats for equality " ^ at_line tags loc]; tags= !tags}
let desc_condition_always_true_false i cond_str_opt loc =
let tags = Tags.create () in
@ -661,11 +711,13 @@ let desc_condition_always_true_false i cond_str_opt loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_unreachable_code_after loc =
let tags = Tags.create () in
let description = "Unreachable code after statement " ^ at_line tags loc in
{no_desc with descriptions= [description]}
let desc_deallocate_stack_variable var_str proc_name loc =
let tags = Tags.create () in
Tags.update tags Tags.value var_str ;
@ -675,6 +727,7 @@ let desc_deallocate_stack_variable var_str proc_name loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_deallocate_static_memory const_str proc_name loc =
let tags = Tags.create () in
Tags.update tags Tags.value const_str ;
@ -684,24 +737,25 @@ let desc_deallocate_static_memory const_str proc_name loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_class_cast_exception pname_opt typ_str1 typ_str2 exp_str_opt loc =
let tags = Tags.create () in
Tags.update tags Tags.type1 typ_str1 ;
Tags.update tags Tags.type2 typ_str2 ;
let in_expression =
match exp_str_opt with
| Some exp_str
-> Tags.update tags Tags.value exp_str ;
| Some exp_str ->
Tags.update tags Tags.value exp_str ;
" in expression " ^ MF.monospaced_to_string exp_str ^ " "
| None
-> " "
| None ->
" "
in
let at_line' () =
match pname_opt with
| Some proc_name
-> "in " ^ call_to_at_line tags proc_name loc
| None
-> at_line tags loc
| Some proc_name ->
"in " ^ call_to_at_line tags proc_name loc
| None ->
at_line tags loc
in
let description =
Format.asprintf "%a cannot be cast to %a %s %s" MF.pp_monospaced typ_str1 MF.pp_monospaced
@ -709,6 +763,7 @@ let desc_class_cast_exception pname_opt typ_str1 typ_str2 exp_str_opt loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_divide_by_zero expr_str loc =
let tags = Tags.create () in
Tags.update tags Tags.value expr_str ;
@ -717,6 +772,7 @@ let desc_divide_by_zero expr_str loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_empty_vector_access pname_opt object_str loc =
let vector_str = Format.asprintf "Vector %a" MF.pp_monospaced object_str in
let desc = access_str_empty pname_opt in
@ -725,6 +781,7 @@ let desc_empty_vector_access pname_opt object_str loc =
let descriptions = [vector_str; desc.problem_str; at_line tags loc] in
{no_desc with descriptions; tags= !tags}
let is_empty_vector_access_desc desc = has_tag desc Tags.empty_vector_access
let desc_frontend_warning desc sugg_opt loc =
@ -736,6 +793,7 @@ let desc_frontend_warning desc sugg_opt loc =
let description = Format.sprintf "%s %s. %s" desc (at_line tags loc) sugg in
{no_desc with descriptions= [description]; tags= !tags}
let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc bucket_opt =
let tags = Tags.create () in
let () =
@ -744,28 +802,28 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
let xxx_allocated_to =
let value_str, _to, _on =
match value_str_opt with
| None
-> ("", "", "")
| Some s
-> Tags.update tags Tags.value s ; (MF.monospaced_to_string s, " to ", " on ")
| None ->
("", "", "")
| Some s ->
Tags.update tags Tags.value s ; (MF.monospaced_to_string s, " to ", " on ")
in
let typ_str =
match hpred_type_opt with
| Some Exp.Sizeof {typ= {desc= Tstruct name}} when Typ.Name.is_class name
-> " of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " "
| _
-> " "
| Some Exp.Sizeof {typ= {desc= Tstruct name}} when Typ.Name.is_class name ->
" of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " "
| _ ->
" "
in
let desc_str =
match resource_opt with
| Some PredSymb.Rmemory _
-> mem_dyn_allocated ^ _to ^ value_str
| Some PredSymb.Rfile
-> "resource" ^ typ_str ^ "acquired" ^ _to ^ value_str
| Some PredSymb.Rlock
-> lock_acquired ^ _on ^ value_str
| Some PredSymb.Rignore | None
-> if is_none value_str_opt then "memory" else value_str
| Some PredSymb.Rmemory _ ->
mem_dyn_allocated ^ _to ^ value_str
| Some PredSymb.Rfile ->
"resource" ^ typ_str ^ "acquired" ^ _to ^ value_str
| Some PredSymb.Rlock ->
lock_acquired ^ _on ^ value_str
| Some PredSymb.Rignore | None ->
if is_none value_str_opt then "memory" else value_str
in
if String.equal desc_str "" then [] else [desc_str]
in
@ -775,14 +833,14 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
let is_not_rxxx_after =
let rxxx =
match resource_opt with
| Some PredSymb.Rmemory _
-> reachable
| Some PredSymb.Rfile | Some PredSymb.Rlock
-> released
| Some PredSymb.Rignore | None
-> reachable
| Some PredSymb.Rmemory _ ->
reachable
| Some PredSymb.Rfile | Some PredSymb.Rlock ->
released
| Some PredSymb.Rignore | None ->
reachable
in
[("is not " ^ rxxx ^ " after " ^ _line tags loc)]
["is not " ^ rxxx ^ " after " ^ _line tags loc]
in
let bucket_str =
match bucket_opt with Some bucket when Config.show_buckets -> bucket | _ -> ""
@ -790,6 +848,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
{ no_desc with
descriptions= bucket_str :: xxx_allocated_to @ by_call_to @ is_not_rxxx_after; tags= !tags }
let desc_buffer_overrun desc = verbatim_desc desc
(** kind of precondition not met *)
@ -799,15 +858,15 @@ let desc_precondition_not_met kind proc_name loc =
let tags = Tags.create () in
let kind_str =
match kind with
| None
-> []
| Some Pnm_bounds
-> ["possible array out of bounds"]
| Some Pnm_dangling
-> ["possible dangling pointer dereference"]
| None ->
[]
| Some Pnm_bounds ->
["possible array out of bounds"]
| Some Pnm_dangling ->
["possible dangling pointer dereference"]
in
{ no_desc with
descriptions= kind_str @ [("in " ^ call_to_at_line tags proc_name loc)]; tags= !tags }
{no_desc with descriptions= kind_str @ ["in " ^ call_to_at_line tags proc_name loc]; tags= !tags}
let desc_null_test_after_dereference expr_str line loc =
let tags = Tags.create () in
@ -819,6 +878,7 @@ let desc_null_test_after_dereference expr_str line loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_return_expression_required typ_str loc =
let tags = Tags.create () in
Tags.update tags Tags.value typ_str ;
@ -828,6 +888,7 @@ let desc_return_expression_required typ_str loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_retain_cycle cycle loc cycle_dotty =
Logging.d_strln "Proposition with retain cycle:" ;
let ct = ref 1 in
@ -838,20 +899,20 @@ let desc_retain_cycle cycle loc cycle_dotty =
in
let do_edge ((se, _), f, _) =
match se with
| Sil.Eexp (Exp.Lvar pvar, _) when Pvar.equal pvar Sil.block_pvar
-> str_cycle
| Sil.Eexp (Exp.Lvar pvar, _) when Pvar.equal pvar Sil.block_pvar ->
str_cycle
:= !str_cycle ^ " (" ^ string_of_int !ct ^ ") a block capturing "
^ MF.monospaced_to_string (Typ.Fieldname.to_string f) ^ "; " ;
ct := !ct + 1
| Sil.Eexp ((Exp.Lvar pvar as e), _)
-> let e_str = Exp.to_string e in
| Sil.Eexp ((Exp.Lvar pvar as e), _) ->
let e_str = Exp.to_string e in
let e_str = if Pvar.is_seed pvar then remove_old e_str else e_str in
str_cycle
:= !str_cycle ^ " (" ^ string_of_int !ct ^ ") object " ^ e_str ^ " retaining "
^ MF.monospaced_to_string (e_str ^ "." ^ Typ.Fieldname.to_string f) ^ ", " ;
ct := !ct + 1
| Sil.Eexp (Exp.Sizeof {typ}, _)
-> let step =
| Sil.Eexp (Exp.Sizeof {typ}, _) ->
let step =
" (" ^ string_of_int !ct ^ ") an object of "
^ MF.monospaced_to_string (Typ.to_string typ)
^ " retaining another object via instance variable "
@ -859,8 +920,8 @@ let desc_retain_cycle cycle loc cycle_dotty =
in
str_cycle := !str_cycle ^ step ;
ct := !ct + 1
| _
-> ()
| _ ->
()
in
List.iter ~f:do_edge cycle ;
let desc =
@ -869,36 +930,41 @@ let desc_retain_cycle cycle loc cycle_dotty =
in
{no_desc with descriptions= [desc]; tags= !tags; dotty= cycle_dotty}
let registered_observer_being_deallocated_str obj_str =
"Object " ^ obj_str
^ " is registered in a notification center but not being removed before deallocation"
let desc_registered_observer_being_deallocated pvar loc =
let tags = Tags.create () in
let obj_str = MF.monospaced_to_string (Pvar.to_string pvar) in
{ no_desc with
descriptions=
[ ( registered_observer_being_deallocated_str obj_str ^ at_line tags loc
[ registered_observer_being_deallocated_str obj_str ^ at_line tags loc
^ ". Being still registered as observer of the notification "
^ "center, the deallocated object " ^ obj_str ^ " may be notified in the future." ) ]
^ "center, the deallocated object " ^ obj_str ^ " may be notified in the future." ]
; tags= !tags }
let desc_return_statement_missing loc =
let tags = Tags.create () in
{no_desc with descriptions= [("Return statement missing " ^ at_line tags loc)]; tags= !tags}
{no_desc with descriptions= ["Return statement missing " ^ at_line tags loc]; tags= !tags}
let desc_return_value_ignored proc_name loc =
let tags = Tags.create () in
{no_desc with descriptions= [("after " ^ call_to_at_line tags proc_name loc)]; tags= !tags}
{no_desc with descriptions= ["after " ^ call_to_at_line tags proc_name loc]; tags= !tags}
let desc_unary_minus_applied_to_unsigned_expression expr_str_opt typ_str loc =
let tags = Tags.create () in
let expression =
match expr_str_opt with
| Some s
-> Tags.update tags Tags.value s ; "expression " ^ s
| None
-> "an expression"
| Some s ->
Tags.update tags Tags.value s ; "expression " ^ s
| None ->
"an expression"
in
let description =
Format.asprintf "A unary minus is applied to %a of type %s %s" MF.pp_monospaced expression
@ -906,29 +972,32 @@ let desc_unary_minus_applied_to_unsigned_expression expr_str_opt typ_str loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_skip_function proc_name =
let tags = Tags.create () in
let proc_name_str = Typ.Procname.to_string proc_name in
Tags.update tags Tags.value proc_name_str ;
{no_desc with descriptions= [proc_name_str]; tags= !tags}
let desc_inherently_dangerous_function proc_name =
let proc_name_str = Typ.Procname.to_string proc_name in
let tags = Tags.create () in
Tags.update tags Tags.value proc_name_str ;
{no_desc with descriptions= [MF.monospaced_to_string proc_name_str]; tags= !tags}
let desc_stack_variable_address_escape pvar addr_dexp_str loc =
let expr_str = Pvar.to_string pvar in
let tags = Tags.create () in
Tags.update tags Tags.value expr_str ;
let escape_to_str =
match addr_dexp_str with
| Some s
-> Tags.update tags Tags.escape_to s ;
| Some s ->
Tags.update tags Tags.escape_to s ;
"to " ^ s ^ " "
| None
-> ""
| None ->
""
in
let variable_str =
if Pvar.is_frontend_tmp pvar then "temporary"
@ -939,6 +1008,7 @@ let desc_stack_variable_address_escape pvar addr_dexp_str loc =
in
{no_desc with descriptions= [description]; tags= !tags}
let desc_uninitialized_dangling_pointer_deref deref expr_str loc =
let tags = Tags.create () in
Tags.update tags Tags.value expr_str ;
@ -948,3 +1018,4 @@ let desc_uninitialized_dangling_pointer_deref deref expr_str loc =
(at_line tags loc)
in
{no_desc with descriptions= [description]; tags= !tags}

3
infer/src/IR/Location.ml
Unescape View File

@ -31,12 +31,15 @@ let pp f (loc: t) =
F.fprintf f "line %d" loc.line ;
if loc.col <> -1 then F.fprintf f ", column %d" loc.col
let to_string loc =
let s = string_of_int loc.line in
if loc.col <> -1 then Printf.sprintf "%s:%d" s loc.col else s
(** Pretty print a file-position of a location *)
let pp_file_pos f (loc: t) =
let fname = SourceFile.to_string loc.file in
let pos = to_string loc in
F.fprintf f "%s:%s" fname pos

1
infer/src/IR/Mangled.ml
Unescape View File

@ -30,6 +30,7 @@ let to_string (pn: t) = pn.plain
let to_string_full (pn: t) =
match pn.mangled with Some mangled -> pn.plain ^ "{" ^ mangled ^ "}" | None -> pn.plain
(** Get mangled string if given *)
let get_mangled pn = match pn.mangled with Some s -> s | None -> pn.plain

22
infer/src/IR/Mleak_buckets.ml
Unescape View File

@ -17,16 +17,17 @@ let objc_arc_flag = "objc_arc"
let bucket_to_message bucket =
match bucket with
| `MLeak_cf
-> "[CF]"
| `MLeak_arc
-> "[ARC]"
| `MLeak_no_arc
-> "[NO ARC]"
| `MLeak_cpp
-> "[CPP]"
| `MLeak_unknown
-> "[UNKNOWN ORIGIN]"
| `MLeak_cf ->
"[CF]"
| `MLeak_arc ->
"[ARC]"
| `MLeak_no_arc ->
"[NO ARC]"
| `MLeak_cpp ->
"[CPP]"
| `MLeak_unknown ->
"[UNKNOWN ORIGIN]"
let contains_all = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_all
@ -65,6 +66,7 @@ let should_raise_objc_leak typ =
else if should_raise_leak_no_arc () then Some (bucket_to_message `MLeak_no_arc)
else None
(*
let bucket_to_string bucket =
match bucket with

34
infer/src/IR/Objc_models.ml
Unescape View File

@ -56,6 +56,7 @@ module Core_foundation_model = struct
; "__CFURLEnumerator"
; "__CFUUID" ]
let cf_network =
[ "_CFHTTPAuthentication"
; "__CFHTTPMessage"
@ -65,6 +66,7 @@ module Core_foundation_model = struct
; "__CFNetServiceMonitor"
; "__CFNetServiceBrowser" ]
let core_media =
[ "OpaqueCMBlockBuffer"
; "opaqueCMBufferQueue"
@ -76,6 +78,7 @@ module Core_foundation_model = struct
; "OpaqueCMClock"
; "OpaqueCMTimebase" ]
let core_text =
[ "__CTFont"
; "__CTFontCollection"
@ -91,9 +94,11 @@ module Core_foundation_model = struct
; "__CTTextTab"
; "__CTTypesetter" ]
let core_video =
["__CVBuffer"; "__CVMetalTextureCache"; "__CVOpenGLESTextureCache"; "__CVPixelBufferPool"]
let image_io = ["CGImageDestination"; "CGImageMetadata"; "CGImageMetadataTag"; "CGImageSource"]
let security =
@ -107,6 +112,7 @@ module Core_foundation_model = struct
; "__SecTrust"
; "__SecRequirement" ]
let system_configuration =
[ "__SCDynamicStore"
; "__SCNetworkInterface"
@ -118,6 +124,7 @@ module Core_foundation_model = struct
; "__SCNetworkReachability"
; "__SCPreferences" ]
let core_graphics_types =
[ "CGAffineTransform"
; "CGBase"
@ -149,10 +156,12 @@ module Core_foundation_model = struct
; "CGPDFString"
; "CGShading" ]
let core_foundation_types =
core_foundation @ cf_network @ core_media @ core_text @ core_video @ image_io @ security
@ system_configuration
let copy = "Copy"
let create = "Create"
@ -171,24 +180,27 @@ module Core_foundation_model = struct
let core_lib_to_type_list lib =
match lib with
| Core_foundation
-> core_foundation_types
| Core_graphics
-> core_graphics_types
| Core_foundation ->
core_foundation_types
| Core_graphics ->
core_graphics_types
let is_objc_memory_model_controlled o =
List.mem ~equal:String.equal core_foundation_types o
|| List.mem ~equal:String.equal core_graphics_types o
let rec is_core_lib lib typ =
match typ.Typ.desc with
| Typ.Tptr (styp, _)
-> is_core_lib lib styp
| Typ.Tstruct name
-> let core_lib_types = core_lib_to_type_list lib in
| Typ.Tptr (styp, _) ->
is_core_lib lib styp
| Typ.Tstruct name ->
let core_lib_types = core_lib_to_type_list lib in
List.mem ~equal:String.equal core_lib_types (Typ.Name.name name)
| _
-> false
| _ ->
false
let is_core_foundation_type typ = is_core_lib Core_foundation typ
@ -200,6 +212,7 @@ module Core_foundation_model = struct
is_core_lib_type typ
&& (String.is_substring ~substring:create funct || String.is_substring ~substring:copy funct)
let function_arg_is_cftype typ = String.is_substring ~substring:cf_type typ
let is_core_lib_retain typ funct = function_arg_is_cftype typ && String.equal funct cf_retain
@ -212,6 +225,7 @@ module Core_foundation_model = struct
in
List.exists ~f core_graphics_types
(*
let function_arg_is_core_pgraphics typ =
let res = (String.is_substring ~substring:cf_type typ) in

186
infer/src/IR/PredSymb.ml
Unescape View File

@ -26,10 +26,11 @@ let equal_access = [%compare.equal : access]
(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *)
let get_sentinel_func_attribute_value attr_list =
match attr_list with
| (FA_sentinel (sentinel, null_pos)) :: _
-> Some (sentinel, null_pos)
| []
-> None
| (FA_sentinel (sentinel, null_pos)) :: _ ->
Some (sentinel, null_pos)
| [] ->
None
type mem_kind =
| Mmalloc (** memory allocated with malloc *)
@ -72,6 +73,7 @@ type res_action =
let compare_res_action {ra_kind= k1; ra_res= r1} {ra_kind= k2; ra_res= r2} =
[%compare : res_act_kind * resource] (k1, r1) (k2, r2)
(* type aliases for components of t values that compare should ignore *)
type _annot_item = Annot.Item.t
@ -115,25 +117,27 @@ let equal = [%compare.equal : t]
(** name of the allocation function for the given memory kind *)
let mem_alloc_pname = function
| Mmalloc
-> Typ.Procname.from_string_c_fun "malloc"
| Mnew
-> Typ.Procname.from_string_c_fun "new"
| Mnew_array
-> Typ.Procname.from_string_c_fun "new[]"
| Mobjc
-> Typ.Procname.from_string_c_fun "alloc"
| Mmalloc ->
Typ.Procname.from_string_c_fun "malloc"
| Mnew ->
Typ.Procname.from_string_c_fun "new"
| Mnew_array ->
Typ.Procname.from_string_c_fun "new[]"
| Mobjc ->
Typ.Procname.from_string_c_fun "alloc"
(** name of the deallocation function for the given memory kind *)
let mem_dealloc_pname = function
| Mmalloc
-> Typ.Procname.from_string_c_fun "free"
| Mnew
-> Typ.Procname.from_string_c_fun "delete"
| Mnew_array
-> Typ.Procname.from_string_c_fun "delete[]"
| Mobjc
-> Typ.Procname.from_string_c_fun "dealloc"
| Mmalloc ->
Typ.Procname.from_string_c_fun "free"
| Mnew ->
Typ.Procname.from_string_c_fun "delete"
| Mnew_array ->
Typ.Procname.from_string_c_fun "delete[]"
| Mobjc ->
Typ.Procname.from_string_c_fun "dealloc"
(** Categories of attributes *)
type category =
@ -152,24 +156,25 @@ let equal_category = [%compare.equal : category]
let to_category att =
match att with
| Aresource _ | Adangling _
-> ACresource
| Alocked | Aunlocked
-> AClock
| Aautorelease
-> ACautorelease
| Adiv0 _
-> ACdiv0
| Aobjc_null
-> ACobjc_null
| Aretval _
-> ACretval
| Aundef _
-> ACundef
| Aobserver | Aunsubscribed_observer
-> ACobserver
| Awont_leak
-> ACwontleak
| Aresource _ | Adangling _ ->
ACresource
| Alocked | Aunlocked ->
AClock
| Aautorelease ->
ACautorelease
| Adiv0 _ ->
ACdiv0
| Aobjc_null ->
ACobjc_null
| Aretval _ ->
ACretval
| Aundef _ ->
ACundef
| Aobserver | Aunsubscribed_observer ->
ACobserver
| Awont_leak ->
ACwontleak
let is_undef = function Aundef _ -> true | _ -> false
@ -177,71 +182,72 @@ let is_wont_leak = function Awont_leak -> true | _ -> false
(** convert the attribute to a string *)
let to_string pe = function
| Aresource ra
-> let mk_name = function
| Mmalloc
-> "ma"
| Mnew
-> "ne"
| Mnew_array
-> "na"
| Mobjc
-> "oc"
| Aresource ra ->
let mk_name = function
| Mmalloc ->
"ma"
| Mnew ->
"ne"
| Mnew_array ->
"na"
| Mobjc ->
"oc"
in
let name =
match (ra.ra_kind, ra.ra_res) with
| Racquire, Rmemory mk
-> "MEM" ^ mk_name mk
| Racquire, Rfile
-> "FILE"
| Rrelease, Rmemory mk
-> "FREED" ^ mk_name mk
| Rrelease, Rfile
-> "CLOSED"
| _, Rignore
-> "IGNORE"
| Racquire, Rlock
-> "LOCKED"
| Rrelease, Rlock
-> "UNLOCKED"
| Racquire, Rmemory mk ->
"MEM" ^ mk_name mk
| Racquire, Rfile ->
"FILE"
| Rrelease, Rmemory mk ->
"FREED" ^ mk_name mk
| Rrelease, Rfile ->
"CLOSED"
| _, Rignore ->
"IGNORE"
| Racquire, Rlock ->
"LOCKED"
| Rrelease, Rlock ->
"UNLOCKED"
in
let str_vpath =
if Config.trace_error then F.asprintf "%a" (DecompiledExp.pp_vpath pe) ra.ra_vpath else ""
in
name ^ Binop.str pe Lt ^ Typ.Procname.to_string ra.ra_pname ^ ":"
^ string_of_int ra.ra_loc.Location.line ^ Binop.str pe Gt ^ str_vpath
| Aautorelease
-> "AUTORELEASE"
| Adangling dk
-> let dks =
| Aautorelease ->
"AUTORELEASE"
| Adangling dk ->
let dks =
match dk with
| DAuninit
-> "UNINIT"
| DAaddr_stack_var
-> "ADDR_STACK"
| DAminusone
-> "MINUS1"
| DAuninit ->
"UNINIT"
| DAaddr_stack_var ->
"ADDR_STACK"
| DAminusone ->
"MINUS1"
in
"DANGL" ^ Binop.str pe Lt ^ dks ^ Binop.str pe Gt
| Aundef (pn, _, loc, _)
-> "UND" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":"
| Aundef (pn, _, loc, _) ->
"UND" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":"
^ string_of_int loc.Location.line
| Alocked
-> "LOCKED"
| Aunlocked
-> "UNLOCKED"
| Adiv0 (_, _)
-> "DIV0"
| Aobjc_null
-> "OBJC_NULL"
| Aretval (pn, _)
-> "RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt
| Aobserver
-> "OBSERVER"
| Aunsubscribed_observer
-> "UNSUBSCRIBED_OBSERVER"
| Awont_leak
-> "WONT_LEAK"
| Alocked ->
"LOCKED"
| Aunlocked ->
"UNLOCKED"
| Adiv0 (_, _) ->
"DIV0"
| Aobjc_null ->
"OBJC_NULL"
| Aretval (pn, _) ->
"RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt
| Aobserver ->
"OBSERVER"
| Aunsubscribed_observer ->
"UNSUBSCRIBED_OBSERVER"
| Awont_leak ->
"WONT_LEAK"
(** dump an attribute *)
let d_attribute (a: t) = L.add_print_action (L.PTattribute, Obj.repr a)

2
infer/src/IR/ProcAttributes.ml
Unescape View File

@ -21,6 +21,7 @@ let compare_proc_flags x y =
let bindings x = Hashtbl.fold (fun k d l -> (k, d) :: l) x [] in
[%compare : (string * string) list] (bindings x) (bindings y)
let proc_flags_empty () : proc_flags = Hashtbl.create 1
let proc_flag_ignore_return = "ignore_return"
@ -99,3 +100,4 @@ let default proc_name language =
; proc_name
; ret_type= Typ.mk Typ.Tvoid
; source_file_captured= SourceFile.invalid __FILE__ }

142
infer/src/IR/Procdesc.ml
Unescape View File

@ -59,6 +59,7 @@ module Node = struct
; preds= []
; exn= [] }
let compare node1 node2 = Int.compare node1.id node2.id
let hash node = Hashtbl.hash node.id
@ -98,6 +99,7 @@ module Node = struct
in
NodeSet.elements (slice_nodes node.succs)
let get_sliced_preds node f =
let visited = ref NodeSet.empty in
let rec slice_nodes nodes : NodeSet.t =
@ -112,16 +114,18 @@ module Node = struct
in
NodeSet.elements (slice_nodes node.preds)
let get_exn node = node.exn
(** Get the name of the procedure the node belongs to *)
let get_proc_name node =
match node.pname_opt with
| None
-> L.internal_error "get_proc_name: at node %d@\n" node.id ;
| None ->
L.internal_error "get_proc_name: at node %d@\n" node.id ;
assert false
| Some pname
-> pname
| Some pname ->
pname
(** Get the predecessors of the node *)
let get_preds node = node.preds
@ -137,6 +141,7 @@ module Node = struct
in
nodes start_node
(** Get the node kind *)
let get_kind node = node.kind
@ -149,11 +154,12 @@ module Node = struct
match instr with
| Sil.Call (_, exp, _, _, _) -> (
match exp with Exp.Const Const.Cfun procname -> procname :: callees | _ -> callees )
| _
-> callees
| _ ->
callees
in
List.fold ~f:collect ~init:[] (get_instrs node)
(** Get the location of the node *)
let get_loc n = n.loc
@ -161,6 +167,7 @@ module Node = struct
let get_last_loc n =
match List.rev (get_instrs n) with instr :: _ -> Sil.instr_get_loc instr | [] -> n.loc
let pp_id f id = F.fprintf f "%d" id
let pp f node = pp_id f (get_id node)
@ -189,6 +196,7 @@ module Node = struct
let instr = Sil.Declare_locals (ptl, loc) in
prepend_instrs node [instr]
(** Print extended instructions for the node,
highlighting the given subinstruction if present *)
let pp_instrs pe0 ~sub_instrs instro fmt node =
@ -201,44 +209,47 @@ module Node = struct
else
let () =
match get_kind node with
| Stmt_node s
-> F.fprintf fmt "statements (%s)" s
| Prune_node (_, _, descr)
-> F.fprintf fmt "assume %s" descr
| Exit_node _
-> F.fprintf fmt "exit"
| Skip_node s
-> F.fprintf fmt "skip (%s)" s
| Start_node _
-> F.fprintf fmt "start"
| Join_node
-> F.fprintf fmt "join"
| Stmt_node s ->
F.fprintf fmt "statements (%s)" s
| Prune_node (_, _, descr) ->
F.fprintf fmt "assume %s" descr
| Exit_node _ ->
F.fprintf fmt "exit"
| Skip_node s ->
F.fprintf fmt "skip (%s)" s
| Start_node _ ->
F.fprintf fmt "start"
| Join_node ->
F.fprintf fmt "join"
in
F.fprintf fmt " %a " Location.pp (get_loc node)
(** Dump extended instructions for the node *)
let d_instrs ~(sub_instrs: bool) (curr_instr: Sil.instr option) (node: t) =
L.add_print_action (L.PTnode_instrs, Obj.repr (sub_instrs, curr_instr, node))
(** Return a description of the cfg node *)
let get_description pe node =
let str =
match get_kind node with
| Stmt_node _
-> "Instructions"
| Prune_node (_, _, descr)
-> "Conditional" ^ " " ^ descr
| Exit_node _
-> "Exit"
| Skip_node _
-> "Skip"
| Start_node _
-> "Start"
| Join_node
-> "Join"
| Stmt_node _ ->
"Instructions"
| Prune_node (_, _, descr) ->
"Conditional" ^ " " ^ descr
| Exit_node _ ->
"Exit"
| Skip_node _ ->
"Skip"
| Start_node _ ->
"Start"
| Join_node ->
"Join"
in
let pp fmt = F.fprintf fmt "%s@\n%a@?" str (pp_instrs pe None ~sub_instrs:true) node in
F.asprintf "%t" pp
end
(* =============== END of module Node =============== *)
@ -273,6 +284,7 @@ let from_proc_attributes ~called_from_cfg attributes =
let exit_node = Node.dummy pname_opt in
{attributes; nodes= []; nodes_num= 0; start_node; exit_node; loop_heads= None}
(** Compute the distance of each node to the exit node, if not computed already *)
let compute_distance_to_exit_node pdesc =
let exit_node = pdesc.exit_node in
@ -280,10 +292,10 @@ let compute_distance_to_exit_node pdesc =
let next_nodes = ref [] in
let do_node (node: Node.t) =
match node.dist_exit with
| Some _
-> ()
| None
-> node.dist_exit <- Some dist ;
| Some _ ->
()
| None ->
node.dist_exit <- Some dist ;
next_nodes := node.preds @ !next_nodes
in
List.iter ~f:do_node nodes ;
@ -291,6 +303,7 @@ let compute_distance_to_exit_node pdesc =
in
mark_distance 0 [exit_node]
(** check or indicate if we have performed preanalysis on the CFG *)
let did_preanalysis pdesc = pdesc.attributes.did_preanalysis
@ -334,6 +347,7 @@ let get_start_node pdesc = pdesc.start_node
let get_sliced_slope pdesc f =
Node.get_generated_slope (get_start_node pdesc) (fun n -> Node.get_sliced_succs n f)
(** List of nodes in the procedure up to the first branching *)
let get_slope pdesc = Node.get_generated_slope (get_start_node pdesc) Node.get_succs
@ -354,6 +368,7 @@ let fold_calls f acc pdesc =
in
List.fold ~f:do_node ~init:acc (get_nodes pdesc)
(** iterate over the calls from the procedure: (callee,location) pairs *)
let iter_calls f pdesc = fold_calls (fun _ call -> f call) () pdesc
@ -361,6 +376,7 @@ let iter_instrs f pdesc =
let do_node node = List.iter ~f:(fun i -> f node i) (Node.get_instrs node) in
iter_nodes do_node pdesc
let fold_nodes f acc pdesc = List.fold ~f ~init:acc (List.rev (get_nodes pdesc))
let fold_instrs f acc pdesc =
@ -369,23 +385,26 @@ let fold_instrs f acc pdesc =
in
fold_nodes fold_node acc pdesc
let iter_slope f pdesc =
let visited = ref NodeSet.empty in
let rec do_node node =
visited := NodeSet.add node !visited ;
f node ;
match Node.get_succs node with
| [n]
-> if not (NodeSet.mem n !visited) then do_node n
| _
-> ()
| [n] ->
if not (NodeSet.mem n !visited) then do_node n
| _ ->
()
in
do_node (get_start_node pdesc)
let iter_slope_calls f pdesc =
let do_node node = List.iter ~f:(fun callee_pname -> f callee_pname) (Node.get_callees node) in
iter_slope do_node pdesc
(** iterate between two nodes or until we reach a branching structure *)
let iter_slope_range f src_node dst_node =
let visited = ref NodeSet.empty in
@ -393,13 +412,14 @@ let iter_slope_range f src_node dst_node =
visited := NodeSet.add node !visited ;
f node ;
match Node.get_succs node with
| [n]
-> if not (NodeSet.mem n !visited) && not (Node.equal node dst_node) then do_node n
| _
-> ()
| [n] ->
if not (NodeSet.mem n !visited) && not (Node.equal node dst_node) then do_node n
| _ ->
()
in
do_node src_node
(** Set the exit node of the proc desc *)
let set_exit_node pdesc node = pdesc.exit_node <- node
@ -413,12 +433,14 @@ let set_start_node pdesc node = pdesc.start_node <- node
let append_locals pdesc new_locals =
(pdesc.attributes).locals <- pdesc.attributes.locals @ new_locals
(** Set the successor nodes and exception nodes, and build predecessor links *)
let set_succs_exn_base (node: Node.t) succs exn =
node.succs <- succs ;
node.exn <- exn ;
List.iter ~f:(fun (n: Node.t) -> n.preds <- node :: n.preds) succs
(** Create a new cfg node *)
let create_node pdesc loc kind instrs =
pdesc.nodes_num <- pdesc.nodes_num + 1 ;
@ -437,18 +459,20 @@ let create_node pdesc loc kind instrs =
pdesc.nodes <- node :: pdesc.nodes ;
node
(** Set the successor and exception nodes.
If this is a join node right before the exit node, add an extra node in the middle,
otherwise nullify and abstract instructions cannot be added after a conditional. *)
let node_set_succs_exn pdesc (node: Node.t) succs exn =
match (node.kind, succs) with
| Join_node, [({Node.kind= Exit_node _} as exit_node)]
-> let kind = Node.Stmt_node "between_join_and_exit" in
| Join_node, [({Node.kind= Exit_node _} as exit_node)] ->
let kind = Node.Stmt_node "between_join_and_exit" in
let node' = create_node pdesc node.loc kind node.instrs in
set_succs_exn_base node [node'] exn ;
set_succs_exn_base node' [exit_node] exn
| _
-> set_succs_exn_base node succs exn
| _ ->
set_succs_exn_base node succs exn
(** Get loop heads for widening.
It collects all target nodes of back-edges in a depth-first
@ -457,10 +481,10 @@ let node_set_succs_exn pdesc (node: Node.t) succs exn =
let get_loop_heads pdesc =
let rec set_loop_head_rec visited heads wl =
match wl with
| []
-> heads
| (n, ancester) :: wl'
-> if NodeSet.mem n visited then
| [] ->
heads
| (n, ancester) :: wl' ->
if NodeSet.mem n visited then
if NodeSet.mem n ancester then set_loop_head_rec visited (NodeSet.add n heads) wl'
else set_loop_head_rec visited heads wl'
else
@ -474,10 +498,12 @@ let get_loop_heads pdesc =
pdesc.loop_heads <- Some lh ;
lh
let is_loop_head pdesc (node: Node.t) =
let lh = match pdesc.loop_heads with Some lh -> lh | None -> get_loop_heads pdesc in
NodeSet.mem node lh
let pp_variable_list fmt etl =
if List.is_empty etl then Format.fprintf fmt "None"
else
@ -485,14 +511,16 @@ let pp_variable_list fmt etl =
~f:(fun (id, ty) -> Format.fprintf fmt " %a:%a" Mangled.pp id (Typ.pp_full Pp.text) ty)
etl
let pp_objc_accessor fmt accessor =
match accessor with
| Some ProcAttributes.Objc_getter field
-> Format.fprintf fmt "Getter of %a, " (Typ.Struct.pp_field Pp.text) field
| Some ProcAttributes.Objc_setter field
-> Format.fprintf fmt "Setter of %a, " (Typ.Struct.pp_field Pp.text) field
| None
-> ()
| Some ProcAttributes.Objc_getter field ->
Format.fprintf fmt "Getter of %a, " (Typ.Struct.pp_field Pp.text) field
| Some ProcAttributes.Objc_setter field ->
Format.fprintf fmt "Setter of %a, " (Typ.Struct.pp_field Pp.text) field
| None ->
()
let pp_signature fmt pdesc =
let attributes = get_attributes pdesc in
@ -511,6 +539,8 @@ let pp_signature fmt pdesc =
Format.fprintf fmt ", Annotation: %a" (Annot.Method.pp pname_string) method_annotation ;
Format.fprintf fmt "]@\n"
let is_specialized pdesc =
let attributes = get_attributes pdesc in
attributes.ProcAttributes.is_specialized

115
infer/src/IR/Pvar.ml
Unescape View File

@ -44,67 +44,73 @@ let compare_modulo_this x y =
else if String.equal "this" (Mangled.to_string x.pv_name) then 0
else compare_pvar_kind x.pv_kind y.pv_kind
let equal = [%compare.equal : t]
let pp_translation_unit fmt = function
| TUFile fname
-> SourceFile.pp fmt fname
| TUExtern
-> Format.fprintf fmt "EXTERN"
| TUFile fname ->
SourceFile.pp fmt fname
| TUExtern ->
Format.fprintf fmt "EXTERN"
let _pp f pv =
let name = pv.pv_name in
match pv.pv_kind with
| Local_var n
-> if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name
| Local_var n ->
if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name
else F.fprintf f "%a$%a" Typ.Procname.pp n Mangled.pp name
| Callee_var n
-> if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name
| Callee_var n ->
if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name
else F.fprintf f "%a$%a|callee" Typ.Procname.pp n Mangled.pp name
| Abduced_retvar (n, l)
-> if !Config.pp_simple then F.fprintf f "%a|abducedRetvar" Mangled.pp name
| Abduced_retvar (n, l) ->
if !Config.pp_simple then F.fprintf f "%a|abducedRetvar" Mangled.pp name
else F.fprintf f "%a$[%a]%a|abducedRetvar" Typ.Procname.pp n Location.pp l Mangled.pp name
| Abduced_ref_param (n, index, l)
-> if !Config.pp_simple then F.fprintf f "%a|abducedRefParam%d" Mangled.pp name index
| Abduced_ref_param (n, index, l) ->
if !Config.pp_simple then F.fprintf f "%a|abducedRefParam%d" Mangled.pp name index
else F.fprintf f "%a$[%a]%a|abducedRefParam" Typ.Procname.pp n Location.pp l Mangled.pp name
| Global_var (translation_unit, is_const, is_pod, _)
-> F.fprintf f "#GB<%a%s%s>$%a" pp_translation_unit translation_unit
| Global_var (translation_unit, is_const, is_pod, _) ->
F.fprintf f "#GB<%a%s%s>$%a" pp_translation_unit translation_unit
(if is_const then "|const" else "")
(if not is_pod then "|!pod" else "")
Mangled.pp name
| Seed_var
-> F.fprintf f "old_%a" Mangled.pp name
| Seed_var ->
F.fprintf f "old_%a" Mangled.pp name
(** Pretty print a program variable in latex. *)
let pp_latex f pv =
let name = pv.pv_name in
match pv.pv_kind with
| Local_var _
-> Latex.pp_string Latex.Roman f (Mangled.to_string name)
| Callee_var _
-> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
| Local_var _ ->
Latex.pp_string Latex.Roman f (Mangled.to_string name)
| Callee_var _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "callee"
| Abduced_retvar _
-> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
| Abduced_retvar _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "abducedRetvar"
| Abduced_ref_param _
-> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
| Abduced_ref_param _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "abducedRefParam"
| Global_var _
-> Latex.pp_string Latex.Boldface f (Mangled.to_string name)
| Seed_var
-> F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
| Global_var _ ->
Latex.pp_string Latex.Boldface f (Mangled.to_string name)
| Seed_var ->
F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "old"
(** Pretty print a pvar which denotes a value, not an address *)
let pp_value pe f pv =
match pe.Pp.kind with TEXT -> _pp f pv | HTML -> _pp f pv | LATEX -> pp_latex f pv
(** Pretty print a program variable. *)
let pp pe f pv =
let ampersand = match pe.Pp.kind with TEXT -> "&" | HTML -> "&amp;" | LATEX -> "\\&" in
F.fprintf f "%s%a" ampersand (pp_value pe) pv
(** Dump a program variable. *)
let d (pvar: t) = L.add_print_action (L.PTpvar, Obj.repr pvar)
@ -123,13 +129,15 @@ let get_simplified_name pv =
match String.rsplit2 s ~on:'.' with
| Some (s1, s2) -> (
match String.rsplit2 s1 ~on:'.' with Some (_, s4) -> s4 ^ "." ^ s2 | _ -> s )
| _
-> s
| _ ->
s
(** Check if the pvar is an abucted return var or param passed by ref *)
let is_abduced pv =
match pv.pv_kind with Abduced_retvar _ | Abduced_ref_param _ -> true | _ -> false
(** Turn a pvar into a seed pvar (which stored the initial value) *)
let to_seed pv = {pv with pv_kind= Seed_var}
@ -173,10 +181,11 @@ let is_frontend_tmp pvar =
is_sil_tmp name
||
match pvar.pv_kind with
| Local_var pname
-> Typ.Procname.is_java pname && is_bytecode_tmp name
| _
-> false
| Local_var pname ->
Typ.Procname.is_java pname && is_bytecode_tmp name
| _ ->
false
(* in Sawja, variables like $T0_18 are temporaries, but not SSA vars. *)
let is_ssa_frontend_tmp pvar =
@ -185,25 +194,28 @@ let is_ssa_frontend_tmp pvar =
let name = to_string pvar in
not (String.contains name '_' && String.contains name '$')
(** Turn an ordinary program variable into a callee program variable *)
let to_callee pname pvar =
match pvar.pv_kind with
| Local_var _
-> {pvar with pv_kind= Callee_var pname}
| Global_var _
-> pvar
| Callee_var _ | Abduced_retvar _ | Abduced_ref_param _ | Seed_var
-> L.d_str "Cannot convert pvar to callee: " ;
| Local_var _ ->
{pvar with pv_kind= Callee_var pname}
| Global_var _ ->
pvar
| Callee_var _ | Abduced_retvar _ | Abduced_ref_param _ | Seed_var ->
L.d_str "Cannot convert pvar to callee: " ;
d pvar ;
L.d_ln () ;
assert false
let name_hash (name: Mangled.t) = Hashtbl.hash name
(** [mk name proc_name] creates a program var with the given function name *)
let mk (name: Mangled.t) (proc_name: Typ.Procname.t) : t =
{pv_hash= name_hash name; pv_name= name; pv_kind= Local_var proc_name}
let get_ret_pvar pname = mk Ident.name_return pname
(** [mk_callee name proc_name] creates a program var
@ -211,6 +223,7 @@ let get_ret_pvar pname = mk Ident.name_return pname
let mk_callee (name: Mangled.t) (proc_name: Typ.Procname.t) : t =
{pv_hash= name_hash name; pv_name= name; pv_kind= Callee_var proc_name}
(** create a global variable with the given name *)
let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) (name: Mangled.t)
translation_unit : t =
@ -218,27 +231,32 @@ let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) (
; pv_name= name
; pv_kind= Global_var (translation_unit, is_constexpr, is_pod, is_static_local) }
(** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! *)
let mk_tmp name pname =
let id = Ident.create_fresh Ident.knormal in
let pvar_mangled = Mangled.from_string (tmp_prefix ^ name ^ Ident.to_string id) in
mk pvar_mangled pname
(** create an abduced return variable for a call to [proc_name] at [loc] *)
let mk_abduced_ret (proc_name: Typ.Procname.t) (loc: Location.t) : t =
let name = Mangled.from_string ("$RET_" ^ Typ.Procname.to_unique_id proc_name) in
{pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_retvar (proc_name, loc)}
let mk_abduced_ref_param (proc_name: Typ.Procname.t) (index: int) (loc: Location.t) : t =
let name = Mangled.from_string ("$REF_PARAM_VAL_" ^ Typ.Procname.to_unique_id proc_name) in
{pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_ref_param (proc_name, index, loc)}
let get_translation_unit pvar =
match pvar.pv_kind with
| Global_var (tu, _, _, _)
-> tu
| _
-> L.(die InternalError) "Expected a global variable"
| Global_var (tu, _, _, _) ->
tu
| _ ->
L.(die InternalError) "Expected a global variable"
let is_compile_constant pvar = match pvar.pv_kind with Global_var (_, b, _, _) -> b | _ -> false
@ -246,9 +264,10 @@ let is_pod pvar = match pvar.pv_kind with Global_var (_, _, b, _) -> b | _ -> tr
let get_initializer_pname {pv_name; pv_kind} =
match pv_kind with
| Global_var _
-> Some
| Global_var _ ->
Some
(Typ.Procname.from_string_c_fun
(Config.clang_initializer_prefix ^ Mangled.to_string_full pv_name))
| _
-> None
| _ ->
None

19
infer/src/IR/QualifiedCppName.ml
Unescape View File

@ -25,16 +25,18 @@ let strip_template_args quals =
let no_template_name s = List.hd_exn (String.split ~on:'<' s) in
List.map ~f:no_template_name quals
let append_template_args_to_last quals ~args =
match quals with
| [last; _] when String.contains last '<'
-> L.(die InternalError)
| [last; _] when String.contains last '<' ->
L.(die InternalError)
"expected qualified name without template args, but got %s, the last qualifier of %s" last
(String.concat ~sep:", " quals)
| last :: rest
-> (last ^ args) :: rest
| []
-> L.(die InternalError) "expected non-empty qualified name"
| last :: rest ->
(last ^ args) :: rest
| [] ->
L.(die InternalError) "expected non-empty qualified name"
let to_list = List.rev
@ -68,6 +70,7 @@ module Match = struct
let regexp_string_of_qualifiers quals =
Str.quote (to_separated_string ~sep:matching_separator quals) ^ "$"
let qualifiers_list_matcher quals_list =
( if List.is_empty quals_list then "a^"
else
@ -75,6 +78,7 @@ module Match = struct
List.map ~f:regexp_string_of_qualifiers quals_list |> String.concat ~sep:"\\|" )
|> Str.regexp
let qualifiers_of_fuzzy_qual_name qual_name =
(* Fail if we detect templates in the fuzzy name. Template instantiations are not taken into
account when fuzzy matching, and templates may produce wrong results when parsing qualified
@ -86,12 +90,15 @@ module Match = struct
L.(die InternalError) "Unexpected template in fuzzy qualified name %s." qual_name ) ;
of_qual_string qual_name
let of_fuzzy_qual_names fuzzy_qual_names =
List.map fuzzy_qual_names ~f:qualifiers_of_fuzzy_qual_name |> qualifiers_list_matcher
let match_qualifiers matcher quals =
(* qual_name may have qualifiers with template parameters - drop them to whitelist all
instantiations *)
let normalized_qualifiers = strip_template_args quals in
Str.string_match matcher (to_separated_string ~sep:matching_separator normalized_qualifiers) 0
end

1278
infer/src/IR/Sil.ml
View File

File diff suppressed because it is too large Load Diff

156
infer/src/IR/Subtype.ml
Unescape View File

@ -18,6 +18,7 @@ let list_to_string list =
if Int.equal (List.length list) 0 then "( sub )"
else "- {" ^ String.concat ~sep:", " (List.map ~f:Typ.Name.name list) ^ "}"
type t' =
| Exact (** denotes the current type only *)
| Subtypes of Typ.Name.t list
@ -39,27 +40,30 @@ let equal_result = [%compare.equal : result]
let sub_type tname_subst st_pair =
let st, kind = st_pair in
match st with
| Subtypes tnames
-> let tnames' = IList.map_changed tname_subst tnames in
| Subtypes tnames ->
let tnames' = IList.map_changed tname_subst tnames in
if phys_equal tnames tnames' then st_pair else (Subtypes tnames', kind)
| Exact
-> st_pair
| Exact ->
st_pair
let max_result res1 res2 = if compare_result res1 res2 <= 0 then res2 else res1
let is_interface tenv (class_name: Typ.Name.t) =
match (class_name, Tenv.lookup tenv class_name) with
| JavaClass _, Some {fields= []; methods= []}
-> true
| _
-> false
| JavaClass _, Some {fields= []; methods= []} ->
true
| _ ->
false
let is_root_class class_name =
match class_name with
| Typ.JavaClass _
-> Typ.Name.equal class_name Typ.Name.Java.java_lang_object
| _
-> false
| Typ.JavaClass _ ->
Typ.Name.equal class_name Typ.Name.Java.java_lang_object
| _ ->
false
(** check if c1 is a subclass of c2 *)
let check_subclass_tenv tenv c1 c2 : result =
@ -69,23 +73,24 @@ let check_subclass_tenv tenv c1 c2 : result =
if equal_result best_result Yes then Yes
else
match classnames with
| []
-> best_result
| cn :: cns
-> loop (max_result best_result (check cn)) cns
| [] ->
best_result
| cn :: cns ->
loop (max_result best_result (check cn)) cns
and check cn : result =
if Typ.Name.equal cn c2 then Yes
else
match Tenv.lookup tenv cn with
| None when is_root_class cn
-> No
| None
-> Unknown
| Some {supers}
-> loop No supers
| None when is_root_class cn ->
No
| None ->
Unknown
| Some {supers} ->
loop No supers
in
if is_root_class c2 then Yes else check c1
module SubtypesMap = Caml.Map.Make (struct
(* pair of subtypes *)
type t = Typ.Name.t * Typ.Name.t [@@deriving compare]
@ -101,6 +106,7 @@ let check_subtype =
is_subt
: result )
let is_known_subtype tenv c1 c2 : bool = equal_result (check_subtype tenv c1 c2) Yes
let is_known_not_subtype tenv c1 c2 : bool = equal_result (check_subtype tenv c1 c2) No
@ -110,10 +116,11 @@ let flag_to_string flag = match flag with CAST -> "(cast)" | INSTOF -> "(instof)
let pp f (t, flag) =
if Config.print_types then
match t with
| Exact
-> F.fprintf f "%s" (flag_to_string flag)
| Subtypes list
-> F.fprintf f "%s" (list_to_string list ^ flag_to_string flag)
| Exact ->
F.fprintf f "%s" (flag_to_string flag)
| Subtypes list ->
F.fprintf f "%s" (list_to_string list ^ flag_to_string flag)
let exact = (Exact, NORMAL)
@ -133,56 +140,63 @@ let list_intersect equal l1 l2 =
let in_l2 a = List.mem ~equal l2 a in
List.filter ~f:in_l2 l1
let join_flag flag1 flag2 =
match (flag1, flag2) with CAST, _ -> CAST | _, CAST -> CAST | _, _ -> NORMAL
let join (s1, flag1) (s2, flag2) =
let s =
match (s1, s2) with
| Exact, _
-> s2
| _, Exact
-> s1
| Subtypes l1, Subtypes l2
-> Subtypes (list_intersect Typ.Name.equal l1 l2)
| Exact, _ ->
s2
| _, Exact ->
s1
| Subtypes l1, Subtypes l2 ->
Subtypes (list_intersect Typ.Name.equal l1 l2)
in
let flag = join_flag flag1 flag2 in
(s, flag)
let update_flag c1 c2 flag flag' =
match flag with INSTOF -> if Typ.Name.equal c1 c2 then flag else flag' | _ -> flag'
let change_flag st_opt c1 c2 flag' =
match st_opt with
| Some st -> (
match st with
| Exact, flag
-> let new_flag = update_flag c1 c2 flag flag' in
| Exact, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Exact, new_flag)
| Subtypes t, flag
-> let new_flag = update_flag c1 c2 flag flag' in
| Subtypes t, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Subtypes t, new_flag) )
| None
-> None
| None ->
None
let normalize_subtypes t_opt c1 c2 flag1 flag2 =
let new_flag = update_flag c1 c2 flag1 flag2 in
match t_opt with
| Some t -> (
match t with
| Exact
-> Some (t, new_flag)
| Subtypes l
-> Some (Subtypes (List.sort ~cmp:Typ.Name.compare l), new_flag) )
| None
-> None
| Exact ->
Some (t, new_flag)
| Subtypes l ->
Some (Subtypes (List.sort ~cmp:Typ.Name.compare l), new_flag) )
| None ->
None
let subtypes_to_string t =
match fst t with
| Exact
-> "ex" ^ flag_to_string (snd t)
| Subtypes l
-> list_to_string l ^ flag_to_string (snd t)
| Exact ->
"ex" ^ flag_to_string (snd t)
| Subtypes l ->
list_to_string l ^ flag_to_string (snd t)
(* c is a subtype when it does not appear in the list l of no-subtypes *)
let no_subtype_in_list tenv c l = not (List.exists ~f:(is_known_subtype tenv c) l)
@ -204,21 +218,23 @@ let check_redundancies tenv c l =
in
List.fold ~f:aux ~init:([], true) l
let rec updates_head f c l =
match l with
| []
-> []
| ci :: rest
-> if is_strict_subtype f ci c then ci :: updates_head f c rest else updates_head f c rest
| [] ->
[]
| ci :: rest ->
if is_strict_subtype f ci c then ci :: updates_head f c rest else updates_head f c rest
(* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur
A - { X1,..., Xn } is inconsistent if A <: Xi for some i *)
let rec add_not_subtype tenv c1 l1 l2 =
match l2 with
| []
-> l1
| c :: rest
-> if is_known_subtype tenv c1 c then add_not_subtype tenv c1 l1 rest
| [] ->
l1
| c :: rest ->
if is_known_subtype tenv c1 c then add_not_subtype tenv c1 l1 rest
else
(* checks for inconsistencies *)
let l1', should_add = check_redundancies tenv c l1 in
@ -226,23 +242,24 @@ let rec add_not_subtype tenv c1 l1 l2 =
let rest' = add_not_subtype tenv c1 l1' rest in
if should_add then c :: rest' else rest'
let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) =
let is_sub = is_known_subtype tenv c1 c2 in
let pos_st, neg_st =
match (st1, st2) with
| Exact, Exact
-> if is_sub then (Some st1, None) else (None, Some st1)
| Exact, Subtypes l2
-> if is_sub && no_subtype_in_list tenv c1 l2 then (Some st1, None) else (None, Some st1)
| Subtypes l1, Exact
-> if is_sub then (Some st1, None)
| Exact, Exact ->
if is_sub then (Some st1, None) else (None, Some st1)
| Exact, Subtypes l2 ->
if is_sub && no_subtype_in_list tenv c1 l2 then (Some st1, None) else (None, Some st1)
| Subtypes l1, Exact ->
if is_sub then (Some st1, None)
else
let l1' = updates_head tenv c2 l1 in
if no_subtype_in_list tenv c2 l1 then
(Some (Subtypes l1'), Some (Subtypes (add_not_subtype tenv c1 l1 [c2])))
else (None, Some st1)
| Subtypes l1, Subtypes l2
-> if is_interface tenv c2 || is_sub then
| Subtypes l1, Subtypes l2 ->
if is_interface tenv c2 || is_sub then
if no_subtype_in_list tenv c1 l2 then
let l2' = updates_head tenv c1 l2 in
(Some (Subtypes (add_not_subtype tenv c1 l1 l2')), None)
@ -257,19 +274,21 @@ let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) =
in
(normalize_subtypes pos_st c1 c2 flag1 flag2, normalize_subtypes neg_st c1 c2 flag1 flag2)
let case_analysis_basic tenv (c1, st) (c2, (_, flag2)) =
let pos_st, neg_st =
if is_known_subtype tenv c1 c2 then (Some st, None)
else if is_known_subtype tenv c2 c1 then
match st with
| Exact, _
-> if Typ.Name.equal c1 c2 then (Some st, None) else (None, Some st)
| Subtypes _, _
-> if Typ.Name.equal c1 c2 then (Some st, None) else (Some st, Some st)
| Exact, _ ->
if Typ.Name.equal c1 c2 then (Some st, None) else (None, Some st)
| Subtypes _, _ ->
if Typ.Name.equal c1 c2 then (Some st, None) else (Some st, Some st)
else (None, Some st)
in
(change_flag pos_st c1 c2 flag2, change_flag neg_st c1 c2 flag2)
(** [case_analysis (c1, st1) (c2, st2) f] performs case analysis on [c1 <: c2]
according to [st1] and [st2]
where f c1 c2 is true if c1 is a subtype of c2.
@ -280,3 +299,4 @@ let case_analysis_basic tenv (c1, st) (c2, (_, flag2)) =
let case_analysis tenv (c1, st1) (c2, st2) =
if Config.subtype_multirange then get_subtypes tenv (c1, st1) (c2, st2)
else case_analysis_basic tenv (c1, st1) (c2, st2)

53
infer/src/IR/Tenv.ml
Unescape View File

@ -34,6 +34,7 @@ let pp fmt (tenv: t) =
Format.fprintf fmt "@[<6>TYPE: %a@." (Typ.Struct.pp Pp.text name) typ)
tenv
(** Create a new type environment. *)
let create () = TypenameHash.create 1000
@ -42,7 +43,9 @@ let mk_struct tenv ?default ?fields ?statics ?methods ?supers ?annots name =
let struct_typ =
Typ.Struct.internal_mk_struct ?default ?fields ?statics ?methods ?supers ?annots ()
in
TypenameHash.replace tenv name struct_typ ; struct_typ
TypenameHash.replace tenv name struct_typ ;
struct_typ
(** Check if typename is found in tenv *)
let mem tenv name = TypenameHash.mem tenv name
@ -59,8 +62,9 @@ let lookup tenv name : Typ.Struct.t option =
| CppClass (m, NoTemplate) -> (
try Some (TypenameHash.find tenv (CStruct m))
with Not_found -> None )
| _
-> None
| _ ->
None
(** Add a (name,type) pair to the global type environment. *)
let add tenv name struct_typ = TypenameHash.replace tenv name struct_typ
@ -77,15 +81,17 @@ let sort_fields_tenv tenv =
in
iter sort_fields_struct tenv
(** Add a field to a given struct in the global type environment. *)
let add_field tenv class_tn_name field =
match lookup tenv class_tn_name with
| Some ({fields} as struct_typ)
-> if not (List.mem ~equal:equal_fields fields field) then
| Some ({fields} as struct_typ) ->
if not (List.mem ~equal:equal_fields fields field) then
let new_fields = List.merge [field] fields ~cmp:compare_fields in
ignore (mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name)
| _
-> ()
| _ ->
()
(** Get method that is being overriden by java_pname (if any) **)
let get_overriden_method tenv pname_java =
@ -103,21 +109,23 @@ let get_overriden_method tenv pname_java =
Some (struct_typ_get_method_by_name struct_typ (Typ.Procname.java_get_method pname_java))
with Not_found ->
get_overriden_method_in_supers pname_java (supers_tail @ struct_typ.supers) )
| None
-> get_overriden_method_in_supers pname_java supers_tail )
| []
-> None
| None ->
get_overriden_method_in_supers pname_java supers_tail )
| [] ->
None
in
match lookup tenv (Typ.Procname.java_get_class_type_name pname_java) with
| Some {supers}
-> get_overriden_method_in_supers pname_java supers
| _
-> None
| Some {supers} ->
get_overriden_method_in_supers pname_java supers
| _ ->
None
(** Serializer for type environments *)
let tenv_serializer : t Serialization.serializer =
Serialization.create_serializer Serialization.Key.tenv
let global_tenv : t option ref = ref None
(** Load a type environment from a file *)
@ -128,6 +136,7 @@ let load_from_file (filename: DB.filename) : t option =
!global_tenv )
else Serialization.read_from_file tenv_serializer filename
(** Save a type environment into a file *)
let store_to_file (filename: DB.filename) (tenv: t) =
(* update in-memory global tenv for later uses by this process, e.g. in single-core mode the
@ -140,13 +149,15 @@ let store_to_file (filename: DB.filename) (tenv: t) =
let fmt = Format.formatter_of_out_channel out_channel in
Format.fprintf fmt "%a" pp tenv ; Out_channel.close out_channel
exception Found of Typ.Name.t
let language_is tenv lang =
match TypenameHash.iter (fun n -> raise (Found n)) tenv with
| ()
-> false
| exception Found JavaClass _
-> Config.equal_language lang Java
| exception Found _
-> Config.equal_language lang Clang
| () ->
false
| exception Found JavaClass _ ->
Config.equal_language lang Java
| exception Found _ ->
Config.equal_language lang Clang

914
infer/src/IR/Typ.ml
View File

File diff suppressed because it is too large Load Diff

119
infer/src/absint/AbstractDomain.ml
Unescape View File

@ -57,34 +57,37 @@ module BottomLifted (Domain : S) = struct
if phys_equal lhs rhs then true
else
match (lhs, rhs) with
| Bottom, _
-> true
| _, Bottom
-> false
| NonBottom lhs, NonBottom rhs
-> Domain.( <= ) ~lhs ~rhs
| Bottom, _ ->
true
| _, Bottom ->
false
| NonBottom lhs, NonBottom rhs ->
Domain.( <= ) ~lhs ~rhs
let join astate1 astate2 =
if phys_equal astate1 astate2 then astate1
else
match (astate1, astate2) with
| Bottom, _
-> astate2
| _, Bottom
-> astate1
| NonBottom a1, NonBottom a2
-> NonBottom (Domain.join a1 a2)
| Bottom, _ ->
astate2
| _, Bottom ->
astate1
| NonBottom a1, NonBottom a2 ->
NonBottom (Domain.join a1 a2)
let widen ~prev ~next ~num_iters =
if phys_equal prev next then prev
else
match (prev, next) with
| Bottom, _
-> next
| _, Bottom
-> prev
| NonBottom prev, NonBottom next
-> NonBottom (Domain.widen ~prev ~next ~num_iters)
| Bottom, _ ->
next
| _, Bottom ->
prev
| NonBottom prev, NonBottom next ->
NonBottom (Domain.widen ~prev ~next ~num_iters)
let pp fmt = function Bottom -> F.fprintf fmt "_|_" | NonBottom astate -> Domain.pp fmt astate
end
@ -98,30 +101,33 @@ module TopLifted (Domain : S) = struct
if phys_equal lhs rhs then true
else
match (lhs, rhs) with
| _, Top
-> true
| Top, _
-> false
| NonTop lhs, NonTop rhs
-> Domain.( <= ) ~lhs ~rhs
| _, Top ->
true
| Top, _ ->
false
| NonTop lhs, NonTop rhs ->
Domain.( <= ) ~lhs ~rhs
let join astate1 astate2 =
if phys_equal astate1 astate2 then astate1
else
match (astate1, astate2) with
| Top, _ | _, Top
-> Top
| NonTop a1, NonTop a2
-> NonTop (Domain.join a1 a2)
| Top, _ | _, Top ->
Top
| NonTop a1, NonTop a2 ->
NonTop (Domain.join a1 a2)
let widen ~prev ~next ~num_iters =
if phys_equal prev next then prev
else
match (prev, next) with
| Top, _ | _, Top
-> Top
| NonTop prev, NonTop next
-> NonTop (Domain.widen ~prev ~next ~num_iters)
| Top, _ | _, Top ->
Top
| NonTop prev, NonTop next ->
NonTop (Domain.widen ~prev ~next ~num_iters)
let pp fmt = function Top -> F.fprintf fmt "T" | NonTop astate -> Domain.pp fmt astate
end
@ -134,16 +140,19 @@ module Pair (Domain1 : S) (Domain2 : S) = struct
else Domain1.( <= ) ~lhs:(fst lhs) ~rhs:(fst rhs)
&& Domain2.( <= ) ~lhs:(snd lhs) ~rhs:(snd rhs)
let join astate1 astate2 =
if phys_equal astate1 astate2 then astate1
else (Domain1.join (fst astate1) (fst astate2), Domain2.join (snd astate1) (snd astate2))
let widen ~prev ~next ~num_iters =
if phys_equal prev next then prev
else
( Domain1.widen ~prev:(fst prev) ~next:(fst next) ~num_iters
, Domain2.widen ~prev:(snd prev) ~next:(snd next) ~num_iters )
let pp fmt (astate1, astate2) = F.fprintf fmt "(%a, %a)" Domain1.pp astate1 Domain2.pp astate2
end
@ -187,34 +196,37 @@ module Map (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S) = stru
with Not_found -> false)
lhs
let join astate1 astate2 =
if phys_equal astate1 astate2 then astate1
else
M.merge
(fun _ v1_opt v2_opt ->
match (v1_opt, v2_opt) with
| Some v1, Some v2
-> Some (ValueDomain.join v1 v2)
| Some v, _ | _, Some v
-> Some v
| None, None
-> None)
| Some v1, Some v2 ->
Some (ValueDomain.join v1 v2)
| Some v, _ | _, Some v ->
Some v
| None, None ->
None)
astate1 astate2
let widen ~prev ~next ~num_iters =
if phys_equal prev next then prev
else
M.merge
(fun _ v1_opt v2_opt ->
match (v1_opt, v2_opt) with
| Some v1, Some v2
-> Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters)
| Some v, _ | _, Some v
-> Some v
| None, None
-> None)
| Some v1, Some v2 ->
Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters)
| Some v, _ | _, Some v ->
Some v
| None, None ->
None)
prev next
let pp fmt astate = M.pp ~pp_value:ValueDomain.pp fmt astate
end
@ -230,30 +242,33 @@ module InvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S
try M.for_all (fun k rhs_v -> ValueDomain.( <= ) ~lhs:(M.find k lhs) ~rhs:rhs_v) rhs
with Not_found -> false
let join astate1 astate2 =
if phys_equal astate1 astate2 then astate1
else
M.merge
(fun _ v1_opt v2_opt ->
match (v1_opt, v2_opt) with
| Some v1, Some v2
-> Some (ValueDomain.join v1 v2)
| _
-> None)
| Some v1, Some v2 ->
Some (ValueDomain.join v1 v2)
| _ ->
None)
astate1 astate2
let widen ~prev ~next ~num_iters =
if phys_equal prev next then prev
else
M.merge
(fun _ v1_opt v2_opt ->
match (v1_opt, v2_opt) with
| Some v1, Some v2
-> Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters)
| _
-> None)
| Some v1, Some v2 ->
Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters)
| _ ->
None)
prev next
let pp fmt astate = M.pp ~pp_value:ValueDomain.pp fmt astate
end

44
infer/src/absint/AbstractInterpreter.ml
Unescape View File

@ -53,24 +53,27 @@ struct
try Some (InvariantMap.find node_id inv_map)
with Not_found -> None
(** extract the postcondition of node [n] from [inv_map] *)
let extract_post node_id inv_map =
match extract_state node_id inv_map with Some state -> Some state.post | None -> None
(** extract the precondition of node [n] from [inv_map] *)
let extract_pre node_id inv_map =
match extract_state node_id inv_map with Some state -> Some state.pre | None -> None
let exec_node node astate_pre work_queue inv_map ({ProcData.pdesc} as proc_data) ~debug =
let node_id = CFG.id node in
let update_inv_map pre visit_count =
let compute_post (pre, inv_map) (instr, id_opt) =
let post = TransferFunctions.exec_instr pre proc_data node instr in
match id_opt with
| Some id
-> (post, InvariantMap.add id {pre; post; visit_count} inv_map)
| None
-> (post, inv_map)
| Some id ->
(post, InvariantMap.add id {pre; post; visit_count} inv_map)
| None ->
(post, inv_map)
in
(* hack to ensure that we call `exec_instr` on a node even if it has no instructions *)
let instr_ids = match CFG.instr_ids node with [] -> [(Sil.skip_instr, None)] | l -> l in
@ -108,6 +111,7 @@ struct
let visit_count = 1 in
update_inv_map astate_pre visit_count
let rec exec_worklist cfg work_queue inv_map proc_data ~debug =
let compute_pre node inv_map =
(* if the [pred] -> [node] transition was normal, use post([pred]) *)
@ -119,25 +123,26 @@ struct
List.fold ~f:extract_pre_f ~init:normal_posts (CFG.exceptional_preds cfg node)
in
match List.filter_opt all_posts with
| post :: posts
-> Some (List.fold ~f:Domain.join ~init:post posts)
| []
-> None
| post :: posts ->
Some (List.fold ~f:Domain.join ~init:post posts)
| [] ->
None
in
match Scheduler.pop work_queue with
| Some (_, [], work_queue')
-> exec_worklist cfg work_queue' inv_map proc_data ~debug
| Some (node, _, work_queue')
-> let inv_map_post, work_queue_post =
| Some (_, [], work_queue') ->
exec_worklist cfg work_queue' inv_map proc_data ~debug
| Some (node, _, work_queue') ->
let inv_map_post, work_queue_post =
match compute_pre node inv_map with
| Some astate_pre
-> exec_node node astate_pre work_queue' inv_map proc_data ~debug
| None
-> (inv_map, work_queue')
| Some astate_pre ->
exec_node node astate_pre work_queue' inv_map proc_data ~debug
| None ->
(inv_map, work_queue')
in
exec_worklist cfg work_queue_post inv_map_post proc_data ~debug
| None
-> inv_map
| None ->
inv_map
(* compute and return an invariant map for [cfg] *)
let exec_cfg cfg proc_data ~initial ~debug =
@ -147,15 +152,18 @@ struct
in
exec_worklist cfg work_queue' inv_map' proc_data ~debug
(* compute and return an invariant map for [pdesc] *)
let exec_pdesc ({ProcData.pdesc} as proc_data) =
exec_cfg (CFG.from_pdesc pdesc) proc_data ~debug:Config.write_html
(* compute and return the postcondition of [pdesc] *)
let compute_post ?(debug= Config.write_html) ({ProcData.pdesc} as proc_data) ~initial =
let cfg = CFG.from_pdesc pdesc in
let inv_map = exec_cfg cfg proc_data ~initial ~debug in
extract_post (CFG.id (CFG.exit_node cfg)) inv_map
end
module MakeWithScheduler (C : ProcCfg.S) (S : Scheduler.Make) (T : TransferFunctions.MakeSIL) =

42
infer/src/absint/Checkers.ml
Unescape View File

@ -21,13 +21,14 @@ module PP = struct
let pp_loc_range linereader nbefore nafter fmt loc =
let printline n =
match Printer.LineReader.from_loc linereader {loc with Location.line= n} with
| Some s
-> F.fprintf fmt "%s%s@\n" (if Int.equal n loc.Location.line then "-->" else " ") s
| _
-> ()
| Some s ->
F.fprintf fmt "%s%s@\n" (if Int.equal n loc.Location.line then "-->" else " ") s
| _ ->
()
in
F.fprintf fmt "%a:%d@\n" SourceFile.pp loc.Location.file loc.Location.line ;
for n = loc.Location.line - nbefore to loc.Location.line + nafter do printline n done
end
(* PP *)
@ -73,33 +74,33 @@ module ST = struct
match (field_name, PatternMatch.get_this_type proc_attributes) with
| Some field_name, Some t -> (
match Typ.Struct.get_field_type_and_annotation ~lookup field_name t with
| Some (_, ia)
-> Annotations.ia_has_annotation_with ia annotation_matches
| None
-> false )
| _
-> false
| Some (_, ia) ->
Annotations.ia_has_annotation_with ia annotation_matches
| None ->
false )
| _ ->
false
in
let is_class_suppressed =
match PatternMatch.get_this_type proc_attributes with
| Some t -> (
match PatternMatch.type_get_annotation tenv t with
| Some ia
-> Annotations.ia_has_annotation_with ia annotation_matches
| None
-> false )
| None
-> false
| Some ia ->
Annotations.ia_has_annotation_with ia annotation_matches
| None ->
false )
| None ->
false
in
is_method_suppressed || is_field_suppressed || is_class_suppressed
in
let trace =
let origin_elements =
match origin_loc with
| Some oloc
-> [Errlog.make_trace_element 0 oloc "origin" []]
| None
-> []
| Some oloc ->
[Errlog.make_trace_element 0 oloc "origin" []]
| None ->
[]
in
origin_elements @ [Errlog.make_trace_element 0 loc description []]
in
@ -108,4 +109,5 @@ module ST = struct
(Typ.Procname.to_string proc_name) ;
L.progress "%s@." description ;
Reporting.log_error_deprecated proc_name ~loc ~ltr:trace exn )
end

3
infer/src/absint/FormalMap.ml
Unescape View File

@ -27,6 +27,7 @@ let make pdesc =
~f:(fun formal_map (base, index) -> AccessPath.BaseMap.add base index formal_map)
~init:AccessPath.BaseMap.empty formals_with_nums
let empty = AccessPath.BaseMap.empty
let is_formal = AccessPath.BaseMap.mem
@ -35,10 +36,12 @@ let get_formal_index base t =
try Some (AccessPath.BaseMap.find base t)
with Not_found -> None
let get_formal_base index t =
List.find ~f:(fun (_, i) -> Int.equal i index) (AccessPath.BaseMap.bindings t)
|> Option.map ~f:fst
let get_formals_indexes = AccessPath.BaseMap.bindings
let pp = AccessPath.BaseMap.pp ~pp_value:Int.pp

19
infer/src/absint/LowerHil.ml
Unescape View File

@ -29,7 +29,7 @@ struct
type extras = TransferFunctions.extras
let exec_instr (actual_state, id_map as astate) extras node instr =
let exec_instr ((actual_state, id_map) as astate) extras node instr =
let f_resolve_id id =
try Some (IdAccessPathMapDomain.find id id_map)
with Not_found -> None
@ -37,16 +37,16 @@ struct
match
HilInstr.of_sil ~include_array_indexes:HilConfig.include_array_indexes ~f_resolve_id instr
with
| Bind (id, access_path)
-> let id_map' = IdAccessPathMapDomain.add id access_path id_map in
| Bind (id, access_path) ->
let id_map' = IdAccessPathMapDomain.add id access_path id_map in
if phys_equal id_map id_map' then astate else (actual_state, id_map')
| Unbind ids
-> let id_map' =
| Unbind ids ->
let id_map' =
List.fold ~f:(fun acc id -> IdAccessPathMapDomain.remove id acc) ~init:id_map ids
in
if phys_equal id_map id_map' then astate else (actual_state, id_map')
| Instr hil_instr
-> let actual_state' = TransferFunctions.exec_instr actual_state extras node hil_instr in
| Instr hil_instr ->
let actual_state' = TransferFunctions.exec_instr actual_state extras node hil_instr in
( if Config.write_html then
let underyling_node = CFG.underlying_node node in
NodePrinter.start_session underyling_node ;
@ -55,8 +55,9 @@ struct
(fst astate) HilInstr.pp hil_instr TransferFunctions.Domain.pp actual_state') ;
NodePrinter.finish_session underyling_node ) ;
if phys_equal actual_state actual_state' then astate else (actual_state', id_map)
| Ignore
-> astate
| Ignore ->
astate
end
module MakeDefault (MakeTransferFunctions : TransferFunctions.MakeHIL) (CFG : ProcCfg.S) =

10
infer/src/absint/NodePrinter.ml
Unescape View File

@ -18,16 +18,18 @@ let new_session node =
let pname = Procdesc.Node.get_proc_name node in
let node_id = (Procdesc.Node.get_id node :> int) in
match Specs.get_summary pname with
| None
-> 0
| Some summary
-> (summary.stats).nodes_visited_fp <- IntSet.add node_id summary.stats.nodes_visited_fp ;
| None ->
0
| Some summary ->
(summary.stats).nodes_visited_fp <- IntSet.add node_id summary.stats.nodes_visited_fp ;
incr summary.Specs.sessions ;
!(summary.Specs.sessions)
let start_session node =
if Config.write_html then
let session = new_session node in
Printer.node_start_session node session
let finish_session node = if Config.write_html then Printer.node_finish_session node

326
infer/src/absint/PatternMatch.ml
Unescape View File

@ -16,10 +16,11 @@ module F = Format
let type_is_object typ =
match typ.Typ.desc with
| Tptr ({desc= Tstruct name}, _)
-> Typ.Name.equal name Typ.Name.Java.java_lang_object
| _
-> false
| Tptr ({desc= Tstruct name}, _) ->
Typ.Name.equal name Typ.Name.Java.java_lang_object
| _ ->
false
let java_proc_name_with_class_method pn_java class_with_path method_name =
try
@ -27,70 +28,81 @@ let java_proc_name_with_class_method pn_java class_with_path method_name =
&& String.equal (Typ.Procname.java_get_method pn_java) method_name
with _ -> false
(** Holds iff the predicate holds on a supertype of the named type, including the type itself *)
let rec supertype_exists tenv pred name =
match Tenv.lookup tenv name with
| Some ({supers} as struct_typ)
-> pred name struct_typ || List.exists ~f:(fun name -> supertype_exists tenv pred name) supers
| None
-> false
| Some ({supers} as struct_typ) ->
pred name struct_typ || List.exists ~f:(fun name -> supertype_exists tenv pred name) supers
| None ->
false
let rec supertype_find_map_opt tenv f name =
match f name with
| None -> (
match Tenv.lookup tenv name with
| Some {supers}
-> List.find_map ~f:(supertype_find_map_opt tenv f) supers
| None
-> None )
| result
-> result
| Some {supers} ->
List.find_map ~f:(supertype_find_map_opt tenv f) supers
| None ->
None )
| result ->
result
let is_immediate_subtype tenv this_type_name super_type_name =
match Tenv.lookup tenv this_type_name with
| Some {supers}
-> List.exists ~f:(Typ.Name.equal super_type_name) supers
| None
-> false
| Some {supers} ->
List.exists ~f:(Typ.Name.equal super_type_name) supers
| None ->
false
(** return true if [typ0] <: [typ1] *)
let is_subtype tenv name0 name1 =
Typ.Name.equal name0 name1
|| supertype_exists tenv (fun name _ -> Typ.Name.equal name name1) name0
let is_subtype_of_str tenv cn1 classname_str =
let typename = Typ.Name.Java.from_string classname_str in
is_subtype tenv cn1 typename
(** The type the method is invoked on *)
let get_this_type proc_attributes =
match proc_attributes.ProcAttributes.formals with (_, t) :: _ -> Some t | _ -> None
let type_get_direct_supertypes tenv (typ: Typ.t) =
match typ.desc with
| Tptr ({desc= Tstruct name}, _) | Tstruct name -> (
match Tenv.lookup tenv name with Some {supers} -> supers | None -> [] )
| _
-> []
| _ ->
[]
let type_get_class_name {Typ.desc} =
match desc with Typ.Tptr (typ, _) -> Typ.name typ | _ -> None
let type_get_annotation tenv (typ: Typ.t) : Annot.Item.t option =
match typ.desc with
| Tptr ({desc= Tstruct name}, _) | Tstruct name -> (
match Tenv.lookup tenv name with Some {annots} -> Some annots | None -> None )
| _
-> None
| _ ->
None
let rec get_type_name {Typ.desc} =
match desc with
| Typ.Tstruct name
-> Typ.Name.name name
| Typ.Tptr (t, _)
-> get_type_name t
| _
-> "_"
| Typ.Tstruct name ->
Typ.Name.name name
| Typ.Tptr (t, _) ->
get_type_name t
| _ ->
"_"
let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string option =
match typ.desc with
@ -98,74 +110,76 @@ let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string
match Tenv.lookup tenv name with
| Some {fields} -> (
match List.find ~f:(function fn, _, _ -> Typ.Fieldname.equal fn fieldname) fields with
| Some (_, ft, _)
-> Some (get_type_name ft)
| None
-> None )
| None
-> None )
| _
-> None
| Some (_, ft, _) ->
Some (get_type_name ft)
| None ->
None )
| None ->
None )
| _ ->
None
let java_get_const_type_name (const: Const.t) : string =
match const with
| Const.Cstr _
-> "java.lang.String"
| Const.Cint _
-> "java.lang.Integer"
| Const.Cfloat _
-> "java.lang.Double"
| _
-> "_"
| Const.Cstr _ ->
"java.lang.String"
| Const.Cint _ ->
"java.lang.Integer"
| Const.Cfloat _ ->
"java.lang.Double"
| _ ->
"_"
let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : string list =
(* Is this the node creating ivar? *)
let rec initializes_array instrs =
match instrs with
| (Sil.Call (Some (t1, _), Exp.Const Const.Cfun pn, _, _, _))
:: (Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _)) :: is
-> Pvar.equal ivar iv && Ident.equal t1 t2
:: (Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _)) :: is ->
Pvar.equal ivar iv && Ident.equal t1 t2
&& Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__new_array")
|| initializes_array is
| _ :: is
-> initializes_array is
| _
-> false
| _ :: is ->
initializes_array is
| _ ->
false
in
(* Get the type name added to ivar or None *)
let added_type_name node =
let rec nvar_type_name nvar instrs =
match instrs with
| (Sil.Load (nv, Exp.Lfield (_, id, t), _, _)) :: _ when Ident.equal nv nvar
-> get_field_type_name tenv t id
| (Sil.Load (nv, _, t, _)) :: _ when Ident.equal nv nvar
-> Some (get_type_name t)
| _ :: is
-> nvar_type_name nvar is
| _
-> None
| (Sil.Load (nv, Exp.Lfield (_, id, t), _, _)) :: _ when Ident.equal nv nvar ->
get_field_type_name tenv t id
| (Sil.Load (nv, _, t, _)) :: _ when Ident.equal nv nvar ->
Some (get_type_name t)
| _ :: is ->
nvar_type_name nvar is
| _ ->
None
in
let rec added_nvar array_nvar instrs =
match instrs with
| (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Var nvar, _)) :: _
when Ident.equal iv array_nvar
-> nvar_type_name nvar (Procdesc.Node.get_instrs node)
when Ident.equal iv array_nvar ->
nvar_type_name nvar (Procdesc.Node.get_instrs node)
| (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Const c, _)) :: _
when Ident.equal iv array_nvar
-> Some (java_get_const_type_name c)
| _ :: is
-> added_nvar array_nvar is
| _
-> None
when Ident.equal iv array_nvar ->
Some (java_get_const_type_name c)
| _ :: is ->
added_nvar array_nvar is
| _ ->
None
in
let rec array_nvar instrs =
match instrs with
| (Sil.Load (nv, Exp.Lvar iv, _, _)) :: _ when Pvar.equal iv ivar
-> added_nvar nv instrs
| _ :: is
-> array_nvar is
| _
-> None
| (Sil.Load (nv, Exp.Lvar iv, _, _)) :: _ when Pvar.equal iv ivar ->
added_nvar nv instrs
| _ :: is ->
array_nvar is
| _ ->
None
in
array_nvar (Procdesc.Node.get_instrs node)
in
@ -176,59 +190,67 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str
match Procdesc.Node.get_preds node with
| [n] -> (
match added_type_name node with Some name -> name :: type_names n | None -> type_names n )
| _
-> raise Not_found
| _ ->
raise Not_found
in
List.rev (type_names call_node)
let has_formal_proc_argument_type_names proc_desc argument_type_names =
let formals = Procdesc.get_formals proc_desc in
let equal_formal_arg (_, typ) arg_type_name = String.equal (get_type_name typ) arg_type_name in
Int.equal (List.length formals) (List.length argument_type_names)
&& List.for_all2_exn ~f:equal_formal_arg formals argument_type_names
let has_formal_method_argument_type_names cfg pname_java argument_type_names =
has_formal_proc_argument_type_names cfg
(Typ.Procname.java_get_class_name pname_java :: argument_type_names)
let is_getter pname_java =
Str.string_match (Str.regexp "get*") (Typ.Procname.java_get_method pname_java) 0
let is_setter pname_java =
Str.string_match (Str.regexp "set*") (Typ.Procname.java_get_method pname_java) 0
(** Returns the signature of a field access (class name, field name, field type name) *)
let get_java_field_access_signature = function
| Sil.Load (_, Exp.Lfield (_, fn, ft), bt, _)
-> Some (get_type_name bt, Typ.Fieldname.java_get_field fn, get_type_name ft)
| _
-> None
| Sil.Load (_, Exp.Lfield (_, fn, ft), bt, _) ->
Some (get_type_name bt, Typ.Fieldname.java_get_field fn, get_type_name ft)
| _ ->
None
(** Returns the formal signature (class name, method name,
argument type names and return type name) *)
let get_java_method_call_formal_signature = function
| Sil.Call (_, Exp.Const Const.Cfun pn, (_, tt) :: args, _, _) -> (
match pn with
| Typ.Procname.Java pn_java
-> let arg_names = List.map ~f:(function _, t -> get_type_name t) args in
| Typ.Procname.Java pn_java ->
let arg_names = List.map ~f:(function _, t -> get_type_name t) args in
let rt_name = Typ.Procname.java_get_return_type pn_java in
let m_name = Typ.Procname.java_get_method pn_java in
Some (get_type_name tt, m_name, arg_names, rt_name)
| _
-> None )
| _
-> None
| _ ->
None )
| _ ->
None
let type_is_class typ =
match typ.Typ.desc with
| Tptr ({desc= Tstruct _}, _)
-> true
| Tptr ({desc= Tarray _}, _)
-> true
| Tstruct _
-> true
| _
-> false
| Tptr ({desc= Tstruct _}, _) ->
true
| Tptr ({desc= Tarray _}, _) ->
true
| Tstruct _ ->
true
| _ ->
false
let initializer_classes =
List.map ~f:Typ.Name.Java.from_string
@ -239,6 +261,7 @@ let initializer_classes =
; "android.support.v4.app.Fragment"
; "junit.framework.TestCase" ]
let initializer_methods = ["onActivityCreated"; "onAttach"; "onCreate"; "onCreateView"; "setUp"]
(** Check if the type has in its supertypes from the initializer_classes list. *)
@ -247,59 +270,62 @@ let type_has_initializer (tenv: Tenv.t) (t: Typ.t) : bool =
List.mem ~equal:Typ.Name.equal initializer_classes typename
in
match t.desc with
| Typ.Tstruct name | Tptr ({desc= Tstruct name}, _)
-> supertype_exists tenv is_initializer_class name
| _
-> false
| Typ.Tstruct name | Tptr ({desc= Tstruct name}, _) ->
supertype_exists tenv is_initializer_class name
| _ ->
false
(** Check if the method is one of the known initializer methods. *)
let method_is_initializer (tenv: Tenv.t) (proc_attributes: ProcAttributes.t) : bool =
match get_this_type proc_attributes with
| Some this_type
-> if type_has_initializer tenv this_type then
| Some this_type ->
if type_has_initializer tenv this_type then
match proc_attributes.ProcAttributes.proc_name with
| Typ.Procname.Java pname_java
-> let mname = Typ.Procname.java_get_method pname_java in
| Typ.Procname.Java pname_java ->
let mname = Typ.Procname.java_get_method pname_java in
List.exists ~f:(String.equal mname) initializer_methods
| _
-> false
| _ ->
false
else false
| None
-> false
| None ->
false
(** Get the vararg values by looking for array assignments to the pvar. *)
let java_get_vararg_values node pvar idenv =
let values = ref [] in
let do_instr = function
| Sil.Store (Exp.Lindex (array_exp, _), _, content_exp, _)
when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv array_exp)
-> (* Each vararg argument is an assigment to a pvar denoting an array of objects. *)
when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv array_exp) ->
(* Each vararg argument is an assigment to a pvar denoting an array of objects. *)
values := content_exp :: !values
| _
-> ()
| _ ->
()
in
let do_node n = List.iter ~f:do_instr (Procdesc.Node.get_instrs n) in
let () =
match Errdesc.find_program_variable_assignment node pvar with
| Some (node', _)
-> Procdesc.iter_slope_range do_node node' node
| None
-> ()
| Some (node', _) ->
Procdesc.iter_slope_range do_node node' node
| None ->
()
in
!values
let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttributes.t) list =
let res = ref [] in
let do_instruction _ instr =
match instr with
| Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) -> (
match resolve_attributes callee_pn with
| Some callee_attributes
-> if filter callee_pn callee_attributes then res := (callee_pn, callee_attributes) :: !res
| None
-> () )
| _
-> ()
| Some callee_attributes ->
if filter callee_pn callee_attributes then res := (callee_pn, callee_attributes) :: !res
| None ->
() )
| _ ->
()
in
let do_node node =
let instrs = Procdesc.Node.get_instrs node in
@ -309,47 +335,50 @@ let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttribute
List.iter ~f:do_node nodes ;
List.rev !res
let override_exists f tenv proc_name =
let rec super_type_exists tenv super_class_name =
let super_proc_name = Typ.Procname.replace_class proc_name super_class_name in
match Tenv.lookup tenv super_class_name with
| Some {methods; supers}
-> let is_override pname =
| Some {methods; supers} ->
let is_override pname =
Typ.Procname.equal pname super_proc_name && not (Typ.Procname.is_constructor pname)
in
List.exists ~f:(fun pname -> is_override pname && f pname) methods
|| List.exists ~f:(super_type_exists tenv) supers
| _
-> false
| _ ->
false
in
f proc_name
||
match proc_name with
| Typ.Procname.Java proc_name_java
-> let type_name =
| Typ.Procname.Java proc_name_java ->
let type_name =
Typ.Name.Java.from_string (Typ.Procname.java_get_class_name proc_name_java)
in
List.exists ~f:(super_type_exists tenv)
(type_get_direct_supertypes tenv (Typ.mk (Tstruct type_name)))
| _
-> false
| _ ->
false
(* Only java supported at the moment *)
let override_iter f tenv proc_name =
ignore (override_exists (fun pname -> f pname ; false) tenv proc_name)
(** return the set of instance fields that are assigned to a null literal in [procdesc] *)
let get_fields_nullified procdesc =
(* walk through the instructions and look for instance fields that are assigned to null *)
let collect_nullified_flds (nullified_flds, this_ids) _ = function
| Sil.Store (Exp.Lfield (Exp.Var lhs, fld, _), _, rhs, _)
when Exp.is_null_literal rhs && Ident.IdentSet.mem lhs this_ids
-> (Typ.Fieldname.Set.add fld nullified_flds, this_ids)
| Sil.Load (id, rhs, _, _) when Exp.is_this rhs
-> (nullified_flds, Ident.IdentSet.add id this_ids)
| _
-> (nullified_flds, this_ids)
when Exp.is_null_literal rhs && Ident.IdentSet.mem lhs this_ids ->
(Typ.Fieldname.Set.add fld nullified_flds, this_ids)
| Sil.Load (id, rhs, _, _) when Exp.is_this rhs ->
(nullified_flds, Ident.IdentSet.add id this_ids)
| _ ->
(nullified_flds, this_ids)
in
let nullified_flds, _ =
Procdesc.fold_instrs collect_nullified_flds (Typ.Fieldname.Set.empty, Ident.IdentSet.empty)
@ -357,10 +386,12 @@ let get_fields_nullified procdesc =
in
nullified_flds
(** Checks if the exception is an unchecked exception *)
let is_runtime_exception tenv typename =
is_subtype_of_str tenv typename "java.lang.RuntimeException"
(** Checks if the class name is a Java exception *)
let is_exception tenv typename = is_subtype_of_str tenv typename "java.lang.Exception"
@ -370,31 +401,34 @@ let is_throwable tenv typename = is_subtype_of_str tenv typename "java.lang.Thro
(** tests whether any class attributes (e.g., @ThreadSafe) pass check of first argument,
including for supertypes*)
let check_class_attributes check tenv = function
| Typ.Procname.Java java_pname
-> let check_class_annots _ {Typ.Struct.annots} = check annots in
| Typ.Procname.Java java_pname ->
let check_class_annots _ {Typ.Struct.annots} = check annots in
supertype_exists tenv check_class_annots (Typ.Procname.java_get_class_type_name java_pname)
| _
-> false
| _ ->
false
(** tests whether any class attributes (e.g., @ThreadSafe) pass check of first argument,
for the current class only*)
let check_current_class_attributes check tenv = function
| Typ.Procname.Java java_pname -> (
match Tenv.lookup tenv (Typ.Procname.java_get_class_type_name java_pname) with
| Some struct_typ
-> check struct_typ.annots
| _
-> false )
| _
-> false
| Some struct_typ ->
check struct_typ.annots
| _ ->
false )
| _ ->
false
(** find superclasss with attributes (e.g., @ThreadSafe), including current class*)
let rec find_superclasses_with_attributes check tenv tname =
match Tenv.lookup tenv tname with
| Some struct_typ
-> let result_from_supers =
| Some struct_typ ->
let result_from_supers =
List.concat (List.map ~f:(find_superclasses_with_attributes check tenv) struct_typ.supers)
in
if check struct_typ.annots then tname :: result_from_supers else result_from_supers
| _
-> []
| _ ->
[]

31
infer/src/absint/ProcCfg.ml
Unescape View File

@ -77,12 +77,14 @@ module InstrNode = struct
let n = Procdesc.Node.compare_id id1 id2 in
if n <> 0 then n else compare_index index1 index2
let pp_id fmt (id, index) =
match index with
| Node_index
-> Procdesc.Node.pp_id fmt id
| Instr_index i
-> F.fprintf fmt "(%a: %d)" Procdesc.Node.pp_id id i
| Node_index ->
Procdesc.Node.pp_id fmt id
| Instr_index i ->
F.fprintf fmt "(%a: %d)" Procdesc.Node.pp_id id i
end
module type S = sig
@ -202,6 +204,7 @@ module Exceptional = struct
in
(pdesc, exceptional_preds)
let instrs = Procdesc.Node.get_instrs
let instr_ids n = List.map ~f:(fun i -> (i, None)) (instrs n)
@ -216,26 +219,29 @@ module Exceptional = struct
try Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map
with Not_found -> []
(** get all normal and exceptional successors of [n]. *)
let succs t n =
let normal_succs = normal_succs t n in
match exceptional_succs t n with
| []
-> normal_succs
| exceptional_succs
-> normal_succs @ exceptional_succs |> List.sort ~cmp:Procdesc.Node.compare
| [] ->
normal_succs
| exceptional_succs ->
normal_succs @ exceptional_succs |> List.sort ~cmp:Procdesc.Node.compare
|> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal
(** get all normal and exceptional predecessors of [n]. *)
let preds t n =
let normal_preds = normal_preds t n in
match exceptional_preds t n with
| []
-> normal_preds
| exceptional_preds
-> normal_preds @ exceptional_preds |> List.sort ~cmp:Procdesc.Node.compare
| [] ->
normal_preds
| exceptional_preds ->
normal_preds @ exceptional_preds |> List.sort ~cmp:Procdesc.Node.compare
|> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal
let proc_desc (pdesc, _) = pdesc
let start_node (pdesc, _) = Procdesc.get_start_node pdesc
@ -285,6 +291,7 @@ struct
let id = (Procdesc.Node.get_id t, Instr_index i) in
(instr, Some id))
(instrs t)
end
module NodeIdMap (CFG : S) = Caml.Map.Make (struct

5
infer/src/absint/Scheduler.ml
Unescape View File

@ -58,16 +58,19 @@ module ReversePostorder (CFG : ProcCfg.S) = struct
let compute_priority cfg node visited_preds =
List.length (CFG.preds cfg node) - IdSet.cardinal visited_preds
let make cfg node =
let visited_preds = IdSet.empty in
let priority = compute_priority cfg node visited_preds in
{node; visited_preds; priority}
(* add [node_id] to the visited preds for [t] *)
let add_visited_pred cfg t node_id =
let visited_preds' = IdSet.add node_id t.visited_preds in
let priority' = compute_priority cfg t.node visited_preds' in
{t with visited_preds= visited_preds'; priority= priority'}
end
type t = {worklist: WorkUnit.t M.t; cfg: CFG.t}
@ -88,6 +91,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct
let new_worklist = List.fold ~f:schedule_succ ~init:t.worklist (CFG.succs t.cfg node) in
{t with worklist= new_worklist}
(* remove and return the node with the highest priority (note that smaller integers have higher
priority), the ids of its visited predecessors, and new schedule *)
(* TODO: could do this slightly more efficiently by keeping a list of priority zero nodes for
@ -109,5 +113,6 @@ module ReversePostorder (CFG : ProcCfg.S) = struct
Some (node, WorkUnit.visited_preds max_priority_work, t')
with Not_found -> None
let empty cfg = {worklist= M.empty; cfg}
end

9
infer/src/absint/Summary.ml
Unescape View File

@ -32,8 +32,9 @@ module Make (P : Payload) : S with type payload = P.payload = struct
let read_summary caller_pdesc callee_pname =
match Ondemand.analyze_proc_name caller_pdesc callee_pname with
| None
-> None
| Some summary
-> P.read_payload summary
| None ->
None
| Some summary ->
P.read_payload summary
end

9
infer/src/absint/Var.ml
Unescape View File

@ -30,10 +30,11 @@ let is_return = function ProgramVar pvar -> Pvar.is_return pvar | LogicalVar _ -
let is_footprint = function ProgramVar _ -> false | LogicalVar id -> Ident.is_footprint id
let pp fmt = function
| ProgramVar pv
-> Pvar.pp Pp.text fmt pv
| LogicalVar id
-> Ident.pp Pp.text fmt id
| ProgramVar pv ->
Pvar.pp Pp.text fmt pv
| LogicalVar id ->
Ident.pp Pp.text fmt id
module Map = PrettyPrintable.MakePPMap (struct
type nonrec t = t

3
infer/src/atd/jbuild.in
Unescape View File

@ -12,5 +12,6 @@ let cflags = common_cflags @ ["-w"; "-27-32-34-35-39"]
(libraries (atdgen))
))
|}
(String.concat " " cflags) (String.concat " " common_optflags)
(String.concat " " cflags)
(String.concat " " common_optflags)
|> Jbuild_plugin.V1.send

264
infer/src/backend/Attribute.ml
Unescape View File

@ -23,38 +23,42 @@ let add tenv ?(footprint= false) ?(polarity= true) prop attr args =
Prop.prop_atom_and tenv ~footprint prop
(if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args))
let attributes_in_same_category attr1 attr2 =
let cat1 = PredSymb.to_category attr1 in
let cat2 = PredSymb.to_category attr2 in
PredSymb.equal_category cat1 cat2
(** Replace an attribute associated to the expression *)
let add_or_replace_check_changed tenv check_attribute_change prop atom =
match atom with
| Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0))
-> let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in
| Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) ->
let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in
let _, nexp = List.hd_exn pairs in
(* len exps0 > 0 by match *)
let atom_map = function
| Sil.Apred (att, exp :: _)
| Anpred (att, exp :: _)
when Exp.equal nexp exp && attributes_in_same_category att att0
-> check_attribute_change att att0 ; atom
| atom'
-> atom'
when Exp.equal nexp exp && attributes_in_same_category att att0 ->
check_attribute_change att att0 ; atom
| atom' ->
atom'
in
let pi = prop.Prop.pi in
let pi' = IList.map_changed atom_map pi in
if phys_equal pi pi' then Prop.prop_atom_and tenv prop atom
else Prop.normalize tenv (Prop.set prop ~pi:pi')
| _
-> prop
| _ ->
prop
let add_or_replace tenv prop atom =
(* wrapper for the most common case: do nothing *)
let check_attr_changed _ _ = () in
add_or_replace_check_changed tenv check_attr_changed prop atom
(** Get all the attributes of the prop *)
let get_all (prop: 'a Prop.t) =
let res = ref [] in
@ -62,34 +66,38 @@ let get_all (prop: 'a Prop.t) =
List.iter ~f:do_atom prop.pi ;
List.rev !res
(** Get all the attributes of the prop *)
let get_for_symb prop att =
List.filter
~f:(function Sil.Apred (att', _) | Anpred (att', _) -> PredSymb.equal att' att | _ -> false)
prop.Prop.pi
(** Get the attribute associated to the expression, if any *)
let get_for_exp tenv (prop: 'a Prop.t) exp =
let nexp = Prop.exp_normalize_prop tenv prop exp in
let atom_get_attr attributes atom =
match atom with
| (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp
-> atom :: attributes
| _
-> attributes
| (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp ->
atom :: attributes
| _ ->
attributes
in
List.fold ~f:atom_get_attr ~init:[] prop.pi
let get tenv prop exp category =
let atts = get_for_exp tenv prop exp in
List.find
~f:(function
| Sil.Apred (att, _) | Anpred (att, _)
-> PredSymb.equal_category (PredSymb.to_category att) category
| _
-> false)
| Sil.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category
| _ ->
false)
atts
let get_undef tenv prop exp = get tenv prop exp ACundef
let get_resource tenv prop exp = get tenv prop exp ACresource
@ -112,11 +120,13 @@ let has_dangling_uninit tenv prop exp =
~f:(function Sil.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false)
la
let filter_atoms tenv ~f prop =
let pi0 = prop.Prop.pi in
let pi1 = IList.filter_changed f pi0 in
if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1)
let remove tenv prop atom =
if is_pred atom then
let natom = Prop.atom_normalize_prop tenv prop atom in
@ -124,74 +134,80 @@ let remove tenv prop atom =
filter_atoms tenv ~f prop
else prop
(** Remove an attribute from all the atoms in the heap *)
let remove_for_attr tenv prop att0 =
let f = function
| Sil.Apred (att, _) | Anpred (att, _)
-> not (PredSymb.equal att0 att)
| _
-> true
| Sil.Apred (att, _) | Anpred (att, _) ->
not (PredSymb.equal att0 att)
| _ ->
true
in
filter_atoms tenv ~f prop
let remove_resource tenv ra_kind ra_res =
let f = function
| Sil.Apred (Aresource res_action, _)
-> PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0
| Sil.Apred (Aresource res_action, _) ->
PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0
|| PredSymb.compare_resource res_action.ra_res ra_res <> 0
| _
-> true
| _ ->
true
in
filter_atoms tenv ~f
(** Apply f to every resource attribute in the prop *)
let map_resource tenv prop f =
let attribute_map e = function
| PredSymb.Aresource ra
-> PredSymb.Aresource (f e ra)
| att
-> att
| PredSymb.Aresource ra ->
PredSymb.Aresource (f e ra)
| att ->
att
in
let atom_map = function
| Sil.Apred (att, ([e] as es))
-> Sil.Apred (attribute_map e att, es)
| Sil.Anpred (att, ([e] as es))
-> Sil.Anpred (attribute_map e att, es)
| atom
-> atom
| Sil.Apred (att, ([e] as es)) ->
Sil.Apred (attribute_map e att, es)
| Sil.Anpred (att, ([e] as es)) ->
Sil.Anpred (attribute_map e att, es)
| atom ->
atom
in
let pi0 = prop.Prop.pi in
let pi1 = IList.map_changed atom_map pi0 in
if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1)
(* Replace an attribute OBJC_NULL($n1) with OBJC_NULL(var) when var = $n1, and also sets $n1 =
0 *)
let replace_objc_null tenv prop lhs_exp rhs_exp =
match (get_objc_null tenv prop rhs_exp, rhs_exp) with
| Some atom, Exp.Var _
-> let prop = remove tenv prop atom in
| Some atom, Exp.Var _ ->
let prop = remove tenv prop atom in
let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop in
let natom = Sil.atom_replace_exp [(rhs_exp, lhs_exp)] atom in
add_or_replace tenv prop natom
| _
-> prop
| _ ->
prop
let rec nullify_exp_with_objc_null tenv prop exp =
match exp with
| Exp.BinOp (_, exp1, exp2)
-> let prop' = nullify_exp_with_objc_null tenv prop exp1 in
| Exp.BinOp (_, exp1, exp2) ->
let prop' = nullify_exp_with_objc_null tenv prop exp1 in
nullify_exp_with_objc_null tenv prop' exp2
| Exp.UnOp (_, exp, _)
-> nullify_exp_with_objc_null tenv prop exp
| Exp.UnOp (_, exp, _) ->
nullify_exp_with_objc_null tenv prop exp
| Exp.Var _ -> (
match get_objc_null tenv prop exp with
| Some atom
-> let prop' = remove tenv prop atom in
| Some atom ->
let prop' = remove tenv prop atom in
Prop.conjoin_eq tenv exp Exp.zero prop'
| _
-> prop )
| _
-> prop
| _ ->
prop )
| _ ->
prop
(** mark Exp.Var's or Exp.Lvar's as undefined
The annotations of the return type of the method get propagated to the return id,
@ -201,23 +217,24 @@ let mark_vars_as_undefined tenv prop ~ret_exp_opt ~undefined_actuals_by_ref call
loc path_pos =
let mark_var_as_undefined ~annot exp prop =
match exp with
| Exp.Var _ | Lvar _
-> let att_undef = PredSymb.Aundef (callee_pname, annot, loc, path_pos) in
| Exp.Var _ | Lvar _ ->
let att_undef = PredSymb.Aundef (callee_pname, annot, loc, path_pos) in
add_or_replace tenv prop (Apred (att_undef, [exp]))
| _
-> prop
| _ ->
prop
in
let prop_with_ret_attr =
match ret_exp_opt with
| Some ret_exp
-> mark_var_as_undefined ~annot:ret_annots ret_exp prop
| None
-> prop
| Some ret_exp ->
mark_var_as_undefined ~annot:ret_annots ret_exp prop
| None ->
prop
in
List.fold
~f:(fun prop id -> mark_var_as_undefined ~annot:[] id prop)
~init:prop_with_ret_attr undefined_actuals_by_ref
(** type for arithmetic problems *)
type arith_problem =
(* division by zero *)
@ -232,68 +249,69 @@ let find_arithmetic_problem tenv proc_node_session prop exp =
let res = ref prop in
let check_zero e =
match Prop.exp_normalize_prop tenv prop e with
| Exp.Const c when Const.iszero_int_float c
-> true
| _
-> res := add_or_replace tenv !res (Apred (Adiv0 proc_node_session, [e])) ;
| Exp.Const c when Const.iszero_int_float c ->
true
| _ ->
res := add_or_replace tenv !res (Apred (Adiv0 proc_node_session, [e])) ;
false
in
let rec walk = function
| Exp.Var _
-> ()
| Exp.Var _ ->
()
| Exp.UnOp
( Unop.Neg
, e
, Some
( {Typ.desc= Tint (Typ.IUChar | Typ.IUInt | Typ.IUShort | Typ.IULong | Typ.IULongLong)}
as typ ) )
-> uminus_unsigned := (e, typ) :: !uminus_unsigned
| Exp.UnOp (_, e, _)
-> walk e
| Exp.BinOp (op, e1, e2)
-> if Binop.equal op Binop.Div || Binop.equal op Binop.Mod then exps_divided
as typ ) ) ->
uminus_unsigned := (e, typ) :: !uminus_unsigned
| Exp.UnOp (_, e, _) ->
walk e
| Exp.BinOp (op, e1, e2) ->
if Binop.equal op Binop.Div || Binop.equal op Binop.Mod then exps_divided
:= e2 :: !exps_divided ;
walk e1 ;
walk e2
| Exp.Exn _
-> ()
| Exp.Closure _
-> ()
| Exp.Const _
-> ()
| Exp.Cast (_, e)
-> walk e
| Exp.Lvar _
-> ()
| Exp.Lfield (e, _, _)
-> walk e
| Exp.Lindex (e1, e2)
-> walk e1 ; walk e2
| Exp.Sizeof {dynamic_length= None}
-> ()
| Exp.Sizeof {dynamic_length= Some len}
-> walk len
| Exp.Exn _ ->
()
| Exp.Closure _ ->
()
| Exp.Const _ ->
()
| Exp.Cast (_, e) ->
walk e
| Exp.Lvar _ ->
()
| Exp.Lfield (e, _, _) ->
walk e
| Exp.Lindex (e1, e2) ->
walk e1 ; walk e2
| Exp.Sizeof {dynamic_length= None} ->
()
| Exp.Sizeof {dynamic_length= Some len} ->
walk len
in
walk exp ;
let problem_opt =
match (List.find ~f:check_zero !exps_divided, !uminus_unsigned) with
| Some e, _
-> Some (Div0 e)
| None, (e, t) :: _
-> Some (UminusUnsigned (e, t))
| None, []
-> None
| Some e, _ ->
Some (Div0 e)
| None, (e, t) :: _ ->
Some (UminusUnsigned (e, t))
| None, [] ->
None
in
(problem_opt, !res)
(** Deallocate the stack variables in [pvars], and replace them by normal variables.
Return the list of stack variables whose address was still present after deallocation. *)
let deallocate_stack_vars tenv (p: 'a Prop.t) pvars =
let filter = function
| Sil.Hpointsto (Exp.Lvar v, _, _)
-> List.exists ~f:(Pvar.equal v) pvars
| _
-> false
| Sil.Hpointsto (Exp.Lvar v, _, _) ->
List.exists ~f:(Pvar.equal v) pvars
| _ ->
false
in
let sigma_stack, sigma_other = List.partition_tf ~f:filter p.sigma in
let fresh_address_vars = ref [] in
@ -303,12 +321,12 @@ let deallocate_stack_vars tenv (p: 'a Prop.t) pvars =
let exp_replace =
List.map
~f:(function
| Sil.Hpointsto (Exp.Lvar v, _, _)
-> let freshv = Ident.create_fresh Ident.kprimed in
| Sil.Hpointsto (Exp.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars ;
(Exp.Lvar v, Exp.Var freshv)
| _
-> assert false)
| _ ->
assert false)
sigma_stack
in
let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in
@ -342,6 +360,7 @@ let deallocate_stack_vars tenv (p: 'a Prop.t) pvars =
let p''' = if changed then Prop.normalize tenv (Prop.set p'' ~pi:filtered_pi) else p'' in
(!stack_vars_address_in_post, List.fold ~f:(Prop.prop_atom_and tenv) ~init:p''' pi)
(** Input of this method is an exp in a prop. Output is a formal variable or path from a
formal variable that is equal to the expression,
or the OBJC_NULL attribute of the expression. *)
@ -353,40 +372,41 @@ let find_equal_formal_path tenv e prop =
else
let seen_hpreds = hpred :: seen_hpreds in
match res with
| Some _
-> res
| Some _ ->
res
| None ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _)
when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1)
-> Some (Exp.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _)
-> List.fold_right
when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) ->
Some (Exp.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) ->
List.fold_right
~f:(fun (field, strexp) res ->
match res with
| Some _
-> res
| Some _ ->
res
| None ->
match strexp with
| Sil.Eexp (exp2, _) when Exp.equal exp2 e -> (
match find_in_sigma exp1 seen_hpreds with
| Some vfs
-> Some (Exp.Lfield (vfs, field, Typ.mk Tvoid))
| None
-> None )
| _
-> None)
| Some vfs ->
Some (Exp.Lfield (vfs, field, Typ.mk Tvoid))
| None ->
None )
| _ ->
None)
fields ~init:None
| _
-> None)
| _ ->
None)
prop.Prop.sigma ~init:None
in
match find_in_sigma e [] with
| Some vfs
-> Some vfs
| Some vfs ->
Some vfs
| None ->
match get_objc_null tenv prop e with
| Some Apred (Aobjc_null, [_; vfs])
-> Some vfs
| _
-> None
| Some Apred (Aobjc_null, [_; vfs]) ->
Some vfs
| _ ->
None

641
infer/src/backend/BuiltinDefn.ml
View File

File diff suppressed because it is too large Load Diff

14
infer/src/backend/Differential.ml
Unescape View File

@ -20,21 +20,23 @@ let of_reports ~(current_report: Jsonbug_t.report) ~(previous_report: Jsonbug_t.
in
let fold_aux ~key:_ ~data (left, both, right) =
match data with
| `Left left'
-> (List.rev_append left' left, both, right)
| `Both (both', _)
-> (left, List.rev_append both' both, right)
| `Right right'
-> (left, both, List.rev_append right' right)
| `Left left' ->
(List.rev_append left' left, both, right)
| `Both (both', _) ->
(left, List.rev_append both' both, right)
| `Right right' ->
(left, both, List.rev_append right' right)
in
let introduced, preexisting, fixed =
Map.fold2 (to_map current_report) (to_map previous_report) ~f:fold_aux ~init:([], [], [])
in
{introduced; fixed; preexisting}
let to_files {introduced; fixed; preexisting} destdir =
Out_channel.write_all (destdir ^/ "introduced.json")
~data:(Jsonbug_j.string_of_report introduced) ;
Out_channel.write_all (destdir ^/ "fixed.json") ~data:(Jsonbug_j.string_of_report fixed) ;
Out_channel.write_all (destdir ^/ "preexisting.json")
~data:(Jsonbug_j.string_of_report preexisting)

96
infer/src/backend/DifferentialFilters.ml
Unescape View File

@ -29,22 +29,22 @@ module FileRenamings = struct
try
match assoc with
| `Assoc l
-> (
-> (
let current_opt = List.Assoc.find ~equal:String.equal l "current" in
let previous_opt = List.Assoc.find ~equal:String.equal l "previous" in
match (current_opt, previous_opt) with
| Some `String current, Some `String previous
-> {current; previous}
| None, _
-> raise (Yojson.Json_error "\"current\" field missing")
| Some _, None
-> raise (Yojson.Json_error "\"previous\" field missing")
| Some _, Some `String _
-> raise (Yojson.Json_error "\"current\" field is not a string")
| Some _, Some _
-> raise (Yojson.Json_error "\"previous\" field is not a string") )
| _
-> raise (Yojson.Json_error "not a record")
| Some `String current, Some `String previous ->
{current; previous}
| None, _ ->
raise (Yojson.Json_error "\"current\" field missing")
| Some _, None ->
raise (Yojson.Json_error "\"previous\" field missing")
| Some _, Some `String _ ->
raise (Yojson.Json_error "\"current\" field is not a string")
| Some _, Some _ ->
raise (Yojson.Json_error "\"previous\" field is not a string") )
| _ ->
raise (Yojson.Json_error "not a record")
with Yojson.Json_error err ->
L.(die UserError)
"Error parsing file renamings: %s@\nExpected JSON object of the following form: '%s', but instead got: '%s'"
@ -52,10 +52,11 @@ module FileRenamings = struct
(Yojson.Basic.to_string assoc)
in
match j with
| `List json_renamings
-> List.map ~f:renaming_of_assoc json_renamings
| _
-> L.(die UserError) "Expected JSON list but got '%s'" input
| `List json_renamings ->
List.map ~f:renaming_of_assoc json_renamings
| _ ->
L.(die UserError) "Expected JSON list but got '%s'" input
let from_json_file file : t = from_json (In_channel.read_all file)
@ -63,12 +64,14 @@ module FileRenamings = struct
let r = List.find ~f:(fun r -> String.equal current r.current) t in
Option.map ~f:(fun r -> r.previous) r
let pp fmt t =
let pp_tuple fmt {current; previous} =
Format.fprintf fmt "{\"current\": \"%s\", \"previous\": \"%s\"}" current previous
in
Format.fprintf fmt "[%a]" (Pp.comma_seq pp_tuple) t
module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY = struct
let from_renamings = from_renamings
@ -82,32 +85,33 @@ end
intersection of [l1] and [l2] according to [cmd] and additionally satisfy [pred], and [lN'] is
[lN] minus [dups]. [dups] contains only one witness for each removed issue, taken from [l1]. *)
let relative_complements ~cmp ?(pred= fun _ -> true) l1 l2 =
let rec aux (out_l1, dups, out_l2 as out) in_l1 in_l2 =
let rec aux ((out_l1, dups, out_l2) as out) in_l1 in_l2 =
let is_last_seen_dup v = match dups with ld :: _ -> Int.equal (cmp ld v) 0 | [] -> false in
match (in_l1, in_l2) with
| i :: is, f :: fs when Int.equal (cmp i f) 0
-> (* i = f *)
| i :: is, f :: fs when Int.equal (cmp i f) 0 ->
(* i = f *)
if pred i then aux (out_l1, i :: dups, out_l2) is fs
else aux (i :: out_l1, dups, f :: out_l2) is fs
| i :: is, f :: _ when cmp i f < 0
-> (* i < f *)
| i :: is, f :: _ when cmp i f < 0 ->
(* i < f *)
let out_l1' = if is_last_seen_dup i then out_l1 else i :: out_l1 in
aux (out_l1', dups, out_l2) is in_l2
| _ :: _, f :: fs
-> (* i > f *)
| _ :: _, f :: fs ->
(* i > f *)
let out_l2' = if is_last_seen_dup f then out_l2 else f :: out_l2 in
aux (out_l1, dups, out_l2') in_l1 fs
| i :: is, [] when is_last_seen_dup i
-> aux out is in_l2
| [], f :: fs when is_last_seen_dup f
-> aux out in_l1 fs
| _, _
-> (List.rev_append in_l1 out_l1, dups, List.rev_append in_l2 out_l2)
| i :: is, [] when is_last_seen_dup i ->
aux out is in_l2
| [], f :: fs when is_last_seen_dup f ->
aux out in_l1 fs
| _, _ ->
(List.rev_append in_l1 out_l1, dups, List.rev_append in_l2 out_l2)
in
let l1_sorted = List.sort ~cmp l1 in
let l2_sorted = List.sort ~cmp l2 in
aux ([], [], []) l1_sorted l2_sorted
type issue_file_with_renaming = Jsonbug_t.jsonbug * string option
let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differential.t =
@ -118,7 +122,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ
in
String.compare f1 f2
in
let cmp (issue1, _ as issue_with_previous_file1) (issue2, _ as issue_with_previous_file2) =
let cmp ((issue1, _) as issue_with_previous_file1) ((issue2, _) as issue_with_previous_file2) =
[%compare : int * string * issue_file_with_renaming]
(issue1.Jsonbug_t.key, issue1.Jsonbug_t.bug_type, issue_with_previous_file1)
(issue2.Jsonbug_t.key, issue2.Jsonbug_t.bug_type, issue_with_previous_file2)
@ -142,6 +146,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ
in
{introduced; fixed; preexisting}
let java_anon_class_pattern = Str.regexp "\\$[0-9]+"
type procedure_id = string
@ -164,12 +169,14 @@ let compare_procedure_id pid1 pid2 =
in
String.compare pid1_norm_trimmed pid2_norm_trimmed
let value_of_qualifier_tag qts tag =
match List.find ~f:(fun elem -> String.equal elem.Jsonbug_t.tag tag) qts with
| Some qt
-> Some qt.Jsonbug_t.value
| None
-> None
| Some qt ->
Some qt.Jsonbug_t.value
| None ->
None
type file_extension = string [@@deriving compare]
@ -206,10 +213,10 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t =
let pred (issue: Jsonbug_t.jsonbug) =
let is_java_file () =
match extension issue.file with
| Some ext
-> String.equal (String.lowercase ext) "java"
| None
-> false
| Some ext ->
String.equal (String.lowercase ext) "java"
| None ->
false
in
let has_anonymous_class_token () =
try
@ -224,11 +231,12 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t =
in
{introduced; fixed; preexisting= preexisting @ diff.preexisting}
(* Strip issues whose paths are not among those we're interested in *)
let interesting_paths_filter (interesting_paths: SourceFile.t list option) =
match interesting_paths with
| Some (paths: SourceFile.t list)
-> let interesting_paths_set =
| Some (paths: SourceFile.t list) ->
let interesting_paths_set =
paths
|> List.filter_map ~f:(fun p ->
if not (SourceFile.is_invalid p) && SourceFile.is_under_project_root p then
@ -240,8 +248,9 @@ let interesting_paths_filter (interesting_paths: SourceFile.t list option) =
List.filter
~f:(fun issue -> String.Set.mem interesting_paths_set issue.Jsonbug_t.file)
report
| None
-> Fn.id
| None ->
Fn.id
let do_filter (diff: Differential.t) (renamings: FileRenamings.t) ~(skip_duplicated_types: bool)
~(interesting_paths: SourceFile.t list option) : Differential.t =
@ -260,6 +269,7 @@ let do_filter (diff: Differential.t) (renamings: FileRenamings.t) ~(skip_duplica
; fixed= apply_paths_filter_if_needed `Fixed diff'.fixed
; preexisting= apply_paths_filter_if_needed `Preexisting diff'.preexisting }
module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY = struct
let relative_complements = relative_complements

67
infer/src/backend/InferAnalyze.ml
Unescape View File

@ -21,7 +21,8 @@ let analyze_exe_env_tasks cluster exe_env : Tasks.t =
let biabduction_only = Config.equal_analyzer Config.analyzer Config.BiAbduction in
if biabduction_only then
(* run the biabduction analysis only *)
Tasks.create (Interproc.do_analysis_closures exe_env)
Tasks.create
(Interproc.do_analysis_closures exe_env)
~continuation:
( if Config.write_html || Config.developer_mode then
Some
@ -37,6 +38,7 @@ let analyze_exe_env_tasks cluster exe_env : Tasks.t =
Callbacks.iterate_callbacks call_graph exe_env ;
if Config.write_html then Printer.write_all_html_files cluster) ]
(** Create tasks to analyze a cluster *)
let analyze_cluster_tasks cluster_num (cluster: Cluster.t) : Tasks.t =
let exe_env = Exe_env.from_cluster cluster in
@ -46,6 +48,7 @@ let analyze_cluster_tasks cluster_num (cluster: Cluster.t) : Tasks.t =
"@\nProcessing cluster #%d with %d procedures@." (cluster_num + 1) num_procs ;
analyze_exe_env_tasks cluster exe_env
let analyze_cluster cluster_num cluster = Tasks.run (analyze_cluster_tasks cluster_num cluster)
let output_json_makefile_stats clusters =
@ -60,13 +63,15 @@ let output_json_makefile_stats clusters =
let f = Out_channel.create (Filename.concat Config.results_dir Config.proc_stats_filename) in
Yojson.Basic.pretty_to_channel f file_stats
let process_cluster_cmdline fname =
match Cluster.load_from_file (DB.filename_from_string fname) with
| None
-> (if Config.keep_going then L.internal_error else L.die InternalError)
| None ->
(if Config.keep_going then L.internal_error else L.die InternalError)
"Cannot find cluster file %s@." fname
| Some (nr, cluster)
-> analyze_cluster (nr - 1) cluster
| Some (nr, cluster) ->
analyze_cluster (nr - 1) cluster
let print_legend () =
L.progress "Starting analysis...@\n" ;
@ -84,6 +89,7 @@ let print_legend () =
Config.log_analysis_recursion_timeout ) ;
L.progress "@\n@?"
let cluster_should_be_analyzed ~changed_files cluster =
let fname = DB.source_dir_to_string cluster in
(* whether [fname] is one of the [changed_files] *)
@ -105,33 +111,35 @@ let cluster_should_be_analyzed ~changed_files cluster =
modified
in
match is_changed_file with
| Some b
-> b
| None when Config.reactive_mode
-> check_modified ()
| None
-> true
| Some b ->
b
| None when Config.reactive_mode ->
check_modified ()
| None ->
true
let register_active_checkers () =
match Config.analyzer with
| Checkers | Crashcontext
-> RegisterCheckers.get_active_checkers () |> RegisterCheckers.register
| BiAbduction | CaptureOnly | CompileOnly | Linters
-> ()
| Checkers | Crashcontext ->
RegisterCheckers.get_active_checkers () |> RegisterCheckers.register
| BiAbduction | CaptureOnly | CompileOnly | Linters ->
()
let main ~changed_files ~makefile =
BuiltinDefn.init () ;
( match Config.modified_targets with
| Some file
-> MergeCapture.record_modified_targets_from_file file
| None
-> () ) ;
| Some file ->
MergeCapture.record_modified_targets_from_file file
| None ->
() ) ;
register_active_checkers () ;
match Config.cluster_cmdline with
| Some fname
-> process_cluster_cmdline fname
| None
-> if Config.allow_specs_cleanup then DB.Results_dir.clean_specs_dir () ;
| Some fname ->
process_cluster_cmdline fname
| None ->
if Config.allow_specs_cleanup then DB.Results_dir.clean_specs_dir () ;
let all_clusters = DB.find_source_dirs () in
let clusters_to_analyze =
List.filter ~f:(cluster_should_be_analyzed ~changed_files) all_clusters
@ -144,10 +152,10 @@ let main ~changed_files ~makefile =
(if Int.equal n_clusters_to_analyze 1 then "" else "s")
Config.results_dir ;
let is_java =
( lazy
(List.exists
~f:(fun cl -> DB.string_crc_has_extension ~ext:"java" (DB.source_dir_to_string cl))
all_clusters) )
lazy
(List.exists
~f:(fun cl -> DB.string_crc_has_extension ~ext:"java" (DB.source_dir_to_string cl))
all_clusters)
in
L.debug Analysis Quiet "Dynamic dispatch mode: %s@."
Config.(string_of_dynamic_dispatch dynamic_dispatch) ;
@ -164,7 +172,8 @@ let main ~changed_files ~makefile =
let aggregate_tasks = Tasks.aggregate ~size:Config.procedures_per_process tasks in
Tasks.Runner.start runner ~tasks:aggregate_tasks
in
List.iteri ~f:cluster_start_tasks clusters_to_analyze ; Tasks.Runner.complete runner )
List.iteri ~f:cluster_start_tasks clusters_to_analyze ;
Tasks.Runner.complete runner )
else if makefile <> "" then
ClusterMakefile.create_cluster_makefile clusters_to_analyze makefile
else (
@ -173,9 +182,11 @@ let main ~changed_files ~makefile =
L.progress "@\nAnalysis finished in %as@." Pp.elapsed_time () ) ;
output_json_makefile_stats clusters_to_analyze
let register_perf_stats_report () =
let stats_dir = Filename.concat Config.results_dir Config.backend_stats_dir_name in
let cluster = match Config.cluster_cmdline with Some cl -> "_" ^ cl | None -> "" in
let stats_base = Config.perf_stats_prefix ^ Filename.basename cluster ^ ".json" in
let stats_file = Filename.concat stats_dir stats_base in
PerfStats.register_report_at_exit stats_file

489
infer/src/backend/InferPrint.ml
Unescape View File

@ -13,7 +13,10 @@ module Hashtbl = Caml.Hashtbl
module L = Logging
module F = Format
let print_usage_exit err_s = L.user_error "Load Error: %s@\n@." err_s ; Config.print_usage_exit ()
let print_usage_exit err_s =
L.user_error "Load Error: %s@\n@." err_s ;
Config.print_usage_exit ()
(** return the list of the .specs files in the results dir and libs, if they're defined *)
let load_specfiles () =
@ -31,6 +34,7 @@ let load_specfiles () =
let result_specs_dir = DB.filename_to_string DB.Results_dir.specs_dir in
specs_files_in_dir result_specs_dir
(** Create and initialize latex file *)
let begin_latex_file fmt =
let author = "Infer " ^ Version.versionString in
@ -38,14 +42,17 @@ let begin_latex_file fmt =
let table_of_contents = true in
Latex.pp_begin fmt (author, title, table_of_contents)
let error_desc_to_csv_string error_desc =
let pp fmt = F.fprintf fmt "%a" Localise.pp_error_desc error_desc in
Escape.escape_csv (F.asprintf "%t" pp)
let error_advice_to_csv_string error_desc =
let pp fmt = F.fprintf fmt "%a" Localise.pp_error_advice error_desc in
Escape.escape_csv (F.asprintf "%t" pp)
let error_desc_to_plain_string error_desc =
let pp fmt = F.fprintf fmt "%a" Localise.pp_error_desc error_desc in
let s = F.asprintf "%t" pp in
@ -56,6 +63,7 @@ let error_desc_to_plain_string error_desc =
in
s
let error_desc_to_dotty_string error_desc = Localise.error_desc_get_dotty error_desc
let error_desc_to_xml_tags error_desc =
@ -63,6 +71,7 @@ let error_desc_to_xml_tags error_desc =
let subtree label contents = Io_infer.Xml.create_tree label [] [Io_infer.Xml.String contents] in
List.map ~f:(fun (tag, value) -> subtree tag (Escape.escape_xml value)) tags
let get_bug_hash (kind: string) (type_str: string) (procedure_id: string) (filename: string)
(node_key: int) (error_desc: Localise.error_desc) =
let qualifier_tag_call_procedure = Localise.error_desc_get_tag_call_procedure error_desc in
@ -76,29 +85,30 @@ let get_bug_hash (kind: string) (type_str: string) (procedure_id: string) (filen
, qualifier_tag_call_procedure
, qualifier_tag_value )
let exception_value = "exception"
let loc_trace_to_jsonbug_record trace_list ekind =
match ekind with
| Exceptions.Kinfo
-> []
| _
-> let tag_value_records_of_node_tag nt =
| Exceptions.Kinfo ->
[]
| _ ->
let tag_value_records_of_node_tag nt =
match nt with
| Errlog.Condition cond
-> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "condition"}
| Errlog.Condition cond ->
[ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "condition"}
; {Jsonbug_j.tag= Io_infer.Xml.tag_branch; value= Printf.sprintf "%B" cond} ]
| Errlog.Exception exn_name
-> let res = [{Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= exception_value}] in
| Errlog.Exception exn_name ->
let res = [{Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= exception_value}] in
let exn_str = Typ.Name.name exn_name in
if String.is_empty exn_str then res
else {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= exn_str} :: res
| Errlog.Procedure_start pname
-> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_start"}
| Errlog.Procedure_start pname ->
[ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_start"}
; {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= Typ.Procname.to_string pname}
; {Jsonbug_j.tag= Io_infer.Xml.tag_name_id; value= Typ.Procname.to_filename pname} ]
| Errlog.Procedure_end pname
-> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_end"}
| Errlog.Procedure_end pname ->
[ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_end"}
; {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= Typ.Procname.to_string pname}
; {Jsonbug_j.tag= Io_infer.Xml.tag_name_id; value= Typ.Procname.to_filename pname} ]
in
@ -114,6 +124,7 @@ let loc_trace_to_jsonbug_record trace_list ekind =
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
@ -175,6 +186,7 @@ let summary_values summary =
; vproof_coverage= Printf.sprintf "%2.2f" node_coverage
; vproof_trace= proof_trace }
module ProcsCsv = struct
(** Print the header of the procedures csv file, with column names *)
let pp_header fmt () =
@ -185,6 +197,7 @@ module ProcsCsv = struct
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
@ -201,6 +214,7 @@ module ProcsCsv = struct
pp "%d," sv.vweight ;
pp "%s," sv.vproof_coverage ;
pp "%s@\n" sv.vproof_trace
end
let should_report (issue_kind: Exceptions.err_kind) issue_type error_desc eclass =
@ -232,6 +246,7 @@ let should_report (issue_kind: Exceptions.err_kind) issue_type error_desc eclass
issue_bucket_is_high
else true
module IssuesCsv = struct
let csv_issues_id = ref 0
@ -243,15 +258,16 @@ module IssuesCsv = struct
Io_infer.Xml.tag_key Io_infer.Xml.tag_qualifier_tags Io_infer.Xml.tag_hash "bug_id"
"always_report" "advice"
let pp_issue fmt error_filter procname proc_loc_opt (key: Errlog.err_key)
(err_data: Errlog.err_data) =
let pp x = F.fprintf fmt x in
let source_file =
match proc_loc_opt with
| Some proc_loc
-> proc_loc.Location.file
| None
-> err_data.loc.Location.file
| Some proc_loc ->
proc_loc.Location.file
| None ->
err_data.loc.Location.file
in
if key.in_footprint && error_filter source_file key.err_desc key.err_name
&& should_report key.err_kind key.err_name key.err_desc err_data.err_class
@ -273,10 +289,10 @@ module IssuesCsv = struct
let filename = SourceFile.to_string source_file in
let always_report =
match Localise.error_desc_extract_tag_value key.err_desc "always_report" with
| ""
-> "false"
| v
-> v
| "" ->
"false"
| v ->
v
in
let trace =
Jsonbug_j.string_of_json_trace
@ -303,9 +319,11 @@ module IssuesCsv = struct
pp "\"%s\"," always_report ;
pp "\"%s\"@\n" err_advice_string
(** Write bug report in csv format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
Errlog.iter (pp_issue fmt error_filter procname proc_loc_opt) err_log
end
let potential_exception_message = "potential exception at line"
@ -317,6 +335,7 @@ module IssuesJson = struct
is_first_item := true ;
F.fprintf fmt "[@?"
let pp_json_close fmt () = F.fprintf fmt "]@\n@?"
let pp_issue fmt error_filter procname proc_loc_opt (key: Errlog.err_key)
@ -324,10 +343,10 @@ module IssuesJson = struct
let pp x = F.fprintf fmt x in
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)
| 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)
@ -346,20 +365,20 @@ module IssuesJson = struct
let file = SourceFile.to_string 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
| Some (file, lnum, cnum, enum) when Config.reports_include_ml_loc ->
Some Jsonbug_j.{file; lnum; cnum; enum}
| _ ->
None
in
let visibility = Exceptions.string_of_visibility err_data.visibility in
let qualifier =
let base_qualifier = error_desc_to_plain_string key.err_desc in
if IssueType.(equal resource_leak) key.err_name then
match Errlog.compute_local_exception_line err_data.loc_trace with
| None
-> base_qualifier
| Some line
-> let potential_exception_message =
| None ->
base_qualifier
| Some line ->
let potential_exception_message =
Format.asprintf "%a: %s %d" MarkupFormatter.pp_bold "Note"
potential_exception_message line
in
@ -394,9 +413,11 @@ module IssuesJson = struct
if not !is_first_item then pp "," else is_first_item := false ;
pp "%s@?" (Jsonbug_j.string_of_jsonbug bug)
(** Write bug report in JSON format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
Errlog.iter (pp_issue fmt error_filter procname proc_loc_opt) err_log
end
let pp_custom_of_report fmt report fields =
@ -412,71 +433,75 @@ let pp_custom_of_report fmt report fields =
in
let pp_field index field =
match field with
| `Issue_field_bug_class
-> Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_class
| `Issue_field_kind
-> Format.fprintf fmt "%s%s" (comma_separator index) issue.kind
| `Issue_field_bug_type
-> Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_type
| `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_visibility
-> Format.fprintf fmt "%s%s" (comma_separator index) issue.visibility
| `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_id
-> Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure_id
| `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%d" (comma_separator index) issue.key
| `Issue_field_hash
-> Format.fprintf fmt "%s%d" (comma_separator index) issue.hash
| `Issue_field_line_offset
-> Format.fprintf fmt "%s%d" (comma_separator index)
| `Issue_field_bug_class ->
Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_class
| `Issue_field_kind ->
Format.fprintf fmt "%s%s" (comma_separator index) issue.kind
| `Issue_field_bug_type ->
Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_type
| `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_visibility ->
Format.fprintf fmt "%s%s" (comma_separator index) issue.visibility
| `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_id ->
Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure_id
| `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%d" (comma_separator index) issue.key
| `Issue_field_hash ->
Format.fprintf fmt "%s%d" (comma_separator index) issue.hash
| `Issue_field_line_offset ->
Format.fprintf fmt "%s%d" (comma_separator index)
(issue.line - issue.procedure_start_line)
| `Issue_field_procedure_id_without_crc
-> Format.fprintf fmt "%s%s" (comma_separator index) (DB.strip_crc issue.procedure_id)
| `Issue_field_qualifier_contains_potential_exception_note
-> Format.fprintf fmt "%B"
| `Issue_field_procedure_id_without_crc ->
Format.fprintf fmt "%s%s" (comma_separator index) (DB.strip_crc issue.procedure_id)
| `Issue_field_qualifier_contains_potential_exception_note ->
Format.fprintf fmt "%B"
(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 bug2 =
let open Jsonbug_t in
[%compare : string * string * int * string * int]
(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
| Some proc_loc ->
proc_loc.Location.file
| None ->
err_data.loc.Location.file
in
if key.in_footprint && error_filter source_file key.err_desc key.err_name then
Exceptions.pp_err ~node_key:err_data.node_id_key.node_key err_data.loc key.err_kind
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 =
@ -487,6 +512,7 @@ let pp_text_of_report fmt report =
in
List.iter ~f:pp_row report ; F.fprintf fmt "@?"
module CallsCsv = struct
(** Write proc summary stats in csv format *)
let pp_calls fmt summary =
@ -503,6 +529,7 @@ module CallsCsv = struct
pp "%a@\n" Specs.CallStats.pp_trace trace
in
Specs.CallStats.iter do_call stats.Specs.call_stats
end
module Stats = struct
@ -536,10 +563,12 @@ module Stats = struct
; nwarnings= 0
; saved_errors= [] }
let process_loc loc stats =
try Hashtbl.find stats.files loc.Location.file
with 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 =
@ -569,14 +598,15 @@ module Stats = struct
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 key.in_footprint && error_filter key.err_desc key.err_name then
match key.err_kind with
| Exceptions.Kerror
-> found_errors := true ;
| Exceptions.Kerror ->
found_errors := true ;
stats.nerrors <- stats.nerrors + 1 ;
let error_strs =
let pp1 fmt = F.fprintf fmt "%d: %s" stats.nerrors type_str in
@ -589,17 +619,18 @@ module Stats = struct
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.Kwarning
-> stats.nwarnings <- stats.nwarnings + 1
| Exceptions.Kinfo
-> stats.ninfos <- stats.ninfos + 1
| Exceptions.Kadvice
-> stats.nadvice <- stats.nadvice + 1
| Exceptions.Klike
-> stats.nlikes <- stats.nlikes + 1
| Exceptions.Kwarning ->
stats.nwarnings <- stats.nwarnings + 1
| Exceptions.Kinfo ->
stats.ninfos <- stats.ninfos + 1
| Exceptions.Kadvice ->
stats.nadvice <- stats.nadvice + 1
| Exceptions.Klike ->
stats.nlikes <- stats.nlikes + 1
in
Errlog.iter process_row err_log ; !found_errors
let process_summary error_filter summary linereader stats =
let specs = Specs.get_specs_from_payload summary in
let found_errors =
@ -619,6 +650,7 @@ module Stats = struct
if is_defective then stats.ndefective <- stats.ndefective + 1 ;
process_loc summary.Specs.attributes.ProcAttributes.loc stats
let num_files stats = Hashtbl.length stats.files
let pp fmt stats =
@ -635,6 +667,7 @@ module Stats = struct
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 Report = struct
@ -642,6 +675,7 @@ module Report = struct
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
@ -651,6 +685,7 @@ module Summary = struct
if CLOpt.equal_command Config.command CLOpt.Report && not Config.quiet then
L.result "Procedure: %a@\n%a@." Typ.Procname.pp proc_name Specs.pp_summary_text summary
(** Write proc summary to latex file *)
let write_summary_latex fmt summary =
let proc_name = Specs.get_proc_name summary in
@ -658,6 +693,7 @@ module Summary = struct
("Analysis of function " ^ Latex.convert_string (Typ.Procname.to_string proc_name)) ;
F.fprintf fmt "@[<v>%a@]" (Specs.pp_summary_latex Black) summary
let pp_summary_xml summary fname =
if Config.xml_specs then
let base = DB.chop_extension (DB.filename_from_string fname) in
@ -672,6 +708,7 @@ module Summary = struct
summary.Specs.attributes.ProcAttributes.loc outf.fmt ;
Utils.close_outf outf )
let print_summary_dot_svg summary fname =
if Config.svg then
let base = DB.chop_extension (DB.filename_from_string fname) in
@ -688,6 +725,7 @@ module Summary = struct
(Sys.command
( "dot -Tsvg \"" ^ DB.filename_to_string dot_file ^ "\" >\""
^ DB.filename_to_string svg_file ^ "\"" ))
end
(** Categorize the preconditions of specs and print stats *)
@ -704,23 +742,27 @@ module PreconditionStats = struct
let specs = Specs.get_specs_from_payload summary in
let preconditions = List.map ~f:(fun spec -> Specs.Jprop.to_prop spec.Specs.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 ;
| 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 ;
| 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
(* Wrapper of an issue that compares all parts except the procname *)
@ -731,6 +773,7 @@ module Issue = struct
let compare_err_data_ (err_data1: Errlog.err_data) (err_data2: Errlog.err_data) =
Location.compare err_data1.loc err_data2.loc
type proc_name_ = Typ.Procname.t
(* ignore proc name *)
@ -751,6 +794,7 @@ module Issue = struct
if num_pruned_issues > 0 then
L.user_warning "Note: pruned %d duplicate issues" num_pruned_issues ) ;
issues'
end
let error_filter filters proc_name file error_desc error_name =
@ -761,6 +805,7 @@ let error_filter filters proc_name file error_desc error_name =
&& (filters.Inferconfig.path_filter file || always_report ())
&& filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name
type report_kind = Issues | Procs | Stats | Calls | Summary [@@deriving compare]
type bug_format_kind = Json | Csv | Tests | Text | Latex [@@deriving compare]
@ -768,57 +813,63 @@ type bug_format_kind = Json | Csv | Tests | Text | Latex [@@deriving compare]
let pp_issue_in_format (format_kind, (outf: Utils.outfile)) error_filter
{Issue.proc_name; proc_location; err_key; err_data} =
match format_kind with
| Csv
-> IssuesCsv.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data
| Json
-> IssuesJson.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data
| Latex
-> L.(die InternalError) "Printing issues in latex is not implemented"
| Tests
-> L.(die InternalError) "Print issues as tests is not implemented"
| Text
-> IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data
| Csv ->
IssuesCsv.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data
| Json ->
IssuesJson.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data
| Latex ->
L.(die InternalError) "Printing issues in latex is not implemented"
| Tests ->
L.(die InternalError) "Print issues as tests is not implemented"
| Text ->
IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data
let pp_issues_in_format (format_kind, (outf: Utils.outfile)) =
match format_kind with
| Json
-> IssuesJson.pp_issues_of_error_log outf.fmt
| Csv
-> IssuesCsv.pp_issues_of_error_log outf.fmt
| Tests
-> L.(die InternalError) "Print issues as tests is not implemented"
| Text
-> IssuesTxt.pp_issues_of_error_log outf.fmt
| Latex
-> L.(die InternalError) "Printing issues in latex is not implemented"
| Json ->
IssuesJson.pp_issues_of_error_log outf.fmt
| Csv ->
IssuesCsv.pp_issues_of_error_log outf.fmt
| Tests ->
L.(die InternalError) "Print issues as tests is not implemented"
| Text ->
IssuesTxt.pp_issues_of_error_log outf.fmt
| Latex ->
L.(die InternalError) "Printing issues in latex is not implemented"
let pp_procs_in_format (format_kind, (outf: Utils.outfile)) =
match format_kind with
| Csv
-> ProcsCsv.pp_summary outf.fmt
| Json | Latex | Tests | Text
-> L.(die InternalError) "Printing procs in json/latex/tests/text is not implemented"
| Csv ->
ProcsCsv.pp_summary outf.fmt
| Json | Latex | Tests | Text ->
L.(die InternalError) "Printing procs in json/latex/tests/text is not implemented"
let pp_calls_in_format (format_kind, (outf: Utils.outfile)) =
match format_kind with
| Csv
-> CallsCsv.pp_calls outf.fmt
| Json | Tests | Text | Latex
-> L.(die InternalError) "Printing calls in json/tests/text/latex is not implemented"
| Csv ->
CallsCsv.pp_calls outf.fmt
| Json | Tests | Text | Latex ->
L.(die InternalError) "Printing calls in json/tests/text/latex is not implemented"
let pp_stats_in_format (format_kind, _) =
match format_kind with
| Csv
-> Stats.process_summary
| Json | Tests | Text | Latex
-> L.(die InternalError) "Printing stats in json/tests/text/latex is not implemented"
| Csv ->
Stats.process_summary
| Json | Tests | Text | Latex ->
L.(die InternalError) "Printing stats in json/tests/text/latex is not implemented"
let pp_summary_in_format (format_kind, (outf: Utils.outfile)) =
match format_kind with
| Latex
-> Summary.write_summary_latex outf.fmt
| Json | Csv | Tests | Text
-> L.(die InternalError) "Printing summary in json/csv/tests/text is not implemented"
| Latex ->
Summary.write_summary_latex outf.fmt
| Json | Csv | Tests | Text ->
L.(die InternalError) "Printing summary in json/csv/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 =
@ -826,15 +877,16 @@ let pp_issues_of_error_log 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.Specs.attributes.ProcAttributes.err_log in
let proc_name = Specs.get_proc_name summary in
let proc_location = summary.Specs.attributes.ProcAttributes.loc in
Errlog.fold
(fun err_key err_data acc ->
{Issue.proc_name= proc_name; proc_location; err_key; err_data} :: acc)
(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
@ -842,6 +894,7 @@ let pp_procs summary procs_format_list =
in
List.iter ~f:pp_procs_in_format procs_format_list
let pp_calls summary calls_format_list =
let pp_calls_in_format format =
let pp_calls = pp_calls_in_format format in
@ -849,6 +902,7 @@ let pp_calls summary calls_format_list =
in
List.iter ~f:pp_calls_in_format calls_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
@ -856,6 +910,7 @@ let pp_stats error_filter linereader summary stats stats_format_list =
in
List.iter ~f:pp_stats_in_format stats_format_list
let pp_summary summary fname summary_format_list =
let pp_summary_in_format format =
let pp_summary = pp_summary_in_format format in
@ -866,39 +921,42 @@ let pp_summary summary fname summary_format_list =
Summary.pp_summary_xml summary fname ;
Summary.print_summary_dot_svg summary fname
let pp_summary_by_report_kind formats_by_report_kind summary fname error_filter linereader stats
file issues_acc =
let pp_summary_by_report_kind (report_kind, format_list) =
match (report_kind, format_list) with
| Procs, _ :: _
-> pp_procs summary format_list
| Stats, _ :: _
-> pp_stats (error_filter file) linereader summary stats format_list
| Calls, _ :: _
-> pp_calls summary format_list
| Summary, _
-> pp_summary summary fname format_list
| _
-> ()
| Procs, _ :: _ ->
pp_procs summary format_list
| Stats, _ :: _ ->
pp_stats (error_filter file) linereader summary stats format_list
| Calls, _ :: _ ->
pp_calls summary format_list
| Summary, _ ->
pp_summary summary fname format_list
| _ ->
()
in
List.iter ~f:pp_summary_by_report_kind formats_by_report_kind ; collect_issues summary issues_acc
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 =
| Ok report_lines ->
let pp_json_issues format_list report =
let pp_json_issue (format_kind, (outf: Utils.outfile)) =
match format_kind with
| Tests
-> pp_custom_of_report outf.fmt report Config.issues_fields
| Text
-> 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"
| Latex
-> L.(die InternalError) "Printing issues from json does not support latex output"
| Tests ->
pp_custom_of_report outf.fmt report Config.issues_fields
| Text ->
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"
| Latex ->
L.(die InternalError) "Printing issues from json does not support latex output"
in
List.iter ~f:pp_json_issue format_list
in
@ -908,30 +966,33 @@ let pp_json_report_by_report_kind formats_by_report_kind fname =
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
| _
-> ()
| 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
| 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
| _
-> ()
| 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 fname summary issues_acc =
let file = summary.Specs.attributes.ProcAttributes.loc.Location.file in
@ -947,6 +1008,7 @@ let process_summary filters formats_by_report_kind linereader stats fname summar
Config.pp_simple := pp_simple_saved ;
issues_acc'
module AnalysisResults = struct
type t = (string * Specs.summary) list
@ -963,15 +1025,16 @@ module AnalysisResults = struct
if List.is_empty Config.anon_args then load_specfiles () else List.rev Config.anon_args )
else load_specfiles ()
(** Load .specs files in memory and return list of summaries *)
let load_summaries_in_memory () : t =
let summaries = ref [] in
let load_file fname =
match Specs.load_summary (DB.filename_from_string fname) with
| None
-> L.(die UserError) "Error: cannot open file %s@." fname
| Some summary
-> summaries := (fname, summary) :: !summaries
| None ->
L.(die UserError) "Error: cannot open file %s@." fname
| Some summary ->
summaries := (fname, summary) :: !summaries
in
let do_load () = spec_files_from_cmdline () |> List.iter ~f:load_file in
Utils.without_gc ~f:do_load ;
@ -987,31 +1050,36 @@ module AnalysisResults = struct
in
List.sort ~cmp:summ_cmp !summaries
(** Create an iterator which loads spec files one at a time *)
let iterator_of_spec_files () =
let sorted_spec_files = List.sort ~cmp:String.compare (spec_files_from_cmdline ()) in
let do_spec f fname =
match Specs.load_summary (DB.filename_from_string fname) with
| None
-> L.(die UserError) "Error: cannot open file %s@." fname
| Some summary
-> f (fname, summary)
| None ->
L.(die UserError) "Error: cannot open file %s@." fname
| Some summary ->
f (fname, summary)
in
let iterate f = List.iter ~f:(do_spec f) sorted_spec_files in
iterate
(** Serializer for analysis results *)
let analysis_results_serializer : t Serialization.serializer =
Serialization.create_serializer Serialization.Key.analysis_results
(** Load analysis_results from a file *)
let load_analysis_results_from_file (filename: DB.filename) : t option =
Serialization.read_from_file analysis_results_serializer filename
(** Save analysis_results into a file *)
let store_analysis_results_to_file (filename: DB.filename) (analysis_results: t) =
Serialization.write_to_file analysis_results_serializer filename ~data:analysis_results
(** Return an iterator over all the summaries.
If options - load_results or - save_results are used,
all the summaries are loaded in memory *)
@ -1020,18 +1088,19 @@ module AnalysisResults = struct
match Config.load_analysis_results with
| None -> (
match Config.save_analysis_results with
| None
-> iterator_of_spec_files ()
| Some s
-> let r = load_summaries_in_memory () in
| None ->
iterator_of_spec_files ()
| Some s ->
let r = load_summaries_in_memory () in
store_analysis_results_to_file (DB.filename_from_string s) r ;
iterator_of_summary_list r )
| Some fname ->
match load_analysis_results_from_file (DB.filename_from_string fname) with
| Some r
-> iterator_of_summary_list r
| None
-> L.(die UserError) "Error: cannot open analysis results file %s@." fname
| Some r ->
iterator_of_summary_list r
| None ->
L.(die UserError) "Error: cannot open analysis results file %s@." fname
end
let register_perf_stats_report () =
@ -1039,11 +1108,13 @@ let register_perf_stats_report () =
let stats_file = Filename.concat stats_dir (Config.perf_stats_prefix ^ ".json") in
PerfStats.register_report_at_exit stats_file
let mk_format format_kind fname =
Option.value_map
~f:(fun out_file -> [(format_kind, out_file)])
~default:[] (Utils.create_outfile fname)
let init_issues_format_list report_csv report_json =
let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] report_csv in
let json_format = Option.value_map ~f:(mk_format Json) ~default:[] report_json in
@ -1051,53 +1122,58 @@ let init_issues_format_list report_csv report_json =
let txt_format = Option.value_map ~f:(mk_format Text) ~default:[] Config.issues_txt in
csv_format @ json_format @ tests_format @ txt_format
let init_procs_format_list () = Option.value_map ~f:(mk_format Csv) ~default:[] Config.procs_csv
let init_calls_format_list () =
let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] Config.calls_csv in
csv_format
let init_stats_format_list () =
let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] Config.stats_report in
csv_format
let init_summary_format_list () =
let latex_format = Option.value_map ~f:(mk_format Latex) ~default:[] Config.latex in
latex_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: Utils.outfile)) =
match (format_kind, report_kind) with
| Csv, Issues
-> IssuesCsv.pp_header outfile.fmt ()
| Csv, Procs
-> ProcsCsv.pp_header outfile.fmt ()
| Csv, Stats
-> Report.pp_header outfile.fmt ()
| Json, Issues
-> IssuesJson.pp_json_open outfile.fmt ()
| Latex, Summary
-> begin_latex_file outfile.fmt
| (Csv | Json | Latex | Tests | Text), _
-> ()
| Csv, Issues ->
IssuesCsv.pp_header outfile.fmt ()
| Csv, Procs ->
ProcsCsv.pp_header outfile.fmt ()
| Csv, Stats ->
Report.pp_header outfile.fmt ()
| Json, Issues ->
IssuesJson.pp_json_open outfile.fmt ()
| Latex, Summary ->
begin_latex_file outfile.fmt
| (Csv | Json | Latex | 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 pdflatex =
let close_files_of_report_kind (report_kind, format_list) =
let close_files_of_format (format_kind, (outfile: Utils.outfile)) =
( match (format_kind, report_kind) with
| Csv, Stats
-> F.fprintf outfile.fmt "%a@?" Report.pp_stats stats
| Json, Issues
-> IssuesJson.pp_json_close outfile.fmt ()
| Latex, Summary
-> Latex.pp_end outfile.fmt ()
| (Csv | Latex | Tests | Text | Json), _
-> () ) ;
| Csv, Stats ->
F.fprintf outfile.fmt "%a@?" Report.pp_stats stats
| Json, Issues ->
IssuesJson.pp_json_close outfile.fmt ()
| Latex, Summary ->
Latex.pp_end outfile.fmt ()
| (Csv | Latex | Tests | Text | Json), _ ->
() ) ;
Utils.close_outf outfile ;
(* bug_format_kind report_kind *)
if [%compare.equal : bug_format_kind * report_kind]
@ -1107,10 +1183,12 @@ let finalize_and_close_files format_list_by_kind stats pdflatex =
let pdf_name = Filename.chop_extension outfile.fname ^ ".pdf" in
ignore (Sys.command ("open " ^ pdf_name)) )
in
List.iter ~f:close_files_of_format format_list ; ()
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 pdflatex fname = ignore (Sys.command ("pdflatex " ^ fname)) in
let stats = Stats.create () in
@ -1131,10 +1209,12 @@ let pp_summary_and_issues formats_by_report_kind issue_formats =
(Issue.sort_filter_issues !all_issues) ;
if Config.precondition_stats then PreconditionStats.pp_stats () ;
LintIssues.load_issues_to_errlog_map Config.lint_issues_dir_name ;
Typ.Procname.Map.iter (pp_lint_issues filters formats_by_report_kind linereader)
Typ.Procname.Map.iter
(pp_lint_issues filters formats_by_report_kind linereader)
!LintIssues.errLogMap ;
finalize_and_close_files formats_by_report_kind stats pdflatex
let main ~report_csv ~report_json =
let issue_formats = init_issues_format_list report_csv report_json in
let formats_by_report_kind =
@ -1147,7 +1227,8 @@ let main ~report_csv ~report_json =
if Config.developer_mode then 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
| Some fname ->
pp_json_report_by_report_kind formats_by_report_kind fname
| None ->
pp_summary_and_issues formats_by_report_kind issue_formats

11
infer/src/backend/OndemandCapture.ml
Unescape View File

@ -9,7 +9,7 @@
open! IStd
module L = Logging
let compilation_db = (lazy (CompilationDatabase.from_json_files !Config.clang_compilation_dbs))
let compilation_db = lazy (CompilationDatabase.from_json_files !Config.clang_compilation_dbs)
(** Given proc_attributes try to produce proc_attributes' where proc_attributes'.is_defined = true
It may trigger capture of extra files to do so and when it does, it waits for
@ -45,12 +45,12 @@ let try_capture (attributes: ProcAttributes.t) : ProcAttributes.t option =
SourceFile.pp definition_file Typ.Procname.pp attributes.proc_name
in
match definition_file_opt with
| None
-> L.(debug Capture Medium)
| None ->
L.(debug Capture Medium)
"Couldn't find source file for %a (declared in %a)@\n" Typ.Procname.pp
attributes.proc_name SourceFile.pp decl_file
| Some file
-> try_compile file ) ;
| Some file ->
try_compile file ) ;
(* It's important to call load_defined_attributes again in all cases to make sure we try
reading from disk again no matter which condition happened. If previous call to
load_defined_attributes is None, it may mean couple of things:
@ -62,3 +62,4 @@ let try_capture (attributes: ProcAttributes.t) : ProcAttributes.t option =
Caveat: it's possible that procedure will be captured in some other unrelated file
later - infer may ignore it then. *)
Attributes.load_defined attributes.proc_name

10
infer/src/backend/PerfStats.ml
Unescape View File

@ -47,6 +47,7 @@ let to_json ps =
; ("stack_kb", `Float ps.stack_kb)
; ("minor_heap_kb", `Float ps.minor_heap_kb) ]
let from_json json =
let open! Yojson.Basic.Util in
{ rtime= json |> member "rtime" |> to_float
@ -65,6 +66,7 @@ let from_json json =
; stack_kb= json |> member "stack_kb" |> to_float
; minor_heap_kb= json |> member "minor_heap_kb" |> to_float }
let aggregate s =
let mk_stats f = StatisticsToolbox.compute_statistics (List.map ~f s) in
let aggr_rtime = mk_stats (fun stats -> stats.rtime) in
@ -99,6 +101,7 @@ let aggregate s =
; ("stack_kb", StatisticsToolbox.to_json aggr_stack_kb)
; ("minor_heap_kb", StatisticsToolbox.to_json aggr_minor_heap_kb) ]
let stats () =
let words_to_kb n = n *. float_of_int (Sys.word_size / 8) /. 1024. in
let words_to_mb n = words_to_kb n /. 1024. in
@ -123,6 +126,7 @@ let stats () =
; stack_kb= words_to_kb (float_of_int gc_stats.stack_size)
; minor_heap_kb= words_to_kb (float_of_int gc_ctrl.minor_heap_size) }
let report_at_exit file () =
try
let json_stats = to_json (stats ()) in
@ -133,11 +137,14 @@ let report_at_exit file () =
Yojson.Basic.pretty_to_channel stats_oc json_stats )
with exc ->
L.internal_error "Info: failed to write stats to %s@\n%s@\n%s@\n%s@." file
(Exn.to_string exc) (Yojson.Basic.pretty_to_string json_stats) (Printexc.get_backtrace ())
(Exn.to_string exc)
(Yojson.Basic.pretty_to_string json_stats)
(Printexc.get_backtrace ())
with exc ->
L.internal_error "Info: failed to compute stats for %s@\n%s@\n%s@." file (Exn.to_string exc)
(Printexc.get_backtrace ())
let register_report_at_exit =
(* take care of not double-registering the same perf stat report *)
let registered_files = String.Table.create ~size:4 () in
@ -146,3 +153,4 @@ let register_report_at_exit =
String.Table.set registered_files ~key:file ~data:() ;
if not Config.buck_cache_mode then
Epilogues.register ~f:(report_at_exit file) ("stats reporting in " ^ file) )

97
infer/src/backend/PropUtil.ml
Unescape View File

@ -17,10 +17,10 @@ let get_name_of_objc_static_locals (curr_f: Procdesc.t) p =
match e with
| Exp.Lvar pvar
when Pvar.is_global pvar && Sil.is_static_local_name pname pvar
(* is a local static if it's a global and it has a static local name *)
-> [pvar]
| _
-> []
(* is a local static if it's a global and it has a static local name *) ->
[pvar]
| _ ->
[]
in
let hpred_local_static hpred =
match hpred with Sil.Hpointsto (e, _, _) -> [local_static e] | _ -> []
@ -28,6 +28,7 @@ let get_name_of_objc_static_locals (curr_f: Procdesc.t) p =
let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in
List.concat (List.concat vars_sigma)
(* returns a list of local variables that points to an objc block in a proposition *)
let get_name_of_objc_block_locals p =
let local_blocks e =
@ -39,44 +40,45 @@ let get_name_of_objc_block_locals p =
let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in
List.concat (List.concat vars_sigma)
let remove_abduced_retvars tenv p =
(* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *)
let compute_reachable p seed_exps =
let sigma, pi = (p.Prop.sigma, p.Prop.pi) in
let rec collect_exps exps = function
| Sil.Eexp (Exp.Exn e, _)
-> Exp.Set.add e exps
| Sil.Eexp (e, _)
-> Exp.Set.add e exps
| Sil.Estruct (flds, _)
-> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds
| Sil.Earray (_, elems, _)
-> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems
| Sil.Eexp (Exp.Exn e, _) ->
Exp.Set.add e exps
| Sil.Eexp (e, _) ->
Exp.Set.add e exps
| Sil.Estruct (flds, _) ->
List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds
| Sil.Earray (_, elems, _) ->
List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems
in
let rec compute_reachable_hpreds_rec sigma (reach, exps) =
let add_hpred_if_reachable (reach, exps) = function
| Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps
-> let reach' = Sil.HpredSet.add hpred reach in
| Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps ->
let reach' = Sil.HpredSet.add hpred reach in
let exps' = collect_exps exps rhs in
(reach', exps')
| Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred
-> let reach' = Sil.HpredSet.add hpred reach in
| Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in
let exps' =
List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
~init:exps (exp1 :: exp2 :: exp_l)
in
(reach', exps')
| Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred
-> let reach' = Sil.HpredSet.add hpred reach in
| Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in
let exps' =
List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
~init:exps (exp1 :: exp2 :: exp3 :: exp4 :: exp_l)
in
(reach', exps')
| _
-> (reach, exps)
| _ ->
(reach, exps)
in
let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma in
if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps)
@ -88,21 +90,21 @@ let remove_abduced_retvars tenv p =
(* filter away the pure atoms without reachable exps *)
let reach_pi =
let rec exp_contains = function
| exp when Exp.Set.mem exp reach_exps
-> true
| Exp.UnOp (_, e, _) | Exp.Cast (_, e) | Exp.Lfield (e, _, _)
-> exp_contains e
| Exp.BinOp (_, e0, e1) | Exp.Lindex (e0, e1)
-> exp_contains e0 || exp_contains e1
| _
-> false
| exp when Exp.Set.mem exp reach_exps ->
true
| Exp.UnOp (_, e, _) | Exp.Cast (_, e) | Exp.Lfield (e, _, _) ->
exp_contains e
| Exp.BinOp (_, e0, e1) | Exp.Lindex (e0, e1) ->
exp_contains e0 || exp_contains e1
| _ ->
false
in
List.filter
~f:(function
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs)
-> exp_contains lhs || exp_contains rhs
| Sil.Apred (_, es) | Sil.Anpred (_, es)
-> List.exists ~f:exp_contains es)
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) ->
exp_contains lhs || exp_contains rhs
| Sil.Apred (_, es) | Sil.Anpred (_, es) ->
List.exists ~f:exp_contains es)
pi
in
(Sil.HpredSet.elements reach_hpreds, reach_pi)
@ -112,12 +114,12 @@ let remove_abduced_retvars tenv p =
List.fold
~f:(fun pvars hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pvar, _, _)
-> let abduceds, normal_pvars = pvars in
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
let abduceds, normal_pvars = pvars in
if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars)
else (abduceds, pvar :: normal_pvars)
| _
-> pvars)
| _ ->
pvars)
~init:([], []) p.Prop.sigma
in
let _, p' = Attribute.deallocate_stack_vars tenv p abduceds in
@ -130,26 +132,29 @@ let remove_abduced_retvars tenv p =
let sigma_reach, pi_reach = compute_reachable p' normal_pvar_set in
Prop.normalize tenv (Prop.set p' ~pi:pi_reach ~sigma:sigma_reach)
let remove_locals tenv (curr_f: Procdesc.t) p =
let names_of_locals = List.map ~f:(get_name_of_local curr_f) (Procdesc.get_locals curr_f) in
let names_of_locals' =
match !Config.curr_language with
| Config.Clang
-> (* in ObjC to deal with block we need to remove static locals *)
| Config.Clang ->
(* in ObjC to deal with block we need to remove static locals *)
let names_of_static_locals = get_name_of_objc_static_locals curr_f p in
let names_of_block_locals = get_name_of_objc_block_locals p in
names_of_block_locals @ names_of_locals @ names_of_static_locals
| _
-> names_of_locals
| _ ->
names_of_locals
in
let removed, p' = Attribute.deallocate_stack_vars tenv p names_of_locals' in
(removed, remove_abduced_retvars tenv p')
let remove_formals tenv (curr_f: Procdesc.t) p =
let pname = Procdesc.get_proc_name curr_f in
let formal_vars = List.map ~f:(fun (n, _) -> Pvar.mk n pname) (Procdesc.get_formals curr_f) in
Attribute.deallocate_stack_vars tenv p formal_vars
(** remove the return variable from the prop *)
let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) =
let pname = Procdesc.get_proc_name curr_f in
@ -157,10 +162,12 @@ let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) =
let _, p' = Attribute.deallocate_stack_vars tenv p [Pvar.to_callee pname name_of_ret] in
p'
(** remove locals and return variable from the prop *)
let remove_locals_ret tenv (curr_f: Procdesc.t) p =
snd (remove_locals tenv curr_f (remove_ret tenv curr_f p))
(** Remove locals and formal parameters from the prop.
Return the list of stack variables whose address was still present after deallocation. *)
let remove_locals_formals tenv (curr_f: Procdesc.t) p =
@ -168,14 +175,16 @@ let remove_locals_formals tenv (curr_f: Procdesc.t) p =
let pvars2, p2 = remove_formals tenv curr_f p1 in
(pvars1 @ pvars2, p2)
(** remove seed vars from a prop *)
let remove_seed_vars tenv (prop: 'a Prop.t) : Prop.normal Prop.t =
let hpred_not_seed = function
| Sil.Hpointsto (Exp.Lvar pv, _, _)
-> not (Pvar.is_seed pv)
| _
-> true
| Sil.Hpointsto (Exp.Lvar pv, _, _) ->
not (Pvar.is_seed pv)
| _ ->
true
in
let sigma = prop.sigma in
let sigma' = List.filter ~f:hpred_not_seed sigma in
Prop.normalize tenv (Prop.set prop ~sigma:sigma')

66
infer/src/backend/StatsAggregator.ml
Unescape View File

@ -19,6 +19,7 @@ let json_files_to_ignore_regex =
( ".*\\(" ^ Str.quote aggregated_stats_filename ^ "\\|"
^ Str.quote aggregated_stats_by_target_filename ^ "\\)$" )
let dir_exists dir = Sys.is_directory dir = `Yes
let find_json_files_in_dir dir =
@ -29,12 +30,13 @@ let find_json_files_in_dir dir =
&& Polymorphic_compare.( = ) s.st_kind Unix.S_REG
in
match dir_exists dir with
| true
-> let content = Array.to_list (Sys.readdir dir) in
| true ->
let content = Array.to_list (Sys.readdir dir) in
let content_with_path = List.map ~f:(fun p -> Filename.concat dir p) content in
List.filter ~f:is_valid_json_file content_with_path
| false
-> []
| false ->
[]
type stats_paths =
{frontend_paths: string list; backend_paths: string list; reporting_paths: string list}
@ -51,32 +53,34 @@ let find_stats_files_in_dir dir =
in
{frontend_paths; backend_paths; reporting_paths}
let load_data_from_infer_deps file =
let error msg = Printf.sprintf ("Error reading '%s': " ^^ msg) file in
let extract_target_and_path line =
match String.split ~on:'\t' line with
| target :: _ :: path :: _
-> if dir_exists path then Ok (target, path)
| target :: _ :: path :: _ ->
if dir_exists path then Ok (target, path)
else Error (error "path '%s' is not a valid directory" path)
| _
-> Error (error "malformed input")
| _ ->
Error (error "malformed input")
in
let parse_lines lines = List.map lines ~f:extract_target_and_path |> Result.all in
Utils.read_file file |> Result.map_error ~f:(fun msg -> error "%s" msg)
|> Result.bind ~f:parse_lines
let collect_all_stats_files () =
let infer_out = Config.results_dir in
let concatenate_paths p1 p2 = if Filename.is_relative p2 then Filename.concat p1 p2 else p2 in
match Config.buck_out with
| Some p
-> if dir_exists p then
| Some p ->
if dir_exists p then
let data =
load_data_from_infer_deps (Filename.concat infer_out Config.buck_infer_deps_file_name)
in
match data with
| Ok r
-> let buck_out_parent = Filename.concat p Filename.parent_dir_name in
| Ok r ->
let buck_out_parent = Filename.concat p Filename.parent_dir_name in
let targets_files =
List.map
~f:(fun (t, p) ->
@ -84,11 +88,12 @@ let collect_all_stats_files () =
r
in
Ok (Buck_out targets_files)
| Error _ as e
-> e
| Error _ as e ->
e
else Error ("buck-out path '" ^ p ^ "' not found")
| None
-> Ok (Infer_out (find_stats_files_in_dir infer_out))
| None ->
Ok (Infer_out (find_stats_files_in_dir infer_out))
let aggregate_stats_files paths =
let open_json_file file = Yojson.Basic.from_file file in
@ -98,6 +103,7 @@ let aggregate_stats_files paths =
let all_perf_stats = load_stats paths in
match all_perf_stats with [] -> None | _ -> Some (PerfStats.aggregate all_perf_stats)
type json_aggregated_stats =
{ frontend_json_data: Yojson.Basic.json option
; backend_json_data: Yojson.Basic.json option
@ -112,15 +118,16 @@ let aggregate_all_stats origin =
let empty_stats_paths = {frontend_paths= []; backend_paths= []; reporting_paths= []} in
let stats_paths =
match origin with
| Buck_out tf
-> List.fold ~f:(fun acc (_, paths) -> accumulate_paths acc paths) ~init:empty_stats_paths tf
| Infer_out paths
-> paths
| Buck_out tf ->
List.fold ~f:(fun acc (_, paths) -> accumulate_paths acc paths) ~init:empty_stats_paths tf
| Infer_out paths ->
paths
in
{ frontend_json_data= aggregate_stats_files stats_paths.frontend_paths
; backend_json_data= aggregate_stats_files stats_paths.backend_paths
; reporting_json_data= aggregate_stats_files stats_paths.reporting_paths }
let aggregate_stats_by_target tp =
let to_json f aggr_stats =
let collect_valid_stats acc t p = match p with Some v -> (t, v) :: acc | None -> acc in
@ -132,6 +139,7 @@ let aggregate_stats_by_target tp =
let reporting_json_data = to_json (fun p -> aggregate_stats_files p.reporting_paths) tp in
{frontend_json_data; backend_json_data; reporting_json_data}
let generate_files () =
let infer_out = Config.results_dir in
let stats_files = collect_all_stats_files () in
@ -148,8 +156,8 @@ let generate_files () =
match json with Some j -> Utils.write_json_to_file destfile j | None -> ()
in
( match origin with
| Buck_out tp
-> let j = aggregate_stats_by_target tp in
| Buck_out tp ->
let j = aggregate_stats_by_target tp in
write_to_json_file_opt
(Filename.concat aggregated_frontend_stats_dir aggregated_stats_by_target_filename)
j.frontend_json_data ;
@ -159,12 +167,16 @@ let generate_files () =
write_to_json_file_opt
(Filename.concat aggregated_reporting_stats_dir aggregated_stats_by_target_filename)
j.reporting_json_data
| Infer_out _
-> () ) ;
| Infer_out _ ->
() ) ;
let j = aggregate_all_stats origin in
write_to_json_file_opt (Filename.concat aggregated_frontend_stats_dir aggregated_stats_filename)
write_to_json_file_opt
(Filename.concat aggregated_frontend_stats_dir aggregated_stats_filename)
j.frontend_json_data ;
write_to_json_file_opt (Filename.concat aggregated_backend_stats_dir aggregated_stats_filename)
write_to_json_file_opt
(Filename.concat aggregated_backend_stats_dir aggregated_stats_filename)
j.backend_json_data ;
write_to_json_file_opt (Filename.concat aggregated_reporting_stats_dir aggregated_stats_filename)
write_to_json_file_opt
(Filename.concat aggregated_reporting_stats_dir aggregated_stats_filename)
j.reporting_json_data

11
infer/src/backend/Tasks.ml
Unescape View File

@ -23,6 +23,7 @@ let create ?(continuation= None) closures =
in
{closures; continuations}
let empty = {closures= []; continuations= Queue.create ()}
(* Aggregate closures into groups of the given size *)
@ -35,11 +36,17 @@ let aggregate ~size t =
{t with closures}
else t
let run t =
List.iter ~f:(fun f -> f ()) t.closures ;
Queue.iter ~f:(fun closure -> closure ()) t.continuations
let fork_protect ~f x = L.reset_formatters () ; ResultsDir.new_database_connection () ; f x
let fork_protect ~f x =
L.reset_formatters () ;
ResultsDir.new_database_connection () ;
f x
module Runner = struct
type runner = {pool: ProcessPool.t; all_continuations: closure Queue.t}
@ -53,7 +60,9 @@ module Runner = struct
~f:(fun x -> ProcessPool.start_child ~f:(fun f -> fork_protect ~f ()) ~pool x)
tasks.closures
let complete runner =
ProcessPool.wait_all runner.pool ;
Queue.iter ~f:(fun f -> f ()) runner.all_continuations
end

666
infer/src/backend/abs.ml
View File

File diff suppressed because it is too large Load Diff

289
infer/src/backend/absarray.ml
Unescape View File

@ -75,31 +75,32 @@ end = struct
assert false
in
match (se, t.desc, syn_offs) with
| _, _, []
-> (se, t)
| _, _, [] ->
(se, t)
| Sil.Estruct (fsel, _), Tstruct name, (Field (fld, _)) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some {fields}
-> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
| Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
let t' = snd3 (List.find_exn ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' fld) fields) in
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| None
-> fail () )
| Sil.Earray (_, esel, _), Typ.Tarray (t', _, _), (Index ind) :: syn_offs'
-> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in
| None ->
fail () )
| Sil.Earray (_, esel, _), Typ.Tarray (t', _, _), (Index ind) :: syn_offs' ->
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| _
-> fail ()
| _ ->
fail ()
(** Replace a strexp at the given syntactic offset list *)
let rec replace_strexp_at_syn_offsets tenv se (t: Typ.t) syn_offs update =
match (se, t.desc, syn_offs) with
| _, _, []
-> update se
| _, _, [] ->
update se
| Sil.Estruct (fsel, inst), Tstruct name, (Field (fld, _)) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some {fields}
-> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
| Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
let t' =
(fun (_, y, _) -> y)
(List.find_exn ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' fld) fields)
@ -112,43 +113,46 @@ end = struct
fsel
in
Sil.Estruct (fsel', inst)
| None
-> assert false )
| Sil.Earray (len, esel, inst), Tarray (t', _, _), (Index idx) :: syn_offs'
-> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in
| None ->
assert false )
| Sil.Earray (len, esel, inst), Tarray (t', _, _), (Index idx) :: syn_offs' ->
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let esel' =
List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel
in
Sil.Earray (len, esel', inst)
| _
-> assert false
| _ ->
assert false
(** convert a path into an expression *)
let path_to_exps (root, syn_offs_in) =
let rec convert acc = function
| []
-> acc
| (Field (f, t)) :: syn_offs'
-> let acc' = List.map ~f:(fun e -> Exp.Lfield (e, f, t)) acc in
| [] ->
acc
| (Field (f, t)) :: syn_offs' ->
let acc' = List.map ~f:(fun e -> Exp.Lfield (e, f, t)) acc in
convert acc' syn_offs'
| (Index idx) :: syn_offs'
-> let acc' = List.map ~f:(fun e -> Exp.Lindex (e, idx)) acc in
| (Index idx) :: syn_offs' ->
let acc' = List.map ~f:(fun e -> Exp.Lindex (e, idx)) acc in
convert acc' syn_offs'
in
convert [root] syn_offs_in
(** create a path from a root and a list of offsets *)
let path_from_exp_offsets root offs =
let offset_to_syn_offset = function
| Sil.Off_fld (fld, typ)
-> Field (fld, typ)
| Sil.Off_index idx
-> Index idx
| Sil.Off_fld (fld, typ) ->
Field (fld, typ)
| Sil.Off_index idx ->
Index idx
in
let syn_offs = List.map ~f:offset_to_syn_offset offs in
(root, syn_offs)
(** path to the root, len, elements and type of a new_array *)
type strexp_data = path * Sil.strexp * Typ.t
@ -161,6 +165,7 @@ end = struct
let hpred = List.find_exn ~f:filter sigma in
(sigma, hpred, syn_offs)
(** Find a sub strexp with the given property. Can raise [Not_found] *)
let find tenv (sigma: sigma) (pred: strexp_data -> bool) : t list =
let found = ref [] in
@ -172,86 +177,90 @@ end = struct
match (se, typ.desc) with
| Sil.Estruct (fsel, _), Tstruct name -> (
match Tenv.lookup tenv name with
| Some {fields}
-> find_offset_fsel sigma_other hpred root offs fsel fields typ
| None
-> () )
| Sil.Earray (_, esel, _), Tarray (t, _, _)
-> find_offset_esel sigma_other hpred root offs esel t
| _
-> ()
| Some {fields} ->
find_offset_fsel sigma_other hpred root offs fsel fields typ
| None ->
() )
| Sil.Earray (_, esel, _), Tarray (t, _, _) ->
find_offset_esel sigma_other hpred root offs esel t
| _ ->
()
and find_offset_fsel sigma_other hpred root offs fsel ftal typ =
match fsel with
| []
-> ()
| (f, se) :: fsel'
-> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) ftal with
| Some (_, t, _)
-> find_offset_sexp sigma_other hpred root (Field (f, typ) :: offs) se t
| None
-> L.d_strln ("Can't find field " ^ Typ.Fieldname.to_string f ^ " in StrexpMatch.find")
| [] ->
()
| (f, se) :: fsel' ->
( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) ftal with
| Some (_, t, _) ->
find_offset_sexp sigma_other hpred root (Field (f, typ) :: offs) se t
| None ->
L.d_strln ("Can't find field " ^ Typ.Fieldname.to_string f ^ " in StrexpMatch.find")
) ;
find_offset_fsel sigma_other hpred root offs fsel' ftal typ
and find_offset_esel sigma_other hpred root offs esel t =
match esel with
| []
-> ()
| (ind, se) :: esel'
-> find_offset_sexp sigma_other hpred root (Index ind :: offs) se t ;
| [] ->
()
| (ind, se) :: esel' ->
find_offset_sexp sigma_other hpred root (Index ind :: offs) se t ;
find_offset_esel sigma_other hpred root offs esel' t
in
let rec iterate sigma_seen = function
| []
-> ()
| hpred :: sigma_rest
-> ( match hpred with
| Sil.Hpointsto (root, se, te)
-> let sigma_other = sigma_seen @ sigma_rest in
| [] ->
()
| hpred :: sigma_rest ->
( match hpred with
| Sil.Hpointsto (root, se, te) ->
let sigma_other = sigma_seen @ sigma_rest in
find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te)
| _
-> () ) ;
| _ ->
() ) ;
iterate (hpred :: sigma_seen) sigma_rest
in
iterate [] sigma ; !found
(** Get the matched strexp *)
let get_data tenv ((_, hpred, syn_offs): t) =
match hpred with
| Sil.Hpointsto (root, se, te)
-> let t = Exp.texp_to_typ None te in
| Sil.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in
let path' = (root, syn_offs) in
(path', se', t')
| _
-> assert false
| _ ->
assert false
(** Replace the current hpred *)
let replace_hpred ((sigma, hpred, _): t) hpred' =
List.map ~f:(fun hpred'' -> if phys_equal hpred'' hpred then hpred' else hpred'') sigma
(** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp tenv footprint_part hpred syn_offs update =
let update se' =
let se_in = update se' in
match (se', se_in) with
| Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2)
-> let orig_indices = List.map ~f:fst esel in
| Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2) ->
let orig_indices = List.map ~f:fst esel in
let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in
let process_index idx =
if index_is_not_new idx then idx else Sil.array_clean_new_index footprint_part idx
in
let esel_in' = List.map ~f:(fun (idx, se) -> (process_index idx, se)) esel_in in
Sil.Earray (len, esel_in', inst2)
| _, _
-> se_in
| _, _ ->
se_in
in
match hpred with
| Sil.Hpointsto (root, se, te)
-> let t = Exp.texp_to_typ None te in
| Sil.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update in
Sil.Hpointsto (root, se', te)
| _
-> assert false
| _ ->
assert false
(** Replace the strexp at a given position by a new strexp *)
let replace_strexp tenv footprint_part ((sigma, hpred, syn_offs): t) se_in =
@ -259,23 +268,25 @@ end = struct
let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred'
(** Replace the index in the array at a given position with the new index *)
let replace_index tenv footprint_part ((sigma, hpred, syn_offs): t) (index: Exp.t)
(index': Exp.t) =
let update se' =
match se' with
| Sil.Earray (len, esel, inst)
-> let esel' =
| Sil.Earray (len, esel, inst) ->
let esel' =
List.map
~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se'))
esel
in
Sil.Earray (len, esel', inst)
| _
-> assert false
| _ ->
assert false
in
let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred'
end
(** This function renames expressions in [p]. The renaming is, roughly
@ -303,6 +314,7 @@ let prop_replace_path_index tenv (p: Prop.exposed Prop.t) (path: StrexpMatch.pat
in
Prop.prop_expmap expmap_fun p
(** This function uses [update] and transforms the two sigma parts of [p],
the sigma of the current SH of [p] and that of the footprint of [p]. *)
let prop_update_sigma_and_fp_sigma tenv (p: Prop.normal Prop.t)
@ -317,6 +329,7 @@ let prop_update_sigma_and_fp_sigma tenv (p: Prop.normal Prop.t)
in
(Prop.normalize tenv ep2, changed || changed2)
(** Remember whether array abstraction was performed (to be reset before calling Abs.abstract) *)
let array_abstraction_performed = ref false
@ -326,7 +339,7 @@ let array_abstraction_performed = ref false
let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal Prop.t)
(can_abstract_: StrexpMatch.strexp_data -> bool)
(do_abstract:
bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool)
bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool)
: Prop.normal Prop.t =
let can_abstract data =
let r = can_abstract_ data in
@ -341,12 +354,12 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P
in
let match_select_next (matchings_cur, matchings_fp) =
match (matchings_cur, matchings_fp) with
| [], []
-> raise Not_found
| matched :: cur', fp'
-> (matched, false, (cur', fp'))
| [], matched :: fp'
-> (matched, true, ([], fp'))
| [], [] ->
raise Not_found
| matched :: cur', fp' ->
(matched, false, (cur', fp'))
| [], matched :: fp' ->
(matched, true, ([], fp'))
in
let rec match_abstract p0 matchings_cur_fp =
try
@ -374,6 +387,7 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P
let num_matches = List.length matchings_cur + List.length matchings_fp in
find_then_abstract num_matches p_in
(** Return [true] if there's a pointer to the index *)
let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : bool =
let indices =
@ -387,13 +401,14 @@ let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (i
in
let pointers = List.concat_map ~f:add_index_to_paths indices in
let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, _), _)
-> List.exists ~f:(Exp.equal e) pointers
| _
-> false
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) ->
List.exists ~f:(Exp.equal e) pointers
| _ ->
false
in
List.exists ~f:filter p.Prop.sigma
(** Given [p] containing an array at [path], blur [index] in it *)
let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t)
: Prop.normal Prop.t =
@ -425,12 +440,14 @@ let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (inde
Prop.normalize tenv p4
with Not_found -> p
(** Given [p] containing an array at [root], blur [indices] in it *)
let blur_array_indices tenv (p: Prop.normal Prop.t) (root: StrexpMatch.path) (indices: Exp.t list)
: Prop.normal Prop.t * bool =
let f prop index = blur_array_index tenv prop root index in
(List.fold ~f ~init:p indices, List.length indices > 0)
(** Given [p] containing an array at [root], only keep [indices] in it *)
let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (indices: Exp.t list)
: Prop.normal Prop.t * bool =
@ -439,8 +456,8 @@ let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (ind
let matched = StrexpMatch.find_path sigma path in
let _, se, _ = StrexpMatch.get_data tenv matched in
match se with
| Sil.Earray (len, esel, inst)
-> let esel', esel_leftover' =
| Sil.Earray (len, esel, inst) ->
let esel', esel_leftover' =
List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel
in
if List.is_empty esel_leftover' then (sigma, false)
@ -448,39 +465,44 @@ let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (ind
let se' = Sil.Earray (len, esel', inst) in
let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in
(sigma', true)
| _
-> (sigma, false)
| _ ->
(sigma, false)
with Not_found -> (sigma, false)
in
prop_update_sigma_and_fp_sigma tenv p prune_sigma
(** If the type is array, check whether we should do abstraction *)
let array_typ_can_abstract {Typ.desc} =
match desc with
| Tarray ({desc= Tptr ({desc= Tfun _}, _)}, _, _)
-> false (* don't abstract arrays of pointers *)
| _
-> true
| Tarray ({desc= Tptr ({desc= Tfun _}, _)}, _, _) ->
false (* don't abstract arrays of pointers *)
| _ ->
true
(** This function checks whether we can apply an abstraction to a strexp *)
let strexp_can_abstract ((_, se, typ): StrexpMatch.strexp_data) : bool =
let can_abstract_se =
match se with
| Sil.Earray (_, esel, _)
-> let len = List.length esel in
| Sil.Earray (_, esel, _) ->
let len = List.length esel in
len > 1
| _
-> false
| _ ->
false
in
can_abstract_se && array_typ_can_abstract typ
(** This function abstracts a strexp *)
let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.strexp_data)
: Prop.normal Prop.t * bool =
if Config.trace_absarray && footprint_part then (
L.d_str "strexp_do_abstract (footprint)" ; L.d_ln () ) ;
L.d_str "strexp_do_abstract (footprint)" ;
L.d_ln () ) ;
if Config.trace_absarray && not footprint_part then (
L.d_str "strexp_do_abstract (nonfootprint)" ; L.d_ln () ) ;
L.d_str "strexp_do_abstract (nonfootprint)" ;
L.d_ln () ) ;
let prune_and_blur d_keys keep blur path keep_keys blur_keys =
let p2, changed2 =
if Config.trace_absarray then ( L.d_str "keep " ; d_keys keep_keys ; L.d_ln () ) ;
@ -531,12 +553,12 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.stre
let is_pointed index = index_is_pointed_to tenv p path index in
let should_keep (index, _) =
match index with
| Exp.Const _
-> is_pointed index
| Exp.Var id
-> Ident.is_normal id || is_pointed index
| _
-> false
| Exp.Const _ ->
is_pointed index
| Exp.Var id ->
Ident.is_normal id || is_pointed index
| _ ->
false
in
let abstract = prune_and_blur_indices path in
filter_abstract Sil.d_exp_list should_keep abstract esel []
@ -546,15 +568,18 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.stre
in
if !Config.footprint then do_footprint () else do_reexecution ()
let strexp_abstract tenv (p: Prop.normal Prop.t) : Prop.normal Prop.t =
generic_strexp_abstract tenv "strexp_abstract" p strexp_can_abstract (strexp_do_abstract tenv)
let report_error prop =
L.d_strln "Check after array abstraction: FAIL" ;
Prop.d_prop prop ;
L.d_ln () ;
assert false
(** Check performed after the array abstraction to see whether it was successful. Raise assert false in case of failure *)
let check_after_array_abstraction tenv prop =
let lookup = Tenv.lookup tenv in
@ -565,10 +590,10 @@ let check_after_array_abstraction tenv prop =
else not (Sil.fav_exists (Sil.exp_fav ind) Ident.is_primed)
in
let rec check_se root offs typ = function
| Sil.Eexp _
-> ()
| Sil.Earray (_, esel, _)
-> (* check that no more than 2 elements are in the array *)
| Sil.Eexp _ ->
()
| Sil.Earray (_, esel, _) ->
(* check that no more than 2 elements are in the array *)
let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in
if List.length esel > 2 && array_typ_can_abstract typ then
if List.for_all ~f:(check_index root offs) esel then () else report_error prop
@ -576,28 +601,31 @@ let check_after_array_abstraction tenv prop =
List.iter
~f:(fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se)
esel
| Sil.Estruct (fsel, _)
-> List.iter
| Sil.Estruct (fsel, _) ->
List.iter
~f:(fun (f, se) ->
let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se)
fsel
in
let check_hpred = function
| Sil.Hpointsto (root, se, texp)
-> let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in
| Sil.Hpointsto (root, se, texp) ->
let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in
check_se root [] typ se
| Sil.Hlseg _ | Sil.Hdllseg _
-> ()
| Sil.Hlseg _ | Sil.Hdllseg _ ->
()
in
let check_sigma sigma = List.iter ~f:check_hpred sigma in
(* check_footprint_pure prop; *)
check_sigma prop.Prop.sigma ; check_sigma prop.Prop.sigma_fp
(** Apply array abstraction and check the result *)
let abstract_array_check tenv p =
let p_res = strexp_abstract tenv p in
check_after_array_abstraction tenv p_res ; p_res
check_after_array_abstraction tenv p_res ;
p_res
(** remove redundant elements in an array *)
let remove_redundant_elements tenv prop =
@ -634,26 +662,26 @@ let remove_redundant_elements tenv prop =
in
match (e, se) with
| Exp.Const Const.Cint i, Sil.Eexp (Exp.Var id, _)
when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id
-> remove () (* unknown value can be removed in re-execution mode or if the index is zero *)
| Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id
-> remove () (* index unknown can be removed *)
| _
-> true
when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id ->
remove () (* unknown value can be removed in re-execution mode or if the index is zero *)
| Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id ->
remove () (* index unknown can be removed *)
| _ ->
true
in
let remove_redundant_se fp_part = function
| Sil.Earray (len, esel, inst)
-> let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in
| Sil.Earray (len, esel, inst) ->
let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in
Sil.Earray (len, esel', inst)
| se
-> se
| se ->
se
in
let remove_redundant_hpred fp_part = function
| Sil.Hpointsto (e, se, te)
-> let se' = remove_redundant_se fp_part se in
| Sil.Hpointsto (e, se, te) ->
let se' = remove_redundant_se fp_part se in
Sil.Hpointsto (e, se', te)
| hpred
-> hpred
| hpred ->
hpred
in
let remove_redundant_sigma fp_part sigma = List.map ~f:(remove_redundant_hpred fp_part) sigma in
let sigma' = remove_redundant_sigma false prop.Prop.sigma in
@ -662,3 +690,4 @@ let remove_redundant_elements tenv prop =
let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in
Prop.normalize tenv prop'
else prop

93
infer/src/backend/buckets.ml
Unescape View File

@ -24,22 +24,22 @@ let check_nested_loop path pos_opt =
let loop_visits_log = ref [] in
let in_nested_loop () =
match !loop_visits_log with
| true :: true :: _
-> if verbose then L.d_strln "in nested loop" ;
| true :: true :: _ ->
if verbose then L.d_strln "in nested loop" ;
true
(* last two loop visits were entering loops *)
| _
-> false
| _ ->
false
in
let do_node_caller node =
match Procdesc.Node.get_kind node with
| Procdesc.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _)
-> (* if verbose then *)
| Procdesc.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) ->
(* if verbose then *)
(* L.d_strln ((if b then "enter" else "exit") ^ " node " *)
(* ^ (string_of_int (Procdesc.Node.get_id node))); *)
loop_visits_log := b :: !loop_visits_log
| _
-> ()
| _ ->
()
in
let do_any_node _level _node =
incr trace_length
@ -49,13 +49,15 @@ let check_nested_loop path pos_opt =
in
let f level p _ _ =
match Paths.Path.curr_node p with
| Some node
-> do_any_node level node ;
| Some node ->
do_any_node level node ;
if Int.equal level 0 then do_node_caller node
| None
-> ()
| None ->
()
in
Paths.Path.iter_shortest_sequence f pos_opt path ; in_nested_loop ()
Paths.Path.iter_shortest_sequence f pos_opt path ;
in_nested_loop ()
(** Check that we know where the value was last assigned,
and that there is a local access instruction at that line. **)
@ -66,10 +68,10 @@ let check_access access_opt de_opt =
let node_instrs = Procdesc.Node.get_instrs node in
let formals =
match State.get_prop_tenv_pdesc () with
| None
-> []
| Some (_, _, pdesc)
-> Procdesc.get_formals pdesc
| None ->
[]
| Some (_, _, pdesc) ->
Procdesc.get_formals pdesc
in
let formal_names = List.map ~f:fst formals in
let is_formal pvar =
@ -78,43 +80,44 @@ let check_access access_opt de_opt =
in
let formal_ids = ref [] in
let process_formal_letref = function
| Sil.Load (id, Exp.Lvar pvar, _, _)
-> let is_java_this = Config.curr_language_is Config.Java && Pvar.is_this pvar in
| Sil.Load (id, Exp.Lvar pvar, _, _) ->
let is_java_this = Config.curr_language_is Config.Java && Pvar.is_this pvar in
if not is_java_this && is_formal pvar then formal_ids := id :: !formal_ids
| _
-> ()
| _ ->
()
in
List.iter ~f:process_formal_letref node_instrs ; !formal_ids
List.iter ~f:process_formal_letref node_instrs ;
!formal_ids
in
let formal_param_used_in_call = ref false in
let has_call_or_sets_null node =
let rec exp_is_null exp =
match exp with
| Exp.Const Const.Cint n
-> IntLit.iszero n
| Exp.Cast (_, e)
-> exp_is_null e
| Exp.Const Const.Cint n ->
IntLit.iszero n
| Exp.Cast (_, e) ->
exp_is_null e
| Exp.Var _ | Exp.Lvar _ -> (
match State.get_const_map () node exp with
| Some Const.Cint n
-> IntLit.iszero n
| _
-> false )
| _
-> false
| Some Const.Cint n ->
IntLit.iszero n
| _ ->
false )
| _ ->
false
in
let filter = function
| Sil.Call (_, _, etl, _, _)
-> let formal_ids = find_formal_ids node in
| Sil.Call (_, _, etl, _, _) ->
let formal_ids = find_formal_ids node in
let arg_is_formal_param (e, _) =
match e with Exp.Var id -> List.exists ~f:(Ident.equal id) formal_ids | _ -> false
in
if List.exists ~f:arg_is_formal_param etl then formal_param_used_in_call := true ;
true
| Sil.Store (_, _, e, _)
-> exp_is_null e
| _
-> false
| Sil.Store (_, _, e, _) ->
exp_is_null e
| _ ->
false
in
List.exists ~f:filter (Procdesc.Node.get_instrs node)
in
@ -137,16 +140,18 @@ let check_access access_opt de_opt =
else None
in
match access_opt with
| Some Localise.Last_assigned (n, ncf)
-> find_bucket n ncf
| Some Localise.Returned_from_call n
-> find_bucket n false
| Some Localise.Last_accessed (_, is_nullable) when is_nullable
-> Some Localise.BucketLevel.b1
| Some Localise.Last_assigned (n, ncf) ->
find_bucket n ncf
| Some Localise.Returned_from_call n ->
find_bucket n false
| Some Localise.Last_accessed (_, is_nullable) when is_nullable ->
Some Localise.BucketLevel.b1
| _ ->
match de_opt with Some DecompiledExp.Dconst _ -> Some Localise.BucketLevel.b1 | _ -> None
let classify_access desc access_opt de_opt is_nullable =
let default_bucket = if is_nullable then Localise.BucketLevel.b1 else Localise.BucketLevel.b5 in
let bucket = check_access access_opt de_opt |> Option.value ~default:default_bucket in
Localise.error_desc_set_bucket desc bucket

13
infer/src/backend/builtin.ml
Unescape View File

@ -37,18 +37,23 @@ let check_register_populated () =
if Int.equal (Typ.Procname.Hash.length builtin_functions) 0 then
L.(die InternalError) "Builtins were not initialized"
(** check if the function is a builtin *)
let is_registered name =
Typ.Procname.Hash.mem builtin_functions name || (check_register_populated () ; false)
(** get the symbolic execution handler associated to the builtin function name *)
let get name : t option =
try Some (Typ.Procname.Hash.find builtin_functions name)
with Not_found -> check_register_populated () ; None
(** register a builtin [Typ.Procname.t] and symbolic execution handler *)
let register proc_name sym_exe_fun : registered =
Typ.Procname.Hash.replace builtin_functions proc_name sym_exe_fun ; sym_exe_fun
Typ.Procname.Hash.replace builtin_functions proc_name sym_exe_fun ;
sym_exe_fun
(** print the functions registered *)
let pp_registered fmt () =
@ -60,5 +65,9 @@ let pp_registered fmt () =
List.iter ~f:pp !builtin_names ;
Format.fprintf fmt "@]@."
(** print the builtin functions and exit *)
let print_and_exit () = pp_registered Format.std_formatter () ; L.exit 0
let print_and_exit () =
pp_registered Format.std_formatter () ;
L.exit 0

44
infer/src/backend/callbacks.ml
Unescape View File

@ -34,14 +34,17 @@ let cluster_callbacks = ref []
let register_procedure_callback ?(dynamic_dispath= false) language (callback: proc_callback_t) =
procedure_callbacks := (language, dynamic_dispath, callback) :: !procedure_callbacks
let register_cluster_callback language (callback: cluster_callback_t) =
cluster_callbacks := (language, callback) :: !cluster_callbacks
(** Collect what we need to know about a procedure for the analysis. *)
let get_procedure_definition exe_env proc_name =
let tenv = Exe_env.get_tenv exe_env proc_name in
Option.map ~f:(fun proc_desc -> (tenv, proc_desc)) (Exe_env.get_proc_desc exe_env proc_name)
let get_language proc_name = if Typ.Procname.is_java proc_name then Config.Java else Config.Clang
(** Invoke all registered procedure callbacks on the given procedure. *)
@ -51,10 +54,10 @@ let iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc =
Config.curr_language := procedure_language ;
let get_procs_in_file proc_name =
match Exe_env.get_cfg exe_env proc_name with
| Some cfg
-> List.map ~f:Procdesc.get_proc_name (Cfg.get_defined_procs cfg)
| None
-> []
| Some cfg ->
List.map ~f:Procdesc.get_proc_name (Cfg.get_defined_procs cfg)
| None ->
[]
in
let tenv = Exe_env.get_tenv exe_env proc_name in
let is_specialized = Procdesc.is_specialized proc_desc in
@ -65,22 +68,24 @@ let iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc =
else summary)
!procedure_callbacks
(** Invoke all registered cluster callbacks on a cluster of procedures. *)
let iterate_cluster_callbacks all_procs exe_env get_proc_desc =
let procedures = List.filter_map ~f:(get_procedure_definition exe_env) all_procs in
let environment = {procedures; get_proc_desc} in
let language_matches language =
match procedures with
| (_, pdesc) :: _
-> Config.equal_language language (get_language (Procdesc.get_proc_name pdesc))
| _
-> true
| (_, pdesc) :: _ ->
Config.equal_language language (get_language (Procdesc.get_proc_name pdesc))
| _ ->
true
in
List.iter
~f:(fun (language_opt, cluster_callback) ->
if language_matches language_opt then cluster_callback environment)
!cluster_callbacks
(** Invoke all procedure and cluster callbacks on a given environment. *)
let iterate_callbacks call_graph exe_env =
let saved_language = !Config.curr_language in
@ -90,24 +95,24 @@ let iterate_callbacks call_graph exe_env =
in
let get_proc_desc proc_name =
match Exe_env.get_proc_desc exe_env proc_name with
| Some pdesc
-> Some pdesc
| None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy)
-> Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> summary.Specs.proc_desc_option)
| None
-> None
| Some pdesc ->
Some pdesc
| None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) ->
Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> summary.Specs.proc_desc_option)
| None ->
None
in
let analyze_ondemand summary proc_desc =
iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc
in
let callbacks = {Ondemand.analyze_ondemand= analyze_ondemand; get_proc_desc} in
let callbacks = {Ondemand.analyze_ondemand; get_proc_desc} in
(* Create and register on-demand analysis callback *)
let analyze_proc_name pname =
match Ondemand.get_proc_desc pname with
| None
-> L.(die InternalError) "Could not find proc desc for %a" Typ.Procname.pp pname
| Some pdesc
-> ignore (Ondemand.analyze_proc_desc pdesc pdesc)
| None ->
L.(die InternalError) "Could not find proc desc for %a" Typ.Procname.pp pname
| Some pdesc ->
ignore (Ondemand.analyze_proc_desc pdesc pdesc)
in
Ondemand.set_callbacks callbacks ;
(* Invoke procedure callbacks using on-demand anlaysis schedulling *)
@ -117,3 +122,4 @@ let iterate_callbacks call_graph exe_env =
(* Unregister callbacks *)
Ondemand.unset_callbacks () ;
Config.curr_language := saved_language

3
infer/src/backend/callbacks.mli
Unescape View File

@ -30,7 +30,8 @@ type cluster_callback_args =
type cluster_callback_t = cluster_callback_args -> unit
val register_procedure_callback : ?dynamic_dispath:bool -> Config.language -> proc_callback_t -> unit
val register_procedure_callback :
?dynamic_dispath:bool -> Config.language -> proc_callback_t -> unit
(** register a procedure callback *)
val register_cluster_callback : Config.language -> cluster_callback_t -> unit

4
infer/src/backend/cluster.ml
Unescape View File

@ -23,14 +23,17 @@ type serializer_t = int * t
let serializer : serializer_t Serialization.serializer =
Serialization.create_serializer Serialization.Key.cluster
(** Load a cluster from a file *)
let load_from_file (filename: DB.filename) : serializer_t option =
Serialization.read_from_file serializer filename
(** Save a cluster into a file *)
let store_to_file (filename: DB.filename) (data: serializer_t) =
Serialization.write_to_file serializer filename ~data
let cl_name n = "cl" ^ string_of_int n
let cl_file n = "x" ^ cl_name n ^ ".cluster"
@ -46,3 +49,4 @@ let pp_cluster fmt (nr, cluster) =
(* touch the target of the rule to let `make` know that the job has been done *)
F.fprintf fmt "\t%@touch $%@@\n" ;
F.fprintf fmt "@\n"

10
infer/src/backend/clusterMakefile.ml
Unescape View File

@ -17,10 +17,10 @@ module CLOpt = CommandLineOption
let pp_prolog fmt clusters =
let escape = Escape.escape_map (fun c -> if Char.equal c '#' then Some "\\#" else None) in
let infer_flag_of_compilation_db = function
| `Escaped f
-> F.sprintf "--compilation-database-escaped '%s'" f
| `Raw f
-> F.sprintf "--compilation-database '%s'" f
| `Escaped f ->
F.sprintf "--compilation-database-escaped '%s'" f
| `Raw f ->
F.sprintf "--compilation-database '%s'" f
in
let compilation_dbs_cmd =
List.map ~f:infer_flag_of_compilation_db !Config.clang_compilation_dbs
@ -35,6 +35,7 @@ let pp_prolog fmt clusters =
F.fprintf fmt "test: $(CLUSTERS)@\n" ;
if Config.show_progress_bar then F.fprintf fmt "\t%@echo@\n@."
let pp_epilog fmt () = F.fprintf fmt "@.clean:@.\trm -f $(CLUSTERS)@."
let create_cluster_makefile (clusters: Cluster.t list) (fname: string) =
@ -48,3 +49,4 @@ let create_cluster_makefile (clusters: Cluster.t list) (fname: string) =
List.iteri ~f:do_cluster clusters ;
pp_epilog fmt () ;
Out_channel.close outc

54
infer/src/backend/crashcontext.ml
Unescape View File

@ -14,23 +14,25 @@ module L = Logging
let frame_id_of_stackframe frame =
let loc_str =
match frame.Stacktrace.line_num with
| None
-> frame.Stacktrace.file_str
| Some line
-> F.sprintf "%s:%d" frame.Stacktrace.file_str line
| None ->
frame.Stacktrace.file_str
| Some line ->
F.sprintf "%s:%d" frame.Stacktrace.file_str line
in
F.sprintf "%s.%s(%s)" frame.Stacktrace.class_str frame.Stacktrace.method_str loc_str
let frame_id_of_summary stacktree =
let short_name = List.hd_exn (Str.split (Str.regexp "(") stacktree.Stacktree_j.method_name) in
match stacktree.Stacktree_j.location with
| None
-> L.(die InternalError)
| None ->
L.(die InternalError)
"Attempted to take signature of a frame without location information. This is undefined."
| Some {line= Some line_num; file}
-> F.sprintf "%s(%s:%d)" short_name (Filename.basename file) line_num
| Some {file}
-> F.sprintf "%s(%s)" short_name (Filename.basename file)
| Some {line= Some line_num; file} ->
F.sprintf "%s(%s:%d)" short_name (Filename.basename file) line_num
| Some {file} ->
F.sprintf "%s(%s)" short_name (Filename.basename file)
let stracktree_of_frame frame =
{ Stacktree_j.method_name=
@ -43,6 +45,7 @@ let stracktree_of_frame frame =
; blame_range= [] }
; callees= [] }
(** k = 1 implementation, where k is the number of levels of calls inlined *)
let stitch_summaries stacktrace_file summary_files out_file =
let stacktrace = Stacktrace.of_json_file stacktrace_file in
@ -64,6 +67,7 @@ let stitch_summaries stacktrace_file summary_files out_file =
let crashcontext = {Stacktree_j.stack= expanded_frames} in
Ag_util.Json.to_file Stacktree_j.write_crashcontext_t out_file crashcontext
let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir =
let method_summaries =
Utils.directory_fold
@ -77,19 +81,19 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir =
in
let pair_for_stacktrace_file =
match stacktrace_file with
| None
-> None
| Some file
-> let crashcontext_dir = Config.results_dir ^/ "crashcontext" in
| None ->
None
| Some file ->
let crashcontext_dir = Config.results_dir ^/ "crashcontext" in
Utils.create_dir crashcontext_dir ; Some (file, crashcontext_dir ^/ "crashcontext.json")
in
let trace_file_regexp = Str.regexp "\\(.*\\)\\.json" in
let pairs_for_stactrace_dir =
match stacktraces_dir with
| None
-> []
| Some s
-> let dir = DB.filename_from_string s in
| None ->
[]
| Some s ->
let dir = DB.filename_from_string s in
let trace_file_matcher path =
let path_str = DB.filename_to_string path in
Str.string_match trace_file_regexp path_str 0
@ -101,24 +105,25 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir =
in
try DB.fold_paths_matching ~dir ~p:trace_file_matcher ~init:[] ~f:trace_fold
with
| (* trace_fold runs immediately after trace_file_matcher in the
(* trace_fold runs immediately after trace_file_matcher in the
DB.fold_paths_matching statement below, so we don't need to
call Str.string_match again. *)
Not_found
| Not_found
-> assert false
in
let input_output_file_pairs =
match pair_for_stacktrace_file with
| None
-> pairs_for_stactrace_dir
| Some pair
-> pair :: pairs_for_stactrace_dir
| None ->
pairs_for_stactrace_dir
| Some pair ->
pair :: pairs_for_stactrace_dir
in
let process_stacktrace (stacktrace_file, out_file) =
stitch_summaries stacktrace_file method_summaries out_file
in
List.iter ~f:process_stacktrace input_output_file_pairs
let crashcontext_epilogue ~in_buck_mode =
(* if we are the top-level process, then find the output directory and
collect all crashcontext summaries under it in a single
@ -134,4 +139,5 @@ let crashcontext_epilogue ~in_buck_mode =
in
collect_all_summaries root_summaries_dir Config.stacktrace Config.stacktraces_dir
let pp_stacktree fmt st = Format.fprintf fmt "%s" (Stacktree_j.string_of_stacktree st)

1251
infer/src/backend/dom.ml
View File

File diff suppressed because it is too large Load Diff

915
infer/src/backend/dotty.ml
View File

File diff suppressed because it is too large Load Diff

1050
infer/src/backend/errdesc.ml
View File

File diff suppressed because it is too large Load Diff

108
infer/src/backend/exe_env.ml
Unescape View File

@ -32,6 +32,7 @@ let tenv_filename file_base =
per_source_tenv_filename
else DB.global_tenv_fname
module FilenameHash = Hashtbl.Make (struct
type t = DB.filename
@ -52,13 +53,16 @@ let new_file_data source cg_fname =
cfg_file
; cfg= None (* Cfg.load_cfg_from_file cfg_file *) }
let create_file_data table source cg_fname =
match FilenameHash.find table cg_fname with
| file_data
-> file_data
| exception Not_found
-> let file_data = new_file_data source cg_fname in
FilenameHash.add table cg_fname file_data ; file_data
| file_data ->
file_data
| exception Not_found ->
let file_data = new_file_data source cg_fname in
FilenameHash.add table cg_fname file_data ;
file_data
(** execution environment *)
type t =
@ -77,37 +81,39 @@ let create () =
; file_map= FilenameHash.create 1
; source_files= SourceFile.Set.empty }
(** add call graph from fname in the spec db,
with relative tenv and cfg, to the execution environment *)
let add_cg (exe_env: t) (source_dir: DB.source_dir) =
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
match Cg.load_from_file cg_fname with
| None
-> L.internal_error "Error: cannot load %s@." (DB.filename_to_string cg_fname)
| Some cg
-> let source = Cg.get_source cg in
| None ->
L.internal_error "Error: cannot load %s@." (DB.filename_to_string cg_fname)
| Some cg ->
let source = Cg.get_source cg in
exe_env.source_files <- SourceFile.Set.add source exe_env.source_files ;
let defined_procs = Cg.get_defined_nodes cg in
let duplicate_procs_to_print =
List.filter_map defined_procs ~f:(fun pname ->
match Attributes.find_file_capturing_procedure pname with
| None
-> None
| Some (source_captured, origin)
-> let multiply_defined = SourceFile.compare source source_captured <> 0 in
| None ->
None
| Some (source_captured, origin) ->
let multiply_defined = SourceFile.compare source source_captured <> 0 in
if multiply_defined then Cg.remove_node_defined cg pname ;
if multiply_defined && origin <> `Include then Some (pname, source_captured)
else None )
in
if Config.dump_duplicate_symbols then
Out_channel.with_file (Config.results_dir ^/ Config.duplicates_filename) ~append:true
~perm:0o666 ~f:(fun outc ->
Out_channel.with_file (Config.results_dir ^/ Config.duplicates_filename)
~append:true ~perm:0o666 ~f:(fun outc ->
let fmt = F.formatter_of_out_channel outc in
List.iter duplicate_procs_to_print ~f:(fun (pname, source_captured) ->
F.fprintf fmt "@.DUPLICATE_SYMBOLS source: %a source_captured:%a pname:%a@."
SourceFile.pp source SourceFile.pp source_captured Typ.Procname.pp pname ) ) ;
Cg.extend exe_env.cg cg
(** get the global call graph *)
let get_cg exe_env = exe_env.cg
@ -116,83 +122,94 @@ let get_file_data exe_env pname =
with Not_found ->
let source_file_opt =
match Attributes.load pname with
| None
-> L.(debug Analysis Medium) "can't find tenv_cfg_object for %a@." Typ.Procname.pp pname ;
| None ->
L.(debug Analysis Medium) "can't find tenv_cfg_object for %a@." Typ.Procname.pp pname ;
None
| Some proc_attributes when Config.reactive_capture
-> let get_captured_file {ProcAttributes.source_file_captured} = source_file_captured in
| Some proc_attributes when Config.reactive_capture ->
let get_captured_file {ProcAttributes.source_file_captured} = source_file_captured in
OndemandCapture.try_capture proc_attributes |> Option.map ~f:get_captured_file
| Some proc_attributes
-> Some proc_attributes.ProcAttributes.source_file_captured
| Some proc_attributes ->
Some proc_attributes.ProcAttributes.source_file_captured
in
let get_file_data_for_source source_file =
let source_dir = DB.source_dir_from_source_file source_file in
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
let file_data = create_file_data exe_env.file_map source_file cg_fname in
Typ.Procname.Hash.replace exe_env.proc_map pname file_data ; file_data
Typ.Procname.Hash.replace exe_env.proc_map pname file_data ;
file_data
in
Option.map ~f:get_file_data_for_source source_file_opt
(** return the source file associated to the procedure *)
let get_source exe_env pname =
Option.map ~f:(fun file_data -> file_data.source) (get_file_data exe_env pname)
let file_data_to_tenv file_data =
if is_none file_data.tenv then file_data.tenv <- Tenv.load_from_file file_data.tenv_file ;
file_data.tenv
let file_data_to_cfg file_data =
if is_none file_data.cfg then file_data.cfg <- Cfg.load_cfg_from_file file_data.cfg_file ;
file_data.cfg
let java_global_tenv =
( lazy
( match Tenv.load_from_file DB.global_tenv_fname with
| None
-> L.(die InternalError)
"Could not load the global tenv at path '%s'" (DB.filename_to_string DB.global_tenv_fname)
| Some tenv
-> tenv ) )
lazy
( match Tenv.load_from_file DB.global_tenv_fname with
| None ->
L.(die InternalError)
"Could not load the global tenv at path '%s'"
(DB.filename_to_string DB.global_tenv_fname)
| Some tenv ->
tenv )
(** return the type environment associated to the procedure *)
let get_tenv exe_env proc_name =
match proc_name with
| Typ.Procname.Java _
-> Lazy.force java_global_tenv
| Typ.Procname.Java _ ->
Lazy.force java_global_tenv
| _ ->
match get_file_data exe_env proc_name with
| Some file_data -> (
match file_data_to_tenv file_data with
| Some tenv
-> tenv
| None
-> L.(die InternalError)
| Some tenv ->
tenv
| None ->
L.(die InternalError)
"get_tenv: tenv not found for %a in file '%s'" Typ.Procname.pp proc_name
(DB.filename_to_string file_data.tenv_file) )
| None
-> L.(die InternalError) "get_tenv: file_data not found for %a" Typ.Procname.pp proc_name
| None ->
L.(die InternalError) "get_tenv: file_data not found for %a" Typ.Procname.pp proc_name
(** return the cfg associated to the procedure *)
let get_cfg exe_env pname =
match get_file_data exe_env pname with
| None
-> None
| Some file_data
-> file_data_to_cfg file_data
| None ->
None
| Some file_data ->
file_data_to_cfg file_data
(** return the proc desc associated to the procedure *)
let get_proc_desc exe_env pname =
match get_cfg exe_env pname with
| Some cfg
-> Cfg.find_proc_desc_from_name cfg pname
| None
-> None
| Some cfg ->
Cfg.find_proc_desc_from_name cfg pname
| None ->
None
(** Create an exe_env from a source dir *)
let from_cluster cluster =
let exe_env = create () in
add_cg exe_env cluster ; exe_env
(** [iter_files f exe_env] applies [f] to the filename and tenv and cfg for each file in [exe_env] *)
let iter_files f exe_env =
let do_file _ file_data seen_files_acc =
@ -206,3 +223,4 @@ let iter_files f exe_env =
SourceFile.Set.add fname seen_files_acc )
in
ignore (Typ.Procname.Hash.fold do_file exe_env.proc_map SourceFile.Set.empty)

84
infer/src/backend/infer.ml
Unescape View File

@ -24,40 +24,44 @@ let run driver_mode =
analyze_and_report driver_mode ~changed_files ;
run_epilogue driver_mode
let setup () =
match Config.command with
| Analyze
-> ResultsDir.assert_results_dir "have you run capture before?"
| Report | ReportDiff
-> ResultsDir.create_results_dir ()
| Diff
-> ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir ()
| Capture | Compile | Run
-> let driver_mode = Lazy.force Driver.mode_from_command_line in
| Analyze ->
ResultsDir.assert_results_dir "have you run capture before?"
| Report | ReportDiff ->
ResultsDir.create_results_dir ()
| Diff ->
ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir ()
| Capture | Compile | Run ->
let driver_mode = Lazy.force Driver.mode_from_command_line in
if not
( Driver.(equal_mode driver_mode Analyze)
||
Config.(buck || continue_capture || infer_is_clang || infer_is_javac || reactive_mode) )
then ResultsDir.remove_results_dir () ;
ResultsDir.create_results_dir ()
| Explore
-> ResultsDir.assert_results_dir "please run an infer analysis first"
| Explore ->
ResultsDir.assert_results_dir "please run an infer analysis first"
let print_active_checkers () =
(if Config.print_active_checkers && CLOpt.is_originator then L.result else L.environment_info)
"Analyzer: %s@."
Config.(string_of_analyzer analyzer) ;
(if Config.print_active_checkers && CLOpt.is_originator then L.result else L.environment_info)
"Active checkers: %a@." (Pp.seq ~sep:", " RegisterCheckers.pp_checker)
"Active checkers: %a@."
(Pp.seq ~sep:", " RegisterCheckers.pp_checker)
(RegisterCheckers.get_active_checkers ())
let log_environment_info () =
L.environment_info "CWD = %s@\n" (Sys.getcwd ()) ;
( match Config.inferconfig_file with
| Some file
-> L.environment_info "Read configuration in %s@\n" file
| None
-> L.environment_info "No .inferconfig file found@\n" ) ;
| Some file ->
L.environment_info "Read configuration in %s@\n" file
| None ->
L.environment_info "No .inferconfig file found@\n" ) ;
L.environment_info "Project root = %s@\n" Config.project_root ;
let infer_args =
Sys.getenv CLOpt.args_env_var |> Option.map ~f:(String.split ~on:CLOpt.env_var_sep)
@ -67,47 +71,48 @@ let log_environment_info () =
L.environment_info "command line arguments: %a" Pp.cli_args (Array.to_list Sys.argv) ;
print_active_checkers ()
let () =
( if Config.linters_validate_syntax_only then
match CTLParserHelper.validate_al_files () with
| Ok ()
-> L.exit 0
| Error e
-> print_endline e ; L.exit 3 ) ;
| Ok () ->
L.exit 0
| Error e ->
print_endline e ; L.exit 3 ) ;
if Config.print_builtins then Builtin.print_and_exit () ;
setup () ;
log_environment_info () ;
if Config.debug_mode && CLOpt.is_originator then
L.progress "Logs in %s@." (Config.results_dir ^/ Config.log_file) ;
match Config.command with
| Analyze
-> let pp_cluster_opt fmt = function
| None
-> F.fprintf fmt "(no cluster)"
| Some cluster
-> F.fprintf fmt "of cluster %s" (Filename.basename cluster)
| Analyze ->
let pp_cluster_opt fmt = function
| None ->
F.fprintf fmt "(no cluster)"
| Some cluster ->
F.fprintf fmt "of cluster %s" (Filename.basename cluster)
in
L.environment_info "Starting analysis %a" pp_cluster_opt Config.cluster_cmdline ;
if Config.developer_mode then InferAnalyze.register_perf_stats_report () ;
Driver.analyze_and_report Analyze ~changed_files:(Driver.read_config_changed_files ())
| Report
-> InferPrint.main ~report_csv:Config.issues_csv ~report_json:None
| ReportDiff
-> (* at least one report must be passed in input to compute differential *)
| Report ->
InferPrint.main ~report_csv:Config.issues_csv ~report_json:None
| ReportDiff ->
(* at least one report must be passed in input to compute differential *)
( match (Config.report_current, Config.report_previous) with
| None, None
-> L.(die UserError)
| None, None ->
L.(die UserError)
"Expected at least one argument among 'report-current' and 'report-previous'"
| _
-> () ) ;
| _ ->
() ) ;
ReportDiff.reportdiff ~current_report:Config.report_current
~previous_report:Config.report_previous
| Capture | Compile | Run
-> run (Lazy.force Driver.mode_from_command_line)
| Diff
-> Diff.diff (Lazy.force Driver.mode_from_command_line)
| Explore
-> let if_some key opt args =
| Capture | Compile | Run ->
run (Lazy.force Driver.mode_from_command_line)
| Diff ->
Diff.diff (Lazy.force Driver.mode_from_command_line)
| Explore ->
let if_some key opt args =
match opt with None -> args | Some arg -> key :: string_of_int arg :: args
in
let if_true key opt args = if not opt then args else key :: args in
@ -122,3 +127,4 @@ let () =
L.external_error
"** Error running the reporting script:@\n** %s %s@\n** See error above@." prog
(String.concat ~sep:" " args)

180
infer/src/backend/inferconfig.ml
Unescape View File

@ -30,6 +30,7 @@ let do_not_filter : filters =
; error_filter= default_error_filter
; proc_filter= default_proc_filter }
type filter_config =
{ whitelist: string list
; blacklist: string list
@ -44,12 +45,14 @@ let is_matching patterns source_file =
with Not_found -> false)
patterns
(** Check if a proc name is matching the name given as string. *)
let match_method language proc_name method_name =
not (BuiltinDecl.is_declared proc_name)
&& Config.equal_language (Typ.Procname.get_language proc_name) language
&& String.equal (Typ.Procname.get_method proc_name) method_name
(* Module to create matcher based on strings present in the source file *)
module FileContainsStringMatcher = struct
type matcher = SourceFile.t -> bool
@ -59,13 +62,14 @@ module FileContainsStringMatcher = struct
let file_contains regexp file_in =
let rec loop () =
try Str.search_forward regexp (In_channel.input_line_exn file_in) 0 >= 0 with
| Not_found
-> loop ()
| End_of_file
-> false
| Not_found ->
loop ()
| End_of_file ->
false
in
loop ()
let create_matcher s_patterns =
if List.is_empty s_patterns then default_matcher
else
@ -81,6 +85,7 @@ module FileContainsStringMatcher = struct
source_map := SourceFile.Map.add source_file pattern_found !source_map ;
pattern_found
with Sys_error _ -> false
end
type method_pattern =
@ -123,13 +128,14 @@ module FileOrProcMatcher = struct
fun _ proc_name ->
match proc_name with Typ.Procname.Java pname_java -> do_java pname_java | _ -> false
let create_file_matcher patterns =
let s_patterns, m_patterns =
let collect (s_patterns, m_patterns) = function
| Source_contains (_, s)
-> (s :: s_patterns, m_patterns)
| Method_pattern (_, mp)
-> (s_patterns, mp :: m_patterns)
| Source_contains (_, s) ->
(s :: s_patterns, m_patterns)
| Method_pattern (_, mp) ->
(s_patterns, mp :: m_patterns)
in
List.fold ~f:collect ~init:([], []) patterns
in
@ -139,15 +145,16 @@ module FileOrProcMatcher = struct
and m_matcher = create_method_matcher m_patterns in
fun source_file proc_name -> m_matcher source_file proc_name || s_matcher source_file proc_name
let load_matcher = create_file_matcher
let _pp_pattern fmt pattern =
let pp_string fmt s = Format.fprintf fmt "%s" s in
let pp_option pp_value fmt = function
| None
-> pp_string fmt "None"
| Some value
-> Format.fprintf fmt "%a" pp_value value
| None ->
pp_string fmt "None"
| Some value ->
Format.fprintf fmt "%a" pp_value value
in
let pp_key_value pp_value fmt (key, value) =
Format.fprintf fmt " %s: %a,@\n" key (pp_option pp_value) value
@ -161,12 +168,15 @@ module FileOrProcMatcher = struct
("parameters", mp.parameters)
and pp_source_contains fmt sc = Format.fprintf fmt " pattern: %s@\n" sc in
match pattern with
| Method_pattern (language, mp)
-> Format.fprintf fmt "Method pattern (%s) {@\n%a}@\n" (Config.string_of_language language)
| Method_pattern (language, mp) ->
Format.fprintf fmt "Method pattern (%s) {@\n%a}@\n"
(Config.string_of_language language)
pp_method_pattern mp
| Source_contains (language, sc)
-> Format.fprintf fmt "Source contains (%s) {@\n%a}@\n" (Config.string_of_language language)
| Source_contains (language, sc) ->
Format.fprintf fmt "Source contains (%s) {@\n%a}@\n"
(Config.string_of_language language)
pp_source_contains sc
end
(* of module FileOrProcMatcher *)
@ -174,62 +184,63 @@ end
module OverridesMatcher = struct
let load_matcher patterns is_subtype proc_name =
let is_matching = function
| Method_pattern (language, mp)
-> is_subtype mp.class_name
| Method_pattern (language, mp) ->
is_subtype mp.class_name
&& Option.value_map ~f:(match_method language proc_name) ~default:false mp.method_name
| _
-> L.(die UserError) "Expecting method pattern"
| _ ->
L.(die UserError) "Expecting method pattern"
in
List.exists ~f:is_matching patterns
end
let patterns_of_json_with_key (json_key, json) =
let default_method_pattern = {class_name= ""; method_name= None; parameters= None} in
let default_source_contains = "" in
let language_of_string = function
| "Java"
-> Ok Config.Java
| l
-> Error ("JSON key " ^ json_key ^ " not supported for language " ^ l)
| "Java" ->
Ok Config.Java
| l ->
Error ("JSON key " ^ json_key ^ " not supported for language " ^ l)
in
let rec detect_language = function
| []
-> Error ("No language found for " ^ json_key)
| ("language", `String s) :: _
-> language_of_string s
| _ :: tl
-> detect_language tl
| [] ->
Error ("No language found for " ^ json_key)
| ("language", `String s) :: _ ->
language_of_string s
| _ :: tl ->
detect_language tl
in
(* Detect the kind of pattern, method pattern or pattern based on the content of the source file.
Detecting the kind of patterns in a first step makes it easier to parse the parts of the
pattern in a second step *)
let detect_pattern assoc =
match detect_language assoc with
| Ok language
-> let is_method_pattern key = List.exists ~f:(String.equal key) ["class"; "method"]
| Ok language ->
let is_method_pattern key = List.exists ~f:(String.equal key) ["class"; "method"]
and is_source_contains key = List.exists ~f:(String.equal key) ["source_contains"] in
let rec loop = function
| []
-> Error ("Unknown pattern for " ^ json_key)
| (key, _) :: _ when is_method_pattern key
-> Ok (Method_pattern (language, default_method_pattern))
| (key, _) :: _ when is_source_contains key
-> Ok (Source_contains (language, default_source_contains))
| _ :: tl
-> loop tl
| [] ->
Error ("Unknown pattern for " ^ json_key)
| (key, _) :: _ when is_method_pattern key ->
Ok (Method_pattern (language, default_method_pattern))
| (key, _) :: _ when is_source_contains key ->
Ok (Source_contains (language, default_source_contains))
| _ :: tl ->
loop tl
in
loop assoc
| Error _ as error
-> error
| Error _ as error ->
error
in
(* Translate a JSON entry into a matching pattern *)
let create_pattern (assoc: (string * Yojson.Basic.json) list) =
let collect_params l =
let collect accu = function
| `String s
-> s :: accu
| _
-> L.(die UserError)
| `String s ->
s :: accu
| _ ->
L.(die UserError)
"Unrecognised parameters in %s"
(Yojson.Basic.to_string (`Assoc assoc))
in
@ -237,74 +248,80 @@ let patterns_of_json_with_key (json_key, json) =
in
let create_method_pattern assoc =
let loop mp = function
| key, `String s when String.equal key "class"
-> {mp with class_name= s}
| key, `String s when String.equal key "method"
-> {mp with method_name= Some s}
| key, `List l when String.equal key "parameters"
-> {mp with parameters= Some (collect_params l)}
| key, _ when String.equal key "language"
-> mp
| _
-> L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc))
| key, `String s when String.equal key "class" ->
{mp with class_name= s}
| key, `String s when String.equal key "method" ->
{mp with method_name= Some s}
| key, `List l when String.equal key "parameters" ->
{mp with parameters= Some (collect_params l)}
| key, _ when String.equal key "language" ->
mp
| _ ->
L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc))
in
List.fold ~f:loop ~init:default_method_pattern assoc
and create_string_contains assoc =
let loop sc = function
| key, `String pattern when String.equal key "source_contains"
-> pattern
| key, _ when String.equal key "language"
-> sc
| _
-> L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc))
| key, `String pattern when String.equal key "source_contains" ->
pattern
| key, _ when String.equal key "language" ->
sc
| _ ->
L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc))
in
List.fold ~f:loop ~init:default_source_contains assoc
in
match detect_pattern assoc with
| Ok Method_pattern (language, _)
-> Ok (Method_pattern (language, create_method_pattern assoc))
| Ok Source_contains (language, _)
-> Ok (Source_contains (language, create_string_contains assoc))
| Error _ as error
-> error
| Ok Method_pattern (language, _) ->
Ok (Method_pattern (language, create_method_pattern assoc))
| Ok Source_contains (language, _) ->
Ok (Source_contains (language, create_string_contains assoc))
| Error _ as error ->
error
in
let warn_user msg = CLOpt.warnf "WARNING: error parsing option %s@\n%s@." json_key msg in
(* Translate all the JSON entries into matching patterns *)
let rec translate accu = function
| `Assoc l -> (
match create_pattern l with
| Ok pattern
-> pattern :: accu
| Error msg
-> warn_user msg ; accu )
| `List l
-> List.fold ~f:translate ~init:accu l
| json
-> warn_user
| Ok pattern ->
pattern :: accu
| Error msg ->
warn_user msg ; accu )
| `List l ->
List.fold ~f:translate ~init:accu l
| json ->
warn_user
(Printf.sprintf "expected list or assoc json type, but got value %s"
(Yojson.Basic.to_string json)) ;
accu
in
translate [] json
let modeled_expensive_matcher =
OverridesMatcher.load_matcher (patterns_of_json_with_key Config.patterns_modeled_expensive)
let never_return_null_matcher =
FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_never_returning_null)
let skip_translation_matcher =
FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_skip_translation)
let skip_implementation_matcher =
FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_skip_implementation)
let load_filters analyzer =
{ whitelist= Config.analysis_path_regex_whitelist analyzer
; blacklist= Config.analysis_path_regex_blacklist analyzer
; blacklist_files_containing= Config.analysis_blacklist_files_containing analyzer
; suppress_errors= Config.analysis_suppress_errors analyzer }
let filters_from_inferconfig inferconfig : filters =
let path_filter =
let whitelist_filter : path_filter =
@ -318,22 +335,24 @@ let filters_from_inferconfig inferconfig : filters =
FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing
in
function
| source_file
-> whitelist_filter source_file && not (blacklist_filter source_file)
| source_file ->
whitelist_filter source_file && not (blacklist_filter source_file)
&& not (blacklist_files_containing_filter source_file)
in
let error_filter = function
| error_name
-> let error_str = error_name.IssueType.unique_id in
| error_name ->
let error_str = error_name.IssueType.unique_id in
not (List.exists ~f:(String.equal error_str) inferconfig.suppress_errors)
in
{path_filter; error_filter; proc_filter= default_proc_filter}
(* Create filters based on .inferconfig *)
let create_filters analyzer =
if not Config.filter_paths then do_not_filter
else filters_from_inferconfig (load_filters analyzer)
(* This function loads and list the path that are being filtered by the analyzer. The results *)
(* are of the form: path/to/file.java -> {infer, checkers} meaning that analysis results will *)
(* be reported on path/to/file.java both for infer and for the checkers *)
@ -357,3 +376,4 @@ let test () =
let matching_s = String.concat ~sep:", " (List.map ~f:fst matching) in
L.result "%s -> {%s}@." (SourceFile.to_rel_path source_file) matching_s)
(Sys.getcwd ())

412
infer/src/backend/interproc.ml
Unescape View File

@ -28,37 +28,41 @@ module NodeVisitSet = Caml.Set.Make (struct
(* higher id is better *)
Procdesc.Node.compare n2 n1
let compare_distance_to_exit {node= n1} {node= n2} =
(* smaller means higher priority *)
let n =
match (Procdesc.Node.get_distance_to_exit n1, Procdesc.Node.get_distance_to_exit n2) with
| None, None
-> 0
| None, Some _
-> 1
| Some _, None
-> -1
| Some d1, Some d2
-> (* shorter distance to exit is better *)
| None, None ->
0
| None, Some _ ->
1
| Some _, None ->
-1
| Some d1, Some d2 ->
(* shorter distance to exit is better *)
Int.compare d1 d2
in
if n <> 0 then n else compare_ids n1 n2
let compare_number_of_visits x1 x2 =
let n = Int.compare x1.visits x2.visits in
(* visited fewer times is better *)
if n <> 0 then n else compare_distance_to_exit x1 x2
let compare x1 x2 =
if !Config.footprint then
match Config.worklist_mode with
| 0
-> compare_ids x1.node x2.node
| 1
-> compare_distance_to_exit x1 x2
| _
-> compare_number_of_visits x1 x2
| 0 ->
compare_ids x1.node x2.node
| 1 ->
compare_distance_to_exit x1 x2
| _ ->
compare_number_of_visits x1 x2
else compare_ids x1.node x2.node
end)
(** Table for the results of the join operation on nodes. *)
@ -79,6 +83,7 @@ end = struct
try Hashtbl.find table i
with Not_found -> Paths.PathSet.empty
let add table i dset = Hashtbl.replace table i dset
end
@ -98,6 +103,7 @@ module Worklist = struct
; todo_set= NodeVisitSet.empty
; visit_map= Procdesc.NodeMap.empty }
let is_empty (wl: t) : bool = NodeVisitSet.is_empty wl.todo_set
let add (wl: t) (node: Procdesc.Node.t) : unit =
@ -108,6 +114,7 @@ module Worklist = struct
in
wl.todo_set <- NodeVisitSet.add {node; visits} wl.todo_set
(** remove the minimum element from the worklist, and increase its number of visits *)
let remove (wl: t) : Procdesc.Node.t =
try
@ -119,6 +126,7 @@ module Worklist = struct
with Not_found ->
L.internal_error "@\n...Work list is empty! Impossible to remove edge...@\n" ;
assert false
end
(* =============== END of module Worklist =============== *)
@ -129,10 +137,14 @@ let path_set_create_worklist proc_cfg =
Procdesc.compute_distance_to_exit_node (ProcCfg.Exceptional.proc_desc proc_cfg) ;
Worklist.create ()
let htable_retrieve (htable: (Procdesc.Node.id, Paths.PathSet.t) Hashtbl.t) (key: Procdesc.Node.id)
: Paths.PathSet.t =
try Hashtbl.find htable key
with Not_found -> Hashtbl.replace htable key Paths.PathSet.empty ; Paths.PathSet.empty
with Not_found ->
Hashtbl.replace htable key Paths.PathSet.empty ;
Paths.PathSet.empty
(** Add [d] to the pathset todo at [node] returning true if changed *)
let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet.t) : bool =
@ -150,6 +162,7 @@ let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet
in
changed
let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.PathSet.t =
try
let node_id = Procdesc.Node.get_id node in
@ -157,15 +170,18 @@ let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.Path
Hashtbl.replace wl.Worklist.path_set_todo node_id Paths.PathSet.empty ;
let visited = Hashtbl.find wl.Worklist.path_set_visited node_id in
let new_visited = Paths.PathSet.union visited todo in
Hashtbl.replace wl.Worklist.path_set_visited node_id new_visited ; todo
Hashtbl.replace wl.Worklist.path_set_visited node_id new_visited ;
todo
with Not_found -> L.die InternalError "could not find todo for node %a" Procdesc.Node.pp node
(* =============== END of the edge_set object =============== *)
let collect_do_abstract_pre pname tenv (pset: Propset.t) : Propset.t =
if !Config.footprint then Config.run_in_re_execution_mode (Abs.lifted_abstract pname tenv) pset
else Abs.lifted_abstract pname tenv pset
let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathSet.t =
let abs_option p =
if Prover.check_inconsistency tenv p then None else Some (Abs.abstract pname tenv p)
@ -174,16 +190,19 @@ let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathS
Config.run_in_re_execution_mode (Paths.PathSet.map_option abs_option) pathset
else Paths.PathSet.map_option abs_option pathset
let do_join_pre plist = Dom.proplist_collapse_pre plist
let do_join_post pname tenv (pset: Paths.PathSet.t) =
if Config.spec_abs_level <= 0 then Dom.pathset_collapse tenv pset
else Dom.pathset_collapse tenv (Dom.pathset_collapse_impl pname tenv pset)
let do_meet_pre tenv pset =
if Config.meet_level > 0 then Dom.propset_meet_generate_pre tenv pset
else Propset.to_proplist pset
(** Find the preconditions in the current spec table,
apply meet then join, and return the joined preconditions *)
let collect_preconditions tenv summary : Prop.normal Specs.Jprop.t list =
@ -247,6 +266,7 @@ let collect_preconditions tenv summary : Prop.normal Specs.Jprop.t list =
L.d_ln () ;
jplist''
(* =============== START of symbolic execution =============== *)
(** propagate a set of results to the given node *)
@ -265,6 +285,7 @@ let propagate (wl: Worklist.t) pname ~is_exception (pset: Paths.PathSet.t)
let changed = path_set_put_todo wl curr_node edgeset_todo in
if changed then Worklist.add wl curr_node
(** propagate a set of results, including exceptions and divergence *)
let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Paths.PathSet.t)
(succ_nodes: Procdesc.Node.t list) (exn_nodes: Procdesc.Node.t list) (wl: Worklist.t) =
@ -289,6 +310,7 @@ let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Pat
List.iter ~f:(propagate wl pname ~is_exception:false pset_ok) succ_nodes ;
List.iter ~f:(propagate wl pname ~is_exception:true pset_exn) exn_nodes
(* ===================== END of symbolic execution ===================== *)
(* =============== START of forward_tabulate =============== *)
@ -312,6 +334,7 @@ let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo: Paths.PathSet.t) =
new_dset')
succ_nodes
let prop_max_size = ref (0, Prop.prop_emp)
let prop_max_chain_size = ref (0, Prop.prop_emp)
@ -325,14 +348,17 @@ let check_prop_size_ p _ =
Prop.d_prop p ;
L.d_ln () )
(* Check prop size and filter out possible unabstracted lists *)
let check_prop_size edgeset_todo =
if Config.monitor_prop_size then Paths.PathSet.iter check_prop_size_ edgeset_todo
let reset_prop_metrics () =
prop_max_size := (0, Prop.prop_emp) ;
prop_max_chain_size := (0, Prop.prop_emp)
exception RE_EXE_ERROR
let do_before_node session node =
@ -341,6 +367,7 @@ let do_before_node session node =
L.reset_delayed_prints () ;
Printer.node_start_session node (session :> int)
let do_after_node node = Printer.node_finish_session node
(** Return the list of normal ids occurring in the instructions *)
@ -351,7 +378,10 @@ let instrs_get_normal_vars instrs =
let exps = Sil.instr_get_exps instr in
List.iter ~f:do_e exps
in
List.iter ~f:do_instr instrs ; Sil.fav_filter_ident fav Ident.is_normal ; Sil.fav_to_list fav
List.iter ~f:do_instr instrs ;
Sil.fav_filter_ident fav Ident.is_normal ;
Sil.fav_to_list fav
(** Perform symbolic execution for a node starting from an initial prop *)
let do_symbolic_execution proc_cfg handle_exn tenv (node: ProcCfg.Exceptional.node)
@ -373,6 +403,7 @@ let do_symbolic_execution proc_cfg handle_exn tenv (node: ProcCfg.Exceptional.no
State.mark_execution_end node ;
pset
let mark_visited summary node =
let node_id = Procdesc.Node.get_id node in
let stats = summary.Specs.stats in
@ -380,6 +411,7 @@ let mark_visited summary node =
stats.Specs.nodes_visited_fp <- IntSet.add (node_id :> int) stats.Specs.nodes_visited_fp
else stats.Specs.nodes_visited_re <- IntSet.add (node_id :> int) stats.Specs.nodes_visited_re
let forward_tabulate tenv proc_cfg wl =
let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in
let handle_exn_node curr_node exn =
@ -389,10 +421,10 @@ let forward_tabulate tenv proc_cfg wl =
State.get_normalized_pre (Abs.abstract_no_symop pname)
in
( match pre_opt with
| Some pre
-> L.d_strln "Precondition:" ; Prop.d_prop pre ; L.d_ln ()
| None
-> () ) ;
| Some pre ->
L.d_strln "Precondition:" ; Prop.d_prop pre ; L.d_ln ()
| None ->
() ) ;
L.d_strln "SIL INSTR:" ;
Procdesc.Node.d_instrs ~sub_instrs:true (State.get_instr ()) curr_node ;
L.d_ln () ;
@ -452,14 +484,14 @@ let forward_tabulate tenv proc_cfg wl =
check_prop_size pathset_todo ;
print_node_preamble curr_node session pathset_todo ;
match Procdesc.Node.get_kind curr_node with
| Procdesc.Node.Join_node
-> do_symexec_join proc_cfg tenv wl curr_node pathset_todo
| Procdesc.Node.Join_node ->
do_symexec_join proc_cfg tenv wl curr_node pathset_todo
| Procdesc.Node.Stmt_node _
| Procdesc.Node.Prune_node _
| Procdesc.Node.Exit_node _
| Procdesc.Node.Skip_node _
| Procdesc.Node.Start_node _
-> exe_iter (do_prop curr_node handle_exn) pathset_todo
| Procdesc.Node.Start_node _ ->
exe_iter (do_prop curr_node handle_exn) pathset_todo
in
let do_node_and_handle curr_node session =
let pathset_todo = path_set_checkout_todo wl curr_node in
@ -485,38 +517,40 @@ let forward_tabulate tenv proc_cfg wl =
mark_visited summary curr_node ;
(* mark nodes visited in fp and re phases *)
let session = incr summary.Specs.sessions ; !(summary.Specs.sessions) in
do_before_node session curr_node ; do_node_and_handle curr_node session
do_before_node session curr_node ;
do_node_and_handle curr_node session
done ;
L.d_strln ".... Work list empty. Stop ...." ;
L.d_ln ()
(** if possible, produce a (fieldname, typ) path from one of the [src_exps] to [sink_exp] using
[reachable_hpreds]. *)
let get_fld_typ_path_opt src_exps sink_exp_ reachable_hpreds_ =
let strexp_matches target_exp = function
| Sil.Eexp (e, _)
-> Exp.equal target_exp e
| _
-> false
| Sil.Eexp (e, _) ->
Exp.equal target_exp e
| _ ->
false
in
let extend_path hpred (sink_exp, path, reachable_hpreds) =
match hpred with
| Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Exp.Sizeof {typ})
-> List.find ~f:(function _, se -> strexp_matches sink_exp se) flds
| Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Exp.Sizeof {typ}) ->
List.find ~f:(function _, se -> strexp_matches sink_exp se) flds
|> Option.value_map
~f:(function
| fld, _
-> let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
| fld, _ ->
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
(lhs, (Some fld, typ) :: path, reachable_hpreds'))
~default:(sink_exp, path, reachable_hpreds)
| Sil.Hpointsto (lhs, Sil.Earray (_, elems, _), Exp.Sizeof {typ})
-> if List.exists ~f:(function _, se -> strexp_matches sink_exp se) elems then
| Sil.Hpointsto (lhs, Sil.Earray (_, elems, _), Exp.Sizeof {typ}) ->
if List.exists ~f:(function _, se -> strexp_matches sink_exp se) elems then
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
(* None means "no field name" ~=~ nameless array index *)
(lhs, (None, typ) :: path, reachable_hpreds')
else (sink_exp, path, reachable_hpreds)
| _
-> (sink_exp, path, reachable_hpreds)
| _ ->
(sink_exp, path, reachable_hpreds)
in
(* terminates because [reachable_hpreds] is shrinking on each recursive call *)
let rec get_fld_typ_path sink_exp path reachable_hpreds =
@ -530,6 +564,7 @@ let get_fld_typ_path_opt src_exps sink_exp_ reachable_hpreds_ =
in
get_fld_typ_path sink_exp_ [] reachable_hpreds_
(** report an error if any Context is reachable from a static field *)
let report_context_leaks pname sigma tenv =
(* report an error if an expression in [context_exps] is reachable from [field_strexp] *)
@ -541,10 +576,10 @@ let report_context_leaks pname sigma tenv =
~f:(fun (context_exp, name) ->
if Exp.Set.mem context_exp reachable_exps then
match get_fld_typ_path_opt fld_exps context_exp reachable_hpreds with
| None
-> () (* TODO (T21871205): the underlying issue still need to be fixed *)
| Some leak_path
-> let err_desc =
| None ->
() (* TODO (T21871205): the underlying issue still need to be fixed *)
| Some leak_path ->
let err_desc =
Errdesc.explain_context_leak pname (Typ.mk (Tstruct name)) fld_name leak_path
in
let exn = Exceptions.Context_leak (err_desc, __POS__) in
@ -558,23 +593,24 @@ let report_context_leaks pname sigma tenv =
match hpred with
| Sil.Hpointsto (_, Eexp (exp, _), Sizeof {typ= {desc= Tptr ({desc= Tstruct name}, _)}})
when not (Exp.is_null_literal exp) && AndroidFramework.is_context tenv name
&& not (AndroidFramework.is_application tenv name)
-> (exp, name) :: exps
| _
-> exps)
&& not (AndroidFramework.is_application tenv name) ->
(exp, name) :: exps
| _ ->
exps)
~init:[] sigma
in
List.iter
~f:(function
| Sil.Hpointsto (Exp.Lvar pv, Sil.Estruct (static_flds, _), _) when Pvar.is_global pv
-> List.iter
| Sil.Hpointsto (Exp.Lvar pv, Sil.Estruct (static_flds, _), _) when Pvar.is_global pv ->
List.iter
~f:(fun (f_name, f_strexp) ->
check_reachable_context_from_fld (f_name, f_strexp) context_exps)
static_flds
| _
-> ())
| _ ->
())
sigma
(** Remove locals and formals,
and check if the address of a stack variable is left in the result *)
let remove_locals_formals_and_check tenv proc_cfg p =
@ -590,6 +626,7 @@ let remove_locals_formals_and_check tenv proc_cfg p =
in
List.iter ~f:check_pvar pvars ; p'
(** Collect the analysis results for the exit node. *)
let collect_analysis_result tenv wl proc_cfg : Paths.PathSet.t =
let exit_node = ProcCfg.Exceptional.exit_node proc_cfg in
@ -597,6 +634,7 @@ let collect_analysis_result tenv wl proc_cfg : Paths.PathSet.t =
let pathset = htable_retrieve wl.Worklist.path_set_visited exit_node_id in
Paths.PathSet.map (remove_locals_formals_and_check tenv proc_cfg) pathset
module Pmap = Caml.Map.Make (struct
type t = Prop.normal Prop.t
@ -606,9 +644,11 @@ end)
let vset_ref_add_path vset_ref path =
Paths.Path.iter_all_nodes_nocalls (fun n -> vset_ref := Procdesc.NodeSet.add n !vset_ref) path
let vset_ref_add_pathset vset_ref pathset =
Paths.PathSet.iter (fun _ path -> vset_ref_add_path vset_ref path) pathset
let compute_visited vset =
let res = ref Specs.Visitedset.empty in
let node_get_all_lines n =
@ -620,7 +660,9 @@ let compute_visited vset =
let do_node n =
res := Specs.Visitedset.add (Procdesc.Node.get_id n, node_get_all_lines n) !res
in
Procdesc.NodeSet.iter do_node vset ; !res
Procdesc.NodeSet.iter do_node vset ;
!res
(** Extract specs from a pathset *)
let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
@ -665,10 +707,10 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
in
let new_posts =
match post with
| None
-> current_posts
| Some (post, path)
-> Paths.PathSet.add_renamed_prop post path current_posts
| None ->
current_posts
| Some (post, path) ->
Paths.PathSet.add_renamed_prop post path current_posts
in
let new_visited = Specs.Visitedset.union visited current_visited in
Pmap.add pre (new_posts, new_visited) map
@ -682,21 +724,20 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
~f:(fun (p, path) -> (PropUtil.remove_seed_vars tenv p, path))
(Paths.PathSet.elements (do_join_post pname tenv posts))
in
let spec =
{Specs.pre= Specs.Jprop.Prop (1, pre); Specs.posts= posts'; Specs.visited= visited}
in
let spec = {Specs.pre= Specs.Jprop.Prop (1, pre); Specs.posts= posts'; Specs.visited} in
specs := spec :: !specs
in
Pmap.iter add_spec pre_post_map ; !specs
let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset.t =
let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in
let pathset = collect_analysis_result tenv wl proc_cfg in
(* Assuming C++ developers use RAII, remove resources from the constructor posts *)
let pathset =
match pname with
| Typ.Procname.ObjC_Cpp _
-> if Typ.Procname.is_constructor pname then
| Typ.Procname.ObjC_Cpp _ ->
if Typ.Procname.is_constructor pname then
Paths.PathSet.map
(fun prop ->
Attribute.remove_resource tenv Racquire (Rmemory Mobjc)
@ -704,8 +745,8 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset
(Attribute.remove_resource tenv Racquire Rfile prop)))
pathset
else pathset
| _
-> pathset
| _ ->
pathset
in
L.d_strln ("#### [FUNCTION " ^ Typ.Procname.to_string pname ^ "] Analysis result ####") ;
Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pathset) ;
@ -733,15 +774,17 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset
L.d_ln () ;
res
let create_seed_vars sigma =
let hpred_add_seed sigma = function
| Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv)
-> Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma
| _
-> sigma
| Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) ->
Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma
| _ ->
sigma
in
List.fold ~f:hpred_add_seed ~init:[] sigma
(** Initialize proposition for execution given formal and global
parameters. The footprint is initialized according to the
execution mode. The prop is not necessarily emp, so it
@ -751,26 +794,27 @@ let prop_init_formals_seed tenv new_formals (prop: 'a Prop.t) : Prop.exposed Pro
let do_formal (pv, typ) =
let texp =
match !Config.curr_language with
| Config.Clang
-> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}
| Config.Java
-> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
| Config.Python
-> L.die InternalError "prop_init_formals_seed not implemented for Python"
| Config.Clang ->
Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}
| Config.Java ->
Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
| Config.Python ->
L.die InternalError "prop_init_formals_seed not implemented for Python"
in
Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_formal (pv, texp, None)
in
List.map ~f:do_formal new_formals
in
let sigma_seed =
create_seed_vars (* formals already there plus new ones *)
(prop.Prop.sigma @ sigma_new_formals)
create_seed_vars ((* formals already there plus new ones *)
prop.Prop.sigma @ sigma_new_formals)
in
let sigma = sigma_seed @ sigma_new_formals in
let new_pi = prop.Prop.pi in
let prop' = Prop.set (Prop.prop_sigma_star prop sigma) ~pi:new_pi in
Prop.set prop' ~sigma_fp:(prop'.Prop.sigma_fp @ sigma_new_formals)
(** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true
as well as seed variables *)
let initial_prop tenv (curr_f: Procdesc.t) (prop: 'a Prop.t) add_formals : Prop.normal Prop.t =
@ -785,6 +829,7 @@ let initial_prop tenv (curr_f: Procdesc.t) (prop: 'a Prop.t) add_formals : Prop.
let prop2 = prop_init_formals_seed tenv new_formals prop1 in
Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2)
(** Construct an initial prop from the empty prop *)
let initial_prop_from_emp tenv curr_f = initial_prop tenv curr_f Prop.prop_emp true
@ -801,6 +846,7 @@ let initial_prop_from_pre tenv curr_f pre =
initial_prop tenv curr_f pre3 false
else initial_prop tenv curr_f pre false
(** Re-execute one precondition and return some spec if there was no re-execution error. *)
let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Specs.Jprop.t)
: Prop.normal Specs.spec option =
@ -841,12 +887,12 @@ let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Sp
let pre =
let p = PropUtil.remove_locals_ret tenv pdesc (Specs.Jprop.to_prop precondition) in
match precondition with
| Specs.Jprop.Prop (n, _)
-> Specs.Jprop.Prop (n, p)
| Specs.Jprop.Joined (n, _, jp1, jp2)
-> Specs.Jprop.Joined (n, p, jp1, jp2)
| Specs.Jprop.Prop (n, _) ->
Specs.Jprop.Prop (n, p)
| Specs.Jprop.Joined (n, _, jp1, jp2) ->
Specs.Jprop.Joined (n, p, jp1, jp2)
in
let spec = {Specs.pre= pre; Specs.posts= posts; Specs.visited= visited} in
let spec = {Specs.pre; Specs.posts; Specs.visited} in
L.d_decrease_indent 1 ; do_after_node init_node ; Some spec
with RE_EXE_ERROR ->
do_before_node 0 init_node ;
@ -860,6 +906,7 @@ let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Sp
do_after_node init_node ;
None
let pp_intra_stats wl proc_cfg fmt _ =
let nstates = ref 0 in
let nodes = ProcCfg.Exceptional.nodes proc_cfg in
@ -872,6 +919,7 @@ let pp_intra_stats wl proc_cfg fmt _ =
nodes ;
F.fprintf fmt "(%d nodes containing %d states)" (List.length nodes) !nstates
type exe_phase = (unit -> unit) * (unit -> Prop.normal Specs.spec list * Specs.phase)
(** Return functions to perform one phase of the analysis for a procedure.
@ -933,7 +981,8 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce
Exceptions.Internal_error
(Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint")
in
Reporting.log_error_deprecated pname exn ; (* retuning no specs *) []
Reporting.log_error_deprecated pname exn ;
(* retuning no specs *) []
in
(specs, Specs.FOOTPRINT)
in
@ -952,10 +1001,10 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce
let speco = execute_filter_prop wl tenv proc_cfg start_node p in
let is_valid =
match speco with
| None
-> false
| Some spec
-> valid_specs := !valid_specs @ [spec] ;
| None ->
false
| Some spec ->
valid_specs := !valid_specs @ [spec] ;
true
in
let outcome = if is_valid then "pass" else "fail" in
@ -982,26 +1031,32 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce
L.(debug Analysis Medium) "@\n *** CANDIDATE PRECONDITIONS FOR %a: " Typ.Procname.pp pname ;
L.(debug Analysis Medium) "@\n================================================@\n" ;
L.(debug Analysis Medium)
"@\n%a @\n@\n" (Specs.Jprop.pp_list Pp.text false) candidate_preconditions ;
"@\n%a @\n@\n"
(Specs.Jprop.pp_list Pp.text false)
candidate_preconditions ;
L.(debug Analysis Medium) "@\n@\n================================================" ;
L.(debug Analysis Medium) "@\n *** VALID PRECONDITIONS FOR %a: " Typ.Procname.pp pname ;
L.(debug Analysis Medium) "@\n================================================@\n" ;
L.(debug Analysis Medium)
"@\n%a @\n@." (Specs.Jprop.pp_list Pp.text true) valid_preconditions ;
"@\n%a @\n@."
(Specs.Jprop.pp_list Pp.text true)
valid_preconditions ;
(specs, Specs.RE_EXECUTION)
in
(go, get_results)
in
match Specs.get_phase summary with
| Specs.FOOTPRINT
-> compute_footprint ()
| Specs.RE_EXECUTION
-> re_execution ()
| Specs.FOOTPRINT ->
compute_footprint ()
| Specs.RE_EXECUTION ->
re_execution ()
let set_current_language proc_desc =
let language = (Procdesc.get_attributes proc_desc).ProcAttributes.language in
Config.curr_language := language
(** reset global values before analysing a procedure *)
let reset_global_values proc_desc =
Config.reset_abs_val () ;
@ -1011,67 +1066,72 @@ let reset_global_values proc_desc =
Abs.reset_current_rules () ;
set_current_language proc_desc
(* Collect all pairs of the kind (precondition, runtime exception) from a summary *)
let exception_preconditions tenv pname summary =
let collect_exceptions pre (exns, all_post_exn) (prop, _) =
match Tabulation.prop_get_exn_name pname prop with
| Some exn_name when PatternMatch.is_runtime_exception tenv exn_name
-> ((pre, exn_name) :: exns, all_post_exn)
| _
-> (exns, false)
| Some exn_name when PatternMatch.is_runtime_exception tenv exn_name ->
((pre, exn_name) :: exns, all_post_exn)
| _ ->
(exns, false)
in
let collect_spec errors spec =
List.fold ~f:(collect_exceptions spec.Specs.pre) ~init:errors spec.Specs.posts
in
List.fold ~f:collect_spec ~init:([], true) (Specs.get_specs_from_payload summary)
(* Collect all pairs of the kind (precondition, custom error) from a summary *)
let custom_error_preconditions summary =
let collect_errors pre (errors, all_post_error) (prop, _) =
match Tabulation.lookup_custom_errors prop with
| None
-> (errors, false)
| Some e
-> ((pre, e) :: errors, all_post_error)
| None ->
(errors, false)
| Some e ->
((pre, e) :: errors, all_post_error)
in
let collect_spec errors spec =
List.fold ~f:(collect_errors spec.Specs.pre) ~init:errors spec.Specs.posts
in
List.fold ~f:collect_spec ~init:([], true) (Specs.get_specs_from_payload summary)
(* Remove the constrain of the form this != null which is true for all Java virtual calls *)
let remove_this_not_null tenv prop =
let collect_hpred (var_option, hpreds) = function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _)
when Config.curr_language_is Config.Java && Pvar.is_this pvar
-> (Some var, hpreds)
| hpred
-> (var_option, hpred :: hpreds)
when Config.curr_language_is Config.Java && Pvar.is_this pvar ->
(Some var, hpreds)
| hpred ->
(var_option, hpred :: hpreds)
in
let collect_atom var atoms = function
| Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null
-> atoms
| a
-> a :: atoms
| Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null ->
atoms
| a ->
a :: atoms
in
match List.fold ~f:collect_hpred ~init:(None, []) prop.Prop.sigma with
| None, _
-> prop
| Some var, filtered_hpreds
-> let filtered_atoms = List.fold ~f:(collect_atom var) ~init:[] prop.Prop.pi in
| None, _ ->
prop
| Some var, filtered_hpreds ->
let filtered_atoms = List.fold ~f:(collect_atom var) ~init:[] prop.Prop.pi in
let prop' = Prop.set Prop.prop_emp ~pi:filtered_atoms ~sigma:filtered_hpreds in
Prop.normalize tenv prop'
(** Is true when the precondition does not contain constrains that can be false at call site.
This means that the post-conditions associated with this precondition cannot be prevented
by the calling context. *)
let is_unavoidable tenv pre =
let prop = remove_this_not_null tenv (Specs.Jprop.to_prop pre) in
match Prop.CategorizePreconditions.categorize [prop] with
| Prop.CategorizePreconditions.NoPres | Prop.CategorizePreconditions.Empty
-> true
| _
-> false
| Prop.CategorizePreconditions.NoPres | Prop.CategorizePreconditions.Empty ->
true
| _ ->
false
(** Detects if there are specs of the form {precondition} proc {runtime exception} and report
an error in that case, generating the trace that lead to the runtime exception if the method is
@ -1085,11 +1145,11 @@ let report_runtime_exceptions tenv pdesc summary =
is_public_method
&&
match pname with
| Typ.Procname.Java pname_java
-> Typ.Procname.java_is_static pname
| Typ.Procname.Java pname_java ->
Typ.Procname.java_is_static pname
&& String.equal (Typ.Procname.java_get_method pname_java) "main"
| _
-> false
| _ ->
false
in
let is_annotated pdesc = Annotations.pdesc_has_return_annot pdesc Annotations.ia_is_verify in
let exn_preconditions, all_post_exn = exception_preconditions tenv pname summary in
@ -1105,6 +1165,7 @@ let report_runtime_exceptions tenv pdesc summary =
in
List.iter ~f:report exn_preconditions
let report_custom_errors tenv summary =
let pname = Specs.get_proc_name summary in
let error_preconditions, all_post_error = custom_error_preconditions summary in
@ -1117,6 +1178,7 @@ let report_custom_errors tenv summary =
in
List.iter ~f:report error_preconditions
module SpecMap = Caml.Map.Make (struct
type t = Prop.normal Specs.Jprop.t
@ -1180,7 +1242,7 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list)
let convert pre (post_set, visited) =
res
:= Specs.spec_normalize tenv
{Specs.pre= pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited= visited}
{Specs.pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited}
:: !res
in
List.iter ~f:re_exe_filter old_specs ;
@ -1190,6 +1252,7 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list)
SpecMap.iter convert !current_specs ;
(!res, !changed)
(** update a summary after analysing a procedure *)
let update_summary tenv prev_summary specs phase res =
let normal_specs = List.map ~f:(Specs.spec_normalize tenv) specs in
@ -1201,13 +1264,14 @@ let update_summary tenv prev_summary specs phase res =
let stats = {prev_summary.Specs.stats with symops; stats_failure} in
let preposts =
match phase with
| Specs.FOOTPRINT
-> Some new_specs
| Specs.RE_EXECUTION
-> Some (List.map ~f:(Specs.NormSpec.erase_join_info_pre tenv) new_specs)
| Specs.FOOTPRINT ->
Some new_specs
| Specs.RE_EXECUTION ->
Some (List.map ~f:(Specs.NormSpec.erase_join_info_pre tenv) new_specs)
in
let payload = {prev_summary.Specs.payload with Specs.preposts= preposts} in
{prev_summary with Specs.phase= phase; stats; payload}
let payload = {prev_summary.Specs.payload with Specs.preposts} in
{prev_summary with Specs.phase; stats; payload}
(** Analyze the procedure and return the resulting summary. *)
let analyze_proc tenv proc_cfg : Specs.summary =
@ -1225,6 +1289,7 @@ let analyze_proc tenv proc_cfg : Specs.summary =
report_runtime_exceptions tenv proc_desc updated_summary ;
updated_summary
(** Perform the transition from [FOOTPRINT] to [RE_EXECUTION] in spec table *)
let transition_footprint_re_exe tenv proc_name joined_pres =
L.(debug Analysis Medium) "Transition %a from footprint to re-exe@." Typ.Procname.pp proc_name ;
@ -1243,6 +1308,7 @@ let transition_footprint_re_exe tenv proc_name joined_pres =
in
Specs.add_summary proc_name summary'
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
the procedures enabled after the analysis of [proc_name] *)
let perform_transition proc_cfg tenv proc_name =
@ -1269,15 +1335,17 @@ let perform_transition proc_cfg tenv proc_name =
"Error in collect_preconditions for %a@." Typ.Procname.pp proc_name ;
let error = Exceptions.recognize_exception exn in
let err_str = "exception raised " ^ error.name.IssueType.unique_id in
L.(debug Analysis Medium) "Error: %s %a@." err_str L.pp_ml_loc_opt error.ml_loc ; []
L.(debug Analysis Medium) "Error: %s %a@." err_str L.pp_ml_loc_opt error.ml_loc ;
[]
in
transition_footprint_re_exe tenv proc_name joined_pres
in
match Specs.get_summary proc_name with
| Some summary when Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT
-> transition summary
| _
-> ()
| Some summary when Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT ->
transition summary
| _ ->
()
(* Create closures for the interprocedural algorithm *)
let interprocedural_algorithm_closures ~prepare_proc exe_env : Tasks.closure list =
@ -1289,17 +1357,18 @@ let interprocedural_algorithm_closures ~prepare_proc exe_env : Tasks.closure lis
| Some proc_desc
when Config.reactive_mode
(* in reactive mode, only analyze changed procedures *)
&& (Procdesc.get_attributes proc_desc).ProcAttributes.changed
-> analyze proc_desc
| Some proc_desc
-> analyze proc_desc
| None
-> ()
&& (Procdesc.get_attributes proc_desc).ProcAttributes.changed ->
analyze proc_desc
| Some proc_desc ->
analyze proc_desc
| None ->
()
in
let procs_to_analyze = Cg.get_defined_nodes call_graph in
let create_closure proc_name () = process_one_proc proc_name in
List.map ~f:create_closure procs_to_analyze
let analyze_procedure_aux cg_opt tenv proc_desc =
let proc_name = Procdesc.get_proc_name proc_desc in
let proc_cfg = ProcCfg.Exceptional.from_pdesc proc_desc in
@ -1311,17 +1380,20 @@ let analyze_procedure_aux cg_opt tenv proc_desc =
Specs.add_summary proc_name summaryfp ;
perform_transition proc_cfg tenv proc_name ;
let summaryre = Config.run_in_re_execution_mode (analyze_proc tenv) proc_cfg in
Specs.add_summary proc_name summaryre ; summaryre
Specs.add_summary proc_name summaryre ;
summaryre
let analyze_procedure {Callbacks.summary; proc_desc; tenv} : Specs.summary =
let proc_name = Procdesc.get_proc_name proc_desc in
Specs.add_summary proc_name summary ;
( try ignore (analyze_procedure_aux None tenv proc_desc)
with exn ->
reraise_if exn ~f:(fun () -> not (Exceptions.handle_exception exn)) ;
Reporting.log_error_deprecated proc_name exn ) ;
reraise_if exn ~f:(fun () -> not (Exceptions.handle_exception exn)) ;
Reporting.log_error_deprecated proc_name exn ) ;
Specs.get_summary_unsafe __FILE__ proc_name
(** Create closures to perform the analysis of an exe_env *)
let do_analysis_closures exe_env : Tasks.closure list =
let get_calls caller_pdesc =
@ -1350,13 +1422,13 @@ let do_analysis_closures exe_env : Tasks.closure list =
let callbacks =
let get_proc_desc proc_name =
match Exe_env.get_proc_desc exe_env proc_name with
| Some pdesc
-> Some pdesc
| None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy)
-> Option.bind (Specs.get_summary proc_name) ~f:(fun summary ->
| Some pdesc ->
Some pdesc
| None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) ->
Option.bind (Specs.get_summary proc_name) ~f:(fun summary ->
summary.Specs.proc_desc_option )
| None
-> None
| None ->
None
in
let analyze_ondemand _ proc_desc =
let proc_name = Procdesc.get_proc_name proc_desc in
@ -1364,7 +1436,7 @@ let do_analysis_closures exe_env : Tasks.closure list =
let cg = Exe_env.get_cg exe_env in
analyze_procedure_aux (Some cg) tenv proc_desc
in
{Ondemand.analyze_ondemand= analyze_ondemand; get_proc_desc}
{Ondemand.analyze_ondemand; get_proc_desc}
in
let prepare_proc pn =
let should_init = Config.models_mode || is_none (Specs.get_summary pn) in
@ -1378,6 +1450,7 @@ let do_analysis_closures exe_env : Tasks.closure list =
in
closures
let visited_and_total_nodes ~filter cfg =
let filter_node pdesc n =
Procdesc.is_defined pdesc && filter pdesc
@ -1386,10 +1459,10 @@ let visited_and_total_nodes ~filter cfg =
| Procdesc.Node.Stmt_node _
| Procdesc.Node.Prune_node _
| Procdesc.Node.Start_node _
| Procdesc.Node.Exit_node _
-> true
| Procdesc.Node.Skip_node _ | Procdesc.Node.Join_node
-> false
| Procdesc.Node.Exit_node _ ->
true
| Procdesc.Node.Skip_node _ | Procdesc.Node.Join_node ->
false
in
let counted_nodes, visited_nodes_re =
let set = ref Procdesc.NodeSet.empty in
@ -1404,6 +1477,7 @@ let visited_and_total_nodes ~filter cfg =
in
(Procdesc.NodeSet.elements visited_nodes_re, Procdesc.NodeSet.elements counted_nodes)
(** Print the stats for the given cfg.
Consider every defined proc unless a proc with the same name
was defined in another module, and was the one which was analyzed *)
@ -1411,10 +1485,10 @@ let print_stats_cfg proc_shadowed source cfg =
let err_table = Errlog.create_err_table () in
let filter pdesc =
match Specs.get_summary (Procdesc.get_proc_name pdesc) with
| None
-> false
| Some summary
-> Specs.get_specs_from_payload summary <> []
| None ->
false
| Some summary ->
Specs.get_specs_from_payload summary <> []
in
let nodes_visited, nodes_total = visited_and_total_nodes ~filter cfg in
let num_proc = ref 0 in
@ -1428,14 +1502,14 @@ let print_stats_cfg proc_shadowed source cfg =
let compute_stats_proc proc_desc =
let proc_name = Procdesc.get_proc_name proc_desc in
match Specs.get_summary proc_name with
| None
-> ()
| Some _ when proc_shadowed proc_desc
-> L.(debug Analysis Medium)
| None ->
()
| Some _ when proc_shadowed proc_desc ->
L.(debug Analysis Medium)
"print_stats: ignoring function %a which is also defined in another file@."
Typ.Procname.pp proc_name
| Some summary
-> let stats = summary.Specs.stats in
| Some summary ->
let stats = summary.Specs.stats in
let err_log = summary.Specs.attributes.ProcAttributes.err_log in
incr num_proc ;
let specs = Specs.get_specs_from_payload summary in
@ -1448,14 +1522,14 @@ let print_stats_cfg proc_shadowed source cfg =
Exceptions.equal_err_kind ekind Exceptions.Kerror && in_footprint)
err_log )
with
| [], 0
-> incr num_nospec_noerror_proc
| _, 0
-> incr num_spec_noerror_proc
| [], _
-> incr num_nospec_error_proc
| _, _
-> incr num_spec_error_proc
| [], 0 ->
incr num_nospec_noerror_proc
| _, 0 ->
incr num_spec_noerror_proc
| [], _ ->
incr num_nospec_error_proc
| _, _ ->
incr num_spec_error_proc
in
tot_symops := !tot_symops + stats.Specs.symops ;
if Option.is_some stats.Specs.stats_failure then incr num_timeout ;
@ -1498,6 +1572,7 @@ let print_stats_cfg proc_shadowed source cfg =
L.(debug Analysis Medium) "%a" print_file_stats () ;
save_file_stats ()
(** Print the stats for all the files in the cluster *)
let print_stats cluster =
let exe_env = Exe_env.from_cluster cluster in
@ -1510,3 +1585,4 @@ let print_stats cluster =
in
print_stats_cfg proc_shadowed source cfg)
exe_env

679
infer/src/backend/match.ml
View File

File diff suppressed because it is too large Load Diff

32
infer/src/backend/mergeCapture.ml
Unescape View File

@ -24,10 +24,12 @@ let modified_targets = ref String.Set.empty
let record_modified_targets_from_file file =
match Utils.read_file file with
| Ok targets
-> modified_targets := List.fold ~f:String.Set.add ~init:String.Set.empty targets
| Error error
-> L.user_error "Failed to read modified targets file '%s': %s@." file error ; ()
| Ok targets ->
modified_targets := List.fold ~f:String.Set.add ~init:String.Set.empty targets
| Error error ->
L.user_error "Failed to read modified targets file '%s': %s@." file error ;
()
type stats = {mutable files_linked: int; mutable targets_merged: int}
@ -39,6 +41,7 @@ let link_exists s =
true
with Unix.Unix_error _ -> false
let create_link ~stats src dst =
if link_exists dst then Unix.unlink dst ;
Unix.symlink ~src ~dst ;
@ -50,6 +53,7 @@ let create_link ~stats src dst =
Unix.utimes src ~access:near_past ~modif:near_past ;
stats.files_linked <- stats.files_linked + 1
(** Create symbolic links recursively from the destination to the source.
Replicate the structure of the source directory in the destination,
with files replaced by links to the source. *)
@ -66,6 +70,7 @@ let rec slink ~stats ~skiplevels src dst =
else if skiplevels > 0 then ()
else create_link ~stats src dst
(** Determine if the destination should link to the source.
To check if it was linked before, check if all the captured source files
from the source are also in the destination.
@ -113,6 +118,7 @@ let should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst =
if r then L.(debug MergeCapture Medium) "%s@." target_results_dir ;
r
(** should_link needs to know whether the source file has changed,
and to determine whether the destination has never been copied.
In both cases, perform the link. *)
@ -121,8 +127,8 @@ let process_merge_file deps_file =
let stats = empty_stats () in
let process_line line =
match Str.split_delim (Str.regexp (Str.quote "\t")) line with
| target :: _ :: target_results_dir :: _
-> let infer_out_src =
| target :: _ :: target_results_dir :: _ ->
let infer_out_src =
if Filename.is_relative target_results_dir then Filename.dirname (buck_out ())
^/ target_results_dir
else target_results_dir
@ -131,17 +137,18 @@ let process_merge_file deps_file =
(* Don't link toplevel files, definitely not .start *)
if should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst then
slink ~stats ~skiplevels infer_out_src infer_out_dst
| _
-> ()
| _ ->
()
in
( match Utils.read_file deps_file with
| Ok lines
-> List.iter ~f:process_line lines
| Error error
-> L.internal_error "Couldn't read deps file '%s': %s" deps_file error ) ;
| Ok lines ->
List.iter ~f:process_line lines
| Error error ->
L.internal_error "Couldn't read deps file '%s': %s" deps_file error ) ;
L.progress "Targets merged: %d@\n" stats.targets_merged ;
L.progress "Files linked: %d@\n" stats.files_linked
let merge_captured_targets () =
let time0 = Mtime_clock.counter () in
L.progress "Merging captured Buck targets...@\n%!" ;
@ -149,3 +156,4 @@ let merge_captured_targets () =
MergeResults.merge_buck_flavors_results infer_deps_file ;
process_merge_file infer_deps_file ;
L.progress "Merging captured Buck targets took %a@\n%!" Mtime.Span.pp (Mtime_clock.count time0)

78
infer/src/backend/ondemand.ml
Unescape View File

@ -39,35 +39,39 @@ let is_active, add_active, remove_active =
in
(is_active, add_active, remove_active)
let should_create_summary proc_name proc_attributes =
match proc_name with
| Typ.Procname.Java _
-> true
| _
-> proc_attributes.ProcAttributes.is_defined
| Typ.Procname.Java _ ->
true
| _ ->
proc_attributes.ProcAttributes.is_defined
let should_be_analyzed proc_name proc_attributes =
let already_analyzed () =
match Specs.get_summary proc_name with
| Some summary
-> Specs.equal_status (Specs.get_status summary) Specs.Analyzed
| None
-> false
| Some summary ->
Specs.equal_status (Specs.get_status summary) Specs.Analyzed
| None ->
false
in
should_create_summary proc_name proc_attributes && not (is_active proc_name)
&& (* avoid infinite loops *)
not (already_analyzed ())
let procedure_should_be_analyzed proc_name =
match Specs.proc_resolve_attributes proc_name with
| Some proc_attributes when Config.reactive_capture && not proc_attributes.is_defined
-> (* try to capture procedure first *)
| Some proc_attributes when Config.reactive_capture && not proc_attributes.is_defined ->
(* try to capture procedure first *)
let defined_proc_attributes = OndemandCapture.try_capture proc_attributes in
Option.value_map ~f:(should_be_analyzed proc_name) ~default:false defined_proc_attributes
| Some proc_attributes
-> should_be_analyzed proc_name proc_attributes
| None
-> false
| Some proc_attributes ->
should_be_analyzed proc_name proc_attributes
| None ->
false
type global_state =
{ abs_val: int
@ -89,6 +93,7 @@ let save_global_state () =
; name_generator= Ident.NameGenerator.get_current ()
; symexec_state= State.save_state () }
let restore_global_state st =
Config.abs_val := st.abs_val ;
Abs.set_current_rules st.abstraction_rules ;
@ -99,6 +104,7 @@ let restore_global_state st =
State.restore_state st.symexec_state ;
Timeout.resume_previous_timeout ()
let run_proc_analysis analyze_proc curr_pdesc callee_pdesc =
let curr_pname = Procdesc.get_proc_name curr_pdesc in
let callee_pname = Procdesc.get_proc_name callee_pdesc in
@ -130,7 +136,7 @@ let run_proc_analysis analyze_proc curr_pdesc callee_pdesc =
Reporting.log_error summary exn ;
let stats = {summary.Specs.stats with Specs.stats_failure= Some kind} in
let payload = {summary.Specs.payload with Specs.preposts= Some []} in
let new_summary = {summary with Specs.stats= stats; payload} in
let new_summary = {summary with Specs.stats; payload} in
Specs.store_summary new_summary ;
remove_active callee_pname ;
log_elapsed_time () ;
@ -151,44 +157,50 @@ let run_proc_analysis analyze_proc curr_pdesc callee_pdesc =
L.internal_error "@\nERROR RUNNING BACKEND: %a %s@\n@\nBACK TRACE@\n%s@?" Typ.Procname.pp
callee_pname (Exn.to_string exn) (Printexc.get_backtrace ()) ;
match exn with
| SymOp.Analysis_failure_exe kind
-> (* in production mode, log the timeout/crash and continue with the summary we had before
| SymOp.Analysis_failure_exe kind ->
(* in production mode, log the timeout/crash and continue with the summary we had before
the failure occurred *)
log_error_and_continue exn initial_summary kind
| _
-> (* this happens with assert false or some other unrecognized exception *)
| _ ->
(* this happens with assert false or some other unrecognized exception *)
log_error_and_continue exn initial_summary (FKcrash (Exn.to_string exn))
let analyze_proc_desc curr_pdesc callee_pdesc : Specs.summary option =
let callee_pname = Procdesc.get_proc_name callee_pdesc in
let proc_attributes = Procdesc.get_attributes callee_pdesc in
match !callbacks_ref with
| None
-> L.(die InternalError)
| None ->
L.(die InternalError)
"No callbacks registered to analyze proc desc %a when analyzing %a" Typ.Procname.pp
callee_pname Typ.Procname.pp (Procdesc.get_proc_name curr_pdesc)
| Some callbacks
-> if should_be_analyzed callee_pname proc_attributes then
callee_pname Typ.Procname.pp
(Procdesc.get_proc_name curr_pdesc)
| Some callbacks ->
if should_be_analyzed callee_pname proc_attributes then
Some (run_proc_analysis callbacks.analyze_ondemand curr_pdesc callee_pdesc)
else Specs.get_summary callee_pname
(** analyze_proc_name curr_pdesc proc_name performs an on-demand analysis of proc_name triggered
during the analysis of curr_pname *)
let analyze_proc_name curr_pdesc callee_pname : Specs.summary option =
match !callbacks_ref with
| None
-> L.(die InternalError)
| None ->
L.(die InternalError)
"No callbacks registered to analyze proc name %a when analyzing %a@." Typ.Procname.pp
callee_pname Typ.Procname.pp (Procdesc.get_proc_name curr_pdesc)
| Some callbacks
-> if procedure_should_be_analyzed callee_pname then
callee_pname Typ.Procname.pp
(Procdesc.get_proc_name curr_pdesc)
| Some callbacks ->
if procedure_should_be_analyzed callee_pname then
match callbacks.get_proc_desc callee_pname with
| Some callee_pdesc
-> analyze_proc_desc curr_pdesc callee_pdesc
| None
-> Specs.get_summary callee_pname
| Some callee_pdesc ->
analyze_proc_desc curr_pdesc callee_pdesc
| None ->
Specs.get_summary callee_pname
else Specs.get_summary callee_pname
(** Find a proc desc for the procedure, perhaps loading it from disk. *)
let get_proc_desc callee_pname =
match !callbacks_ref with Some callbacks -> callbacks.get_proc_desc callee_pname | None -> None

284
infer/src/backend/paths.ml
Unescape View File

@ -118,44 +118,51 @@ end = struct
let get_description path =
match path with Pnode (_, _, _, _, _, descr_opt) -> descr_opt | _ -> None
let add_description path description =
let add_descr descr_option description =
match descr_option with Some descr -> descr ^ " " ^ description | None -> description
in
match path with
| Pnode (node, exn_opt, session, path, stats, descr_opt)
-> let description = add_descr descr_opt description in
| Pnode (node, exn_opt, session, path, stats, descr_opt) ->
let description = add_descr descr_opt description in
Pnode (node, exn_opt, session, path, stats, Some description)
| _
-> path
| _ ->
path
let set_dummy_stats stats =
stats.max_length <- -1 ;
stats.linear_num <- -1.0
let rec curr_node = function
| Pstart (node, _)
-> Some node
| Pnode (node, _, _, _, _, _)
-> Some node
| Pcall (path, _, _, _)
-> curr_node path
| Pjoin _
-> None
| Pstart (node, _) ->
Some node
| Pnode (node, _, _, _, _, _) ->
Some node
| Pcall (path, _, _, _) ->
curr_node path
| Pjoin _ ->
None
let start node = Pstart (node, get_dummy_stats ())
let extend (node: Procdesc.Node.t) exn_opt session path =
Pnode (node, exn_opt, session, path, get_dummy_stats (), None)
let join p1 p2 = Pjoin (p1, p2, get_dummy_stats ())
let add_call include_subtrace p pname p_sub =
if include_subtrace then Pcall (p, pname, ExecCompleted p_sub, get_dummy_stats ()) else p
let add_skipped_call p pname reason loc_opt =
Pcall (p, pname, ExecSkipped (reason, loc_opt), get_dummy_stats ())
(** functions in this module either do not assume, or do not re-establish, the invariant on dummy
stats *)
module Invariant = struct
@ -164,30 +171,32 @@ end = struct
(** return the stats of the path, assumes that the stats are computed *)
let get_stats = function
| Pstart (_, stats)
-> stats
| Pnode (_, _, _, _, stats, _)
-> stats
| Pjoin (_, _, stats)
-> stats
| Pcall (_, _, _, stats)
-> stats
| Pstart (_, stats) ->
stats
| Pnode (_, _, _, _, stats, _) ->
stats
| Pjoin (_, _, stats) ->
stats
| Pcall (_, _, _, stats) ->
stats
(** restore the invariant that all the stats are dummy, so the path is ready for another
traversal assumes that the stats are computed beforehand, and ensures that the invariant
holds afterwards *)
let rec reset_stats = function
| Pstart (_, stats)
-> if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (_, _, _, path, stats, _) | Pcall (path, _, ExecSkipped _, stats)
-> if not (stats_is_dummy stats) then ( reset_stats path ; set_dummy_stats stats )
| Pjoin (path1, path2, stats)
-> if not (stats_is_dummy stats) then (
| Pstart (_, stats) ->
if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (_, _, _, path, stats, _) | Pcall (path, _, ExecSkipped _, stats) ->
if not (stats_is_dummy stats) then ( reset_stats path ; set_dummy_stats stats )
| Pjoin (path1, path2, stats) ->
if not (stats_is_dummy stats) then (
reset_stats path1 ; reset_stats path2 ; set_dummy_stats stats )
| Pcall (path1, _, ExecCompleted path2, stats)
-> if not (stats_is_dummy stats) then (
| Pcall (path1, _, ExecCompleted path2, stats) ->
if not (stats_is_dummy stats) then (
reset_stats path1 ; reset_stats path2 ; set_dummy_stats stats )
(** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are
dummy. Function [f] (typically with side-effects) is applied once to every node, and
max_length in the stats is the length of a longest sequence of nodes in the path where [f]
@ -198,13 +207,13 @@ end = struct
let rec compute_stats do_calls (f: Procdesc.Node.t -> bool) =
let nodes_found stats = stats.max_length > 0 in
function
| Pstart (node, stats)
-> if stats_is_dummy stats then
| Pstart (node, stats) ->
if stats_is_dummy stats then
let found = f node in
stats.max_length <- (if found then 1 else 0) ;
stats.linear_num <- 1.0
| Pnode (node, _, _, path, stats, _)
-> if stats_is_dummy stats then (
| Pnode (node, _, _, path, stats, _) ->
if stats_is_dummy stats then (
compute_stats do_calls f path ;
let stats1 = get_stats path in
let found =
@ -213,21 +222,21 @@ end = struct
in
stats.max_length <- (if found then 1 + stats1.max_length else 0) ;
stats.linear_num <- stats1.linear_num )
| Pjoin (path1, path2, stats)
-> if stats_is_dummy stats then (
| Pjoin (path1, path2, stats) ->
if stats_is_dummy stats then (
compute_stats do_calls f path1 ;
compute_stats do_calls f path2 ;
let stats1, stats2 = (get_stats path1, get_stats path2) in
stats.max_length <- max stats1.max_length stats2.max_length ;
stats.linear_num <- stats1.linear_num +. stats2.linear_num )
| Pcall (path1, _, ExecCompleted path2, stats)
-> if stats_is_dummy stats then
| Pcall (path1, _, ExecCompleted path2, stats) ->
if stats_is_dummy stats then
let stats2 =
match do_calls with
| true
-> compute_stats do_calls f path2 ; get_stats path2
| false
-> {max_length= 0; linear_num= 0.0}
| true ->
compute_stats do_calls f path2 ; get_stats path2
| false ->
{max_length= 0; linear_num= 0.0}
in
let stats1 =
let f' =
@ -239,11 +248,12 @@ end = struct
in
stats.max_length <- stats1.max_length + stats2.max_length ;
stats.linear_num <- stats1.linear_num
| Pcall (path, _, ExecSkipped _, stats)
-> if stats_is_dummy stats then
| Pcall (path, _, ExecSkipped _, stats) ->
if stats_is_dummy stats then
let stats1 = compute_stats do_calls f path ; get_stats path in
stats.max_length <- stats1.max_length ;
stats.linear_num <- stats1.linear_num
end
(* End of module Invariant *)
@ -252,18 +262,23 @@ end = struct
Invariant.compute_stats false (fun node -> f node ; true) path ;
Invariant.reset_stats path
let get_path_pos node =
let pn = Procdesc.Node.get_proc_name node in
let n_id = Procdesc.Node.get_id node in
(pn, (n_id :> int))
let contains_position path pos =
let found = ref false in
let f node =
if PredSymb.equal_path_pos (get_path_pos node) pos then found := true ;
true
in
Invariant.compute_stats true f path ; Invariant.reset_stats path ; !found
Invariant.compute_stats true f path ;
Invariant.reset_stats path ;
!found
(** iterate over the longest sequence belonging to the path,
restricting to those where [filter] holds of some element.
@ -273,27 +288,30 @@ end = struct
(filter: Procdesc.Node.t -> bool) (path: t) : unit =
let rec doit level session path prev_exn_opt =
match path with
| Pstart _
-> f level path session prev_exn_opt
| Pnode (_, exn_opt, session', p, _, _)
-> (* no two consecutive exceptions *)
| Pstart _ ->
f level path session prev_exn_opt
| Pnode (_, exn_opt, session', p, _, _) ->
(* no two consecutive exceptions *)
let next_exn_opt = if prev_exn_opt <> None then None else exn_opt in
doit level (session' :> int) p next_exn_opt ;
f level path session prev_exn_opt
| Pjoin (p1, p2, _)
-> if (Invariant.get_stats p1).max_length <= (Invariant.get_stats p2).max_length then
| Pjoin (p1, p2, _) ->
if (Invariant.get_stats p1).max_length <= (Invariant.get_stats p2).max_length then
doit level session p1 prev_exn_opt
else doit level session p2 prev_exn_opt
| Pcall (p1, _, ExecCompleted p2, _)
-> let next_exn_opt = None in
| Pcall (p1, _, ExecCompleted p2, _) ->
let next_exn_opt = None in
(* exn must already be inside the call *)
doit level session p1 next_exn_opt ;
doit (level + 1) session p2 next_exn_opt
| Pcall (p, _, ExecSkipped _, _)
-> let next_exn_opt = None in
| Pcall (p, _, ExecSkipped _, _) ->
let next_exn_opt = None in
doit level session p next_exn_opt ; f level path session prev_exn_opt
in
Invariant.compute_stats true filter path ; doit 0 0 path None ; Invariant.reset_stats path
Invariant.compute_stats true filter path ;
doit 0 0 path None ;
Invariant.reset_stats path
(** iterate over the shortest sequence belonging to the path,
restricting to those containing the given position if given.
@ -304,10 +322,10 @@ end = struct
(pos_opt: PredSymb.path_pos option) (path: t) : unit =
let filter node =
match pos_opt with
| None
-> true
| Some pos
-> PredSymb.equal_path_pos (get_path_pos node) pos
| None ->
true
| Some pos ->
PredSymb.equal_path_pos (get_path_pos node) pos
in
let path_pos_at_path p =
try match curr_node p with Some node -> pos_opt <> None && filter node | None -> false
@ -320,15 +338,16 @@ end = struct
if path_pos_at_path p then position_seen := true ;
log := (level, p, session, exn_opt) :: !log
in
iter_shortest_sequence_filter g filter path ; !log
iter_shortest_sequence_filter g filter path ;
!log
in
let sequence_up_to_last_seen =
if !position_seen then
let rec remove_until_seen = function
| (_, p, _, _ as x) :: l
-> if path_pos_at_path p then List.rev (x :: l) else remove_until_seen l
| []
-> []
| ((_, p, _, _) as x) :: l ->
if path_pos_at_path p then List.rev (x :: l) else remove_until_seen l
| [] ->
[]
in
remove_until_seen inverse_sequence
else List.rev inverse_sequence
@ -337,6 +356,7 @@ end = struct
~f:(fun (level, p, session, exn_opt) -> f level p session exn_opt)
sequence_up_to_last_seen
(** return the node visited most, and number of visits, in the shortest linear sequence *)
let repetitions path =
let map = ref Procdesc.NodeMap.empty in
@ -346,8 +366,8 @@ end = struct
let n = Procdesc.NodeMap.find node !map in
map := Procdesc.NodeMap.add node (n + 1) !map
with Not_found -> map := Procdesc.NodeMap.add node 1 !map )
| None
-> ()
| None ->
()
in
iter_shortest_sequence (fun _ p _ _ -> add_node (curr_node p)) None path ;
let max_rep_node = ref (Procdesc.Node.dummy None) in
@ -360,6 +380,7 @@ end = struct
!map ;
(!max_rep_node, !max_rep_num)
let stats_string path =
Invariant.compute_stats true (fun _ -> true) path ;
let node, repetitions = repetitions path in
@ -370,6 +391,7 @@ end = struct
in
Invariant.reset_stats path ; str
let pp_stats fmt path = F.fprintf fmt "%s" (stats_string path)
let d_stats path = L.d_str (stats_string path)
@ -397,12 +419,12 @@ end = struct
if not (path_seen path) (* avoid exponential blowup *) then
match path with
(* build a map from delayed paths to a unique number *)
| Pstart _
-> ()
| Pnode (_, _, _, p, _, _) | Pcall (p, _, ExecSkipped _, _)
-> add_delayed p
| Pjoin (p1, p2, _) | Pcall (p1, _, ExecCompleted p2, _)
-> (* delay paths occurring in a join *)
| Pstart _ ->
()
| Pnode (_, _, _, p, _, _) | Pcall (p, _, ExecSkipped _, _) ->
add_delayed p
| Pjoin (p1, p2, _) | Pcall (p1, _, ExecCompleted p2, _) ->
(* delay paths occurring in a join *)
add_delayed p1 ; add_delayed p2 ; add_path p1 ; add_path p2
in
let rec doit n fmt path =
@ -412,16 +434,16 @@ end = struct
F.fprintf fmt "P%d" num
with Not_found ->
match path with
| Pstart (node, _)
-> F.fprintf fmt "n%a" Procdesc.Node.pp node
| Pnode (node, _, session, path, _, _)
-> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path (session :> int) Procdesc.Node.pp node
| Pjoin (path1, path2, _)
-> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path1, _, ExecCompleted path2, _)
-> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path, _, ExecSkipped (reason, _), _)
-> F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason
| Pstart (node, _) ->
F.fprintf fmt "n%a" Procdesc.Node.pp node
| Pnode (node, _, session, path, _, _) ->
F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path (session :> int) Procdesc.Node.pp node
| Pjoin (path1, path2, _) ->
F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path1, _, ExecCompleted path2, _) ->
F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path, _, ExecSkipped (reason, _), _) ->
F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason
in
let print_delayed () =
if not (PathMap.is_empty !delayed) then
@ -431,21 +453,23 @@ end = struct
in
add_delayed path ; doit 0 fmt path ; print_delayed ()
let d p = L.add_print_action (L.PTpath, Obj.repr p)
let rec contains p1 p2 =
match p2 with
| Pjoin (p2', p2'', _)
-> contains p1 p2' || contains p1 p2''
| _
-> phys_equal p1 p2
| Pjoin (p2', p2'', _) ->
contains p1 p2' || contains p1 p2''
| _ ->
phys_equal p1 p2
let create_loc_trace path pos_opt : Errlog.loc_trace =
let trace = ref [] in
let g level path _ exn_opt =
match (path, curr_node path) with
| Pcall (_, pname, ExecSkipped (reason, loc_opt), _), Some curr_node
-> let curr_loc = Procdesc.Node.get_loc curr_node in
| Pcall (_, pname, ExecSkipped (reason, loc_opt), _), Some curr_node ->
let curr_loc = Procdesc.Node.get_loc curr_node in
let descr =
Format.sprintf "Skipping %s: %s" (Typ.Procname.to_simplified_string pname) reason
in
@ -460,48 +484,48 @@ end = struct
trace := Errlog.make_trace_element (level + 1) loc definition_descr [] :: !trace)
loc_opt
| _, Some curr_node
-> (
-> (
let curr_loc = Procdesc.Node.get_loc curr_node in
match Procdesc.Node.get_kind curr_node with
| Procdesc.Node.Join_node
-> () (* omit join nodes from error traces *)
| Procdesc.Node.Start_node pname
-> let descr = "start of procedure " ^ Typ.Procname.to_simplified_string pname in
| Procdesc.Node.Join_node ->
() (* omit join nodes from error traces *)
| Procdesc.Node.Start_node pname ->
let descr = "start of procedure " ^ Typ.Procname.to_simplified_string pname in
let node_tags = [Errlog.Procedure_start pname] in
trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace
| Procdesc.Node.Prune_node (is_true_branch, if_kind, _)
-> let descr =
| Procdesc.Node.Prune_node (is_true_branch, if_kind, _) ->
let descr =
match (is_true_branch, if_kind) with
| true, Sil.Ik_if
-> "Taking true branch"
| false, Sil.Ik_if
-> "Taking false branch"
| true, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile)
-> "Loop condition is true. Entering loop body"
| false, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile)
-> "Loop condition is false. Leaving loop"
| true, Sil.Ik_switch
-> "Switch condition is true. Entering switch case"
| false, Sil.Ik_switch
-> "Switch condition is false. Skipping switch case"
| true, (Sil.Ik_bexp | Sil.Ik_land_lor)
-> "Condition is true"
| false, (Sil.Ik_bexp | Sil.Ik_land_lor)
-> "Condition is false"
| true, Sil.Ik_if ->
"Taking true branch"
| false, Sil.Ik_if ->
"Taking false branch"
| true, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) ->
"Loop condition is true. Entering loop body"
| false, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) ->
"Loop condition is false. Leaving loop"
| true, Sil.Ik_switch ->
"Switch condition is true. Entering switch case"
| false, Sil.Ik_switch ->
"Switch condition is false. Skipping switch case"
| true, (Sil.Ik_bexp | Sil.Ik_land_lor) ->
"Condition is true"
| false, (Sil.Ik_bexp | Sil.Ik_land_lor) ->
"Condition is false"
in
let node_tags = [Errlog.Condition is_true_branch] in
trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace
| Procdesc.Node.Exit_node pname
-> let descr = "return from a call to " ^ Typ.Procname.to_string pname in
| Procdesc.Node.Exit_node pname ->
let descr = "return from a call to " ^ Typ.Procname.to_string pname in
let node_tags = [Errlog.Procedure_end pname] in
trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace
| _
-> let descr, node_tags =
| _ ->
let descr, node_tags =
match exn_opt with
| None
-> ("", [])
| Some exn_name
-> let exn_str = Typ.Name.name exn_name in
| None ->
("", [])
| Some exn_name ->
let exn_str = Typ.Name.name exn_name in
let desc =
if String.is_empty exn_str then "exception" else "exception " ^ exn_str
in
@ -509,14 +533,14 @@ end = struct
in
let descr =
match get_description path with
| Some path_descr
-> if String.length descr > 0 then descr ^ " " ^ path_descr else path_descr
| None
-> descr
| Some path_descr ->
if String.length descr > 0 then descr ^ " " ^ path_descr else path_descr
| None ->
descr
in
trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace )
| _, None
-> ()
| _, None ->
()
in
iter_shortest_sequence g pos_opt path ;
let compare lt1 lt2 =
@ -525,6 +549,7 @@ end = struct
in
let relevant lt = lt.Errlog.lt_node_tags <> [] in
IList.remove_irrelevant_duplicates compare relevant (List.rev !trace)
end
(* =============== END of the Path module ===============*)
@ -612,6 +637,7 @@ end = struct
let f prop path = plist := (prop, path) :: !plist in
PropMap.iter f ps ; !plist
let to_proplist ps = List.map ~f:fst (elements ps)
let to_propset tenv ps = Propset.from_proplist tenv (to_proplist ps)
@ -624,6 +650,7 @@ end = struct
List.iter ~f:(fun p -> filtered_map := PropMap.remove p !filtered_map) !elements ;
!filtered_map
let partition f ps =
let elements = ref [] in
PropMap.iter (fun p _ -> elements := p :: !elements) ps ;
@ -633,6 +660,7 @@ end = struct
!elements ;
(!el1, !el2)
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
let add_renamed_prop (p: Prop.normal Prop.t) (path: Path.t) (ps: t) : t =
let path_new =
@ -643,6 +671,7 @@ end = struct
in
PropMap.add p path_new ps
let union (ps1: t) (ps2: t) : t = PropMap.fold add_renamed_prop ps1 ps2
(** check if the nodes in path p1 are a subset of those in p2 (not trace subset) *)
@ -654,6 +683,7 @@ end = struct
in
Procdesc.NodeSet.subset (get_nodes p1) (get_nodes p2)
(** difference between pathsets for the differential fixpoint *)
let diff (ps1: t) (ps2: t) : t =
let res = ref ps1 in
@ -666,6 +696,7 @@ end = struct
in
PropMap.iter rem ps2 ; !res
let is_empty = PropMap.is_empty
let iter = PropMap.iter
@ -679,6 +710,7 @@ end = struct
in
iter do_elem ps ; !res
let map f ps = map_option (fun p -> Some (f p)) ps
let size ps =
@ -687,6 +719,7 @@ end = struct
let () = PropMap.iter add ps in
!res
let pp pe fmt ps =
let count = ref 0 in
let pp_path fmt path = F.fprintf fmt "[path: %a@\n%a]" Path.pp_stats path Path.pp path in
@ -696,6 +729,7 @@ end = struct
in
iter f ps
let d (ps: t) = L.add_print_action (L.PTpathset, Obj.repr ps)
let filter_path path ps =
@ -703,9 +737,11 @@ end = struct
let f prop path' = if Path.contains path path' then plist := prop :: !plist in
iter f ps ; !plist
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
let from_renamed_list (pl: ('a Prop.t * Path.t) list) : t =
List.fold ~f:(fun ps (p, pa) -> add_renamed_prop p pa ps) ~init:empty pl
end
(* =============== END of the PathSet module ===============*)

122
infer/src/backend/preanal.ml
Unescape View File

@ -22,10 +22,10 @@ let add_dispatch_calls pdesc cg tenv =
|| call_flags.CallFlags.cf_interface
in
let instr_is_dispatch_call = function
| Sil.Call (_, _, _, _, call_flags)
-> call_flags_is_dispatch call_flags
| _
-> false
| Sil.Call (_, _, _, _, call_flags) ->
call_flags_is_dispatch call_flags
| _ ->
false
in
let has_dispatch_call instrs = List.exists ~f:instr_is_dispatch_call instrs in
let replace_dispatch_calls = function
@ -36,7 +36,7 @@ let add_dispatch_calls pdesc cg tenv =
, loc
, call_flags ) as instr
when call_flags_is_dispatch call_flags
-> (
-> (
(* the frontend should not populate the list of targets *)
assert (List.is_empty call_flags.CallFlags.cf_targets) ;
let receiver_typ_no_ptr =
@ -47,8 +47,8 @@ let add_dispatch_calls pdesc cg tenv =
List.sort ~cmp:(fun (_, p1) (_, p2) -> Typ.Procname.compare p1 p2) overrides
in
match sorted_overrides with
| (_, target_pname) :: _ as all_targets
-> let targets_to_add =
| (_, target_pname) :: _ as all_targets ->
let targets_to_add =
if sound_dynamic_dispatch then List.map ~f:snd all_targets
else
(* if sound dispatch is turned off, consider only the first target. we do this
@ -60,10 +60,10 @@ let add_dispatch_calls pdesc cg tenv =
targets_to_add ;
let call_flags' = {call_flags with CallFlags.cf_targets= targets_to_add} in
Sil.Call (ret_id, call_exp, args, loc, call_flags')
| []
-> instr )
| instr
-> instr
| [] ->
instr )
| instr ->
instr
in
let instrs = Procdesc.Node.get_instrs node in
if has_dispatch_call instrs then List.map ~f:replace_dispatch_calls instrs
@ -72,6 +72,7 @@ let add_dispatch_calls pdesc cg tenv =
let pname = Procdesc.get_proc_name pdesc in
Procdesc.iter_nodes (node_add_dispatch_calls pname) pdesc
(** add instructions to perform abstraction *)
let add_abstraction_instructions pdesc =
let open Procdesc in
@ -85,10 +86,10 @@ let add_abstraction_instructions pdesc =
in
let node_requires_abstraction node =
match Node.get_kind node with
| Node.Start_node _ | Node.Join_node
-> false
| Node.Exit_node _ | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _
-> converging_node node
| Node.Start_node _ | Node.Join_node ->
false
| Node.Exit_node _ | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _ ->
converging_node node
in
let do_node node =
let loc = Node.get_last_loc node in
@ -96,6 +97,7 @@ let add_abstraction_instructions pdesc =
in
Procdesc.iter_nodes do_node pdesc
module BackwardCfg = ProcCfg.Backward (ProcCfg.Exceptional)
module LivenessAnalysis = AbstractInterpreter.Make (BackwardCfg) (Liveness.TransferFunctions)
module VarDomain = Liveness.Domain
@ -115,16 +117,17 @@ module NullifyTransferFunctions = struct
type extras = LivenessAnalysis.invariant_map
let postprocess (reaching_defs, _ as astate) node {ProcData.extras} =
let postprocess ((reaching_defs, _) as astate) node {ProcData.extras} =
let node_id = Procdesc.Node.get_id (CFG.underlying_node node) in
match LivenessAnalysis.extract_state node_id extras with
(* note: because the analysis is backward, post and pre are reversed *)
| Some {AbstractInterpreter.post= live_before; pre= live_after}
-> let to_nullify = VarDomain.diff (VarDomain.union live_before reaching_defs) live_after in
| Some {AbstractInterpreter.post= live_before; pre= live_after} ->
let to_nullify = VarDomain.diff (VarDomain.union live_before reaching_defs) live_after in
let reaching_defs' = VarDomain.diff reaching_defs to_nullify in
(reaching_defs', to_nullify)
| None
-> astate
| None ->
astate
let cache_node = ref (Procdesc.Node.dummy None)
@ -142,34 +145,36 @@ module NullifyTransferFunctions = struct
cache_instr := last_instr ;
last_instr
let is_last_instr_in_node instr node = phys_equal (last_instr_in_node node) instr
let exec_instr (active_defs, to_nullify as astate) extras node instr =
let exec_instr ((active_defs, to_nullify) as astate) extras node instr =
let astate' =
match instr with
| Sil.Load (lhs_id, _, _, _)
-> (VarDomain.add (Var.of_id lhs_id) active_defs, to_nullify)
| Sil.Call (lhs_id, _, _, _, _)
-> let active_defs' =
| Sil.Load (lhs_id, _, _, _) ->
(VarDomain.add (Var.of_id lhs_id) active_defs, to_nullify)
| Sil.Call (lhs_id, _, _, _, _) ->
let active_defs' =
Option.value_map
~f:(fun (id, _) -> VarDomain.add (Var.of_id id) active_defs)
~default:active_defs lhs_id
in
(active_defs', to_nullify)
| Sil.Store (Exp.Lvar lhs_pvar, _, _, _)
-> (VarDomain.add (Var.of_pvar lhs_pvar) active_defs, to_nullify)
| Sil.Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _
-> astate
| Sil.Nullify _
-> L.(die InternalError)
| Sil.Store (Exp.Lvar lhs_pvar, _, _, _) ->
(VarDomain.add (Var.of_pvar lhs_pvar) active_defs, to_nullify)
| Sil.Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _ ->
astate
| Sil.Nullify _ ->
L.(die InternalError)
"Should not add nullify instructions before running nullify analysis!"
in
if is_last_instr_in_node instr node then postprocess astate' node extras else astate'
end
module NullifyAnalysis =
AbstractInterpreter.MakeNoCFG (Scheduler.ReversePostorder (ProcCfg.Exceptional))
(NullifyTransferFunctions)
AbstractInterpreter.MakeNoCFG
(Scheduler.ReversePostorder (ProcCfg.Exceptional)) (NullifyTransferFunctions)
let add_nullify_instrs pdesc tenv liveness_inv_map =
let address_taken_vars =
@ -178,10 +183,10 @@ let add_nullify_instrs pdesc tenv liveness_inv_map =
else
let initial = AddressTaken.Domain.empty in
match AddressTaken.Analyzer.compute_post (ProcData.make_default pdesc tenv) ~initial with
| Some post
-> post
| None
-> AddressTaken.Domain.empty
| Some post ->
post
| None ->
AddressTaken.Domain.empty
in
let nullify_proc_cfg = ProcCfg.Exceptional.from_pdesc pdesc in
let nullify_proc_data = ProcData.make pdesc tenv liveness_inv_map in
@ -206,48 +211,55 @@ let add_nullify_instrs pdesc tenv liveness_inv_map =
List.iter
~f:(fun node ->
match NullifyAnalysis.extract_post (ProcCfg.Exceptional.id node) nullify_inv_map with
| Some (_, to_nullify)
-> let pvars_to_nullify, ids_to_remove =
| Some (_, to_nullify) ->
let pvars_to_nullify, ids_to_remove =
VarDomain.fold
(fun var (pvars_acc, ids_acc) ->
match Var.to_exp var with
(* we nullify all address taken variables at the end of the procedure *)
| Exp.Lvar pvar
when not (AddressTaken.Domain.mem pvar address_taken_vars)
-> (pvar :: pvars_acc, ids_acc)
| Exp.Var id
-> (pvars_acc, id :: ids_acc)
| _
-> (pvars_acc, ids_acc))
when not (AddressTaken.Domain.mem pvar address_taken_vars) ->
(pvar :: pvars_acc, ids_acc)
| Exp.Var id ->
(pvars_acc, id :: ids_acc)
| _ ->
(pvars_acc, ids_acc))
to_nullify ([], [])
in
node_add_removetmps_instructions node ids_to_remove ;
node_add_nullify_instructions node pvars_to_nullify
| None
-> ())
| None ->
())
(ProcCfg.Exceptional.nodes nullify_proc_cfg) ;
(* nullify all address taken variables *)
if not (AddressTaken.Domain.is_empty address_taken_vars) then
let exit_node = ProcCfg.Exceptional.exit_node nullify_proc_cfg in
node_add_nullify_instructions exit_node (AddressTaken.Domain.elements address_taken_vars)
let do_liveness pdesc tenv =
let liveness_proc_cfg = BackwardCfg.from_pdesc pdesc in
let initial = Liveness.Domain.empty in
let liveness_inv_map =
LivenessAnalysis.exec_cfg liveness_proc_cfg (ProcData.make_default pdesc tenv) ~initial
~debug:false
LivenessAnalysis.exec_cfg liveness_proc_cfg
(ProcData.make_default pdesc tenv)
~initial ~debug:false
in
add_nullify_instrs pdesc tenv liveness_inv_map ; Procdesc.signal_did_preanalysis pdesc
add_nullify_instrs pdesc tenv liveness_inv_map ;
Procdesc.signal_did_preanalysis pdesc
let do_abstraction pdesc =
add_abstraction_instructions pdesc ; Procdesc.signal_did_preanalysis pdesc
add_abstraction_instructions pdesc ;
Procdesc.signal_did_preanalysis pdesc
let do_dynamic_dispatch pdesc cg tenv =
( match Config.dynamic_dispatch with
| Interface | Sound
-> let pname = Procdesc.get_proc_name pdesc in
| Interface | Sound ->
let pname = Procdesc.get_proc_name pdesc in
if Typ.Procname.is_java pname then add_dispatch_calls pdesc cg tenv
| NoDynamicDispatch | Lazy
-> () ) ;
| NoDynamicDispatch | Lazy ->
() ) ;
Procdesc.signal_did_preanalysis pdesc

250
infer/src/backend/printer.ml
Unescape View File

@ -44,6 +44,7 @@ module LineReader = struct
In_channel.close cin ;
Array.of_list (List.rev !lines)
let file_data (hash: t) fname =
try Some (Hashtbl.find hash fname)
with Not_found ->
@ -52,14 +53,16 @@ module LineReader = struct
Hashtbl.add hash fname lines_arr ; Some lines_arr
with exn when SymOp.exn_not_failure exn -> None
let from_file_linenum_original hash fname linenum =
match file_data hash fname with
| None
-> None
| Some lines_arr
-> if linenum > 0 && linenum <= Array.length lines_arr then Some lines_arr.(linenum - 1)
| None ->
None
| Some lines_arr ->
if linenum > 0 && linenum <= Array.length lines_arr then Some lines_arr.(linenum - 1)
else None
let from_file_linenum hash fname linenum = from_file_linenum_original hash fname linenum
let from_loc hash loc = from_file_linenum hash loc.Location.file loc.Location.line
@ -71,10 +74,10 @@ let curr_html_formatter = ref F.std_formatter
(** Return true if the node was visited during footprint and during re-execution*)
let node_is_visited node =
match Specs.get_summary (Procdesc.Node.get_proc_name node) with
| None
-> (false, false)
| Some summary
-> let stats = summary.Specs.stats in
| None ->
(false, false)
| Some summary ->
let stats = summary.Specs.stats in
let is_visited_fp =
IntSet.mem (Procdesc.Node.get_id node :> int) stats.Specs.nodes_visited_fp
in
@ -83,11 +86,13 @@ let node_is_visited node =
in
(is_visited_fp, is_visited_re)
(** Return true if the node was visited during analysis *)
let is_visited node =
let visited_fp, visited_re = node_is_visited node in
visited_fp || visited_re
(* =============== START of module NodesHtml =============== *)
(** Print information into html files for nodes
@ -102,13 +107,16 @@ end = struct
let log_files = Hashtbl.create 11
let pp_node_link fmt node =
Io_infer.Html.pp_node_link [".."] (Procdesc.Node.get_proc_name node) ~description:""
Io_infer.Html.pp_node_link [".."]
(Procdesc.Node.get_proc_name node)
~description:""
~preds:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_preds node) :> int list)
~succs:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_succs node) :> int list)
~exn:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_exn node) :> int list)
~isvisited:(is_visited node) ~isproof:false fmt
(Procdesc.Node.get_id node :> int)
let start_node nodeid loc proc_name preds succs exns source =
let node_fname = Io_infer.Html.node_filename proc_name nodeid in
let modified = Io_infer.Html.modified_during_analysis source ["nodes"; node_fname] in
@ -138,11 +146,13 @@ end = struct
true )
else false
let finish_node proc_name nodeid source =
let node_fname = Io_infer.Html.node_filename proc_name nodeid in
let fd = Hashtbl.find log_files (node_fname, source) in
Unix.close fd ;
curr_html_formatter := F.std_formatter
end
(* =============== END of module NodesHtml =============== *)
@ -152,148 +162,149 @@ end
let force_delayed_print fmt =
let pe_default = if Config.write_html then Pp.html Black else Pp.text in
function
| L.PTatom, a
-> let a : Sil.atom = Obj.obj a in
| L.PTatom, a ->
let a : Sil.atom = Obj.obj a in
Sil.pp_atom pe_default fmt a
| L.PTattribute, a
-> let a : PredSymb.t = Obj.obj a in
| L.PTattribute, a ->
let a : PredSymb.t = Obj.obj a in
F.pp_print_string fmt (PredSymb.to_string pe_default a)
| L.PTdecrease_indent, n
-> let n : int = Obj.obj n in
| L.PTdecrease_indent, n ->
let n : int = Obj.obj n in
for _ = 1 to n do F.fprintf fmt "@]" done
| L.PTexp, e
-> let e : Exp.t = Obj.obj e in
| L.PTexp, e ->
let e : Exp.t = Obj.obj e in
Sil.pp_exp_printenv pe_default fmt e
| L.PTexp_list, el
-> let el : Exp.t list = Obj.obj el in
| L.PTexp_list, el ->
let el : Exp.t list = Obj.obj el in
Sil.pp_exp_list pe_default fmt el
| L.PThpred, hpred
-> let hpred : Sil.hpred = Obj.obj hpred in
| L.PThpred, hpred ->
let hpred : Sil.hpred = Obj.obj hpred in
Sil.pp_hpred pe_default fmt hpred
| L.PTincrease_indent, n
-> let n : int = Obj.obj n in
| L.PTincrease_indent, n ->
let n : int = Obj.obj n in
let s = ref "" in
for _ = 1 to n do s := " " ^ !s done ;
F.fprintf fmt "%s@[" !s
| L.PTinstr, i
-> let i : Sil.instr = Obj.obj i in
| L.PTinstr, i ->
let i : Sil.instr = Obj.obj i in
if Config.write_html then
F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green
(Sil.pp_instr (Pp.html Green))
i Io_infer.Html.pp_end_color ()
else Sil.pp_instr Pp.text fmt i
| L.PTinstr_list, il
-> let il : Sil.instr list = Obj.obj il in
| L.PTinstr_list, il ->
let il : Sil.instr list = Obj.obj il in
if Config.write_html then
F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green
(Sil.pp_instr_list (Pp.html Green))
il Io_infer.Html.pp_end_color ()
else Sil.pp_instr_list Pp.text fmt il
| L.PTjprop_list, shallow_jpl
-> let (shallow: bool), (jpl: Prop.normal Specs.Jprop.t list) = Obj.obj shallow_jpl in
| L.PTjprop_list, shallow_jpl ->
let (shallow: bool), (jpl: Prop.normal Specs.Jprop.t list) = Obj.obj shallow_jpl in
Specs.Jprop.pp_list pe_default shallow fmt jpl
| L.PTjprop_short, jp
-> let jp : Prop.normal Specs.Jprop.t = Obj.obj jp in
| L.PTjprop_short, jp ->
let jp : Prop.normal Specs.Jprop.t = Obj.obj jp in
Specs.Jprop.pp_short pe_default fmt jp
| L.PTloc, loc
-> let loc : Location.t = Obj.obj loc in
| L.PTloc, loc ->
let loc : Location.t = Obj.obj loc in
Location.pp fmt loc
| L.PTnode_instrs, b_n
-> let (b: bool), (io: Sil.instr option), (n: Procdesc.Node.t) = Obj.obj b_n in
| L.PTnode_instrs, b_n ->
let (b: bool), (io: Sil.instr option), (n: Procdesc.Node.t) = Obj.obj b_n in
if Config.write_html then
F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green
(Procdesc.Node.pp_instrs (Pp.html Green) io ~sub_instrs:b)
n Io_infer.Html.pp_end_color ()
else F.fprintf fmt "%a" (Procdesc.Node.pp_instrs Pp.text io ~sub_instrs:b) n
| L.PToff, off
-> let off : Sil.offset = Obj.obj off in
| L.PToff, off ->
let off : Sil.offset = Obj.obj off in
Sil.pp_offset pe_default fmt off
| L.PToff_list, offl
-> let offl : Sil.offset list = Obj.obj offl in
| L.PToff_list, offl ->
let offl : Sil.offset list = Obj.obj offl in
Sil.pp_offset_list pe_default fmt offl
| L.PTpathset, ps
-> let ps : Paths.PathSet.t = Obj.obj ps in
| L.PTpathset, ps ->
let ps : Paths.PathSet.t = Obj.obj ps in
F.fprintf fmt "%a@\n" (Paths.PathSet.pp pe_default) ps
| L.PTpi, pi
-> let pi : Sil.atom list = Obj.obj pi in
| L.PTpi, pi ->
let pi : Sil.atom list = Obj.obj pi in
Prop.pp_pi pe_default fmt pi
| L.PTpath, path
-> let path : Paths.Path.t = Obj.obj path in
| L.PTpath, path ->
let path : Paths.Path.t = Obj.obj path in
Paths.Path.pp fmt path
| L.PTprop, p
-> let p : Prop.normal Prop.t = Obj.obj p in
| L.PTprop, p ->
let p : Prop.normal Prop.t = Obj.obj p in
Prop.pp_prop pe_default fmt p
| L.PTproplist, x
-> let (p: Prop.normal Prop.t), (pl: Prop.normal Prop.t list) = Obj.obj x in
| L.PTproplist, x ->
let (p: Prop.normal Prop.t), (pl: Prop.normal Prop.t list) = Obj.obj x in
Propgraph.pp_proplist pe_default "PROP" (p, false) fmt pl
| L.PTprop_list_with_typ, plist
-> let pl : Prop.normal Prop.t list = Obj.obj plist in
| L.PTprop_list_with_typ, plist ->
let pl : Prop.normal Prop.t list = Obj.obj plist in
F.fprintf fmt "%a" (Prop.pp_proplist_with_typ pe_default) pl
| L.PTprop_with_typ, p
-> let p : Prop.normal Prop.t = Obj.obj p in
| L.PTprop_with_typ, p ->
let p : Prop.normal Prop.t = Obj.obj p in
Prop.pp_prop_with_typ pe_default fmt p
| L.PTpvar, pvar
-> let pvar : Pvar.t = Obj.obj pvar in
| L.PTpvar, pvar ->
let pvar : Pvar.t = Obj.obj pvar in
Pvar.pp pe_default fmt pvar
| L.PTsexp, se
-> let se : Sil.strexp = Obj.obj se in
| L.PTsexp, se ->
let se : Sil.strexp = Obj.obj se in
Sil.pp_sexp pe_default fmt se
| L.PTsexp_list, sel
-> let sel : Sil.strexp list = Obj.obj sel in
| L.PTsexp_list, sel ->
let sel : Sil.strexp list = Obj.obj sel in
Sil.pp_sexp_list pe_default fmt sel
| L.PTsigma, sigma
-> let sigma : Sil.hpred list = Obj.obj sigma in
| L.PTsigma, sigma ->
let sigma : Sil.hpred list = Obj.obj sigma in
Prop.pp_sigma pe_default fmt sigma
| L.PTspec, spec
-> let spec : Prop.normal Specs.spec = Obj.obj spec in
| L.PTspec, spec ->
let spec : Prop.normal Specs.spec = Obj.obj spec in
Specs.pp_spec (if Config.write_html then Pp.html Blue else Pp.text) None fmt spec
| L.PTstr, s
-> let s : string = Obj.obj s in
| L.PTstr, s ->
let s : string = Obj.obj s in
F.fprintf fmt "%s" s
| L.PTstr_color, s
-> let (s: string), (c: Pp.color) = Obj.obj s in
| L.PTstr_color, s ->
let (s: string), (c: Pp.color) = Obj.obj s in
if Config.write_html then
F.fprintf fmt "%a%s%a" Io_infer.Html.pp_start_color c s Io_infer.Html.pp_end_color ()
else F.fprintf fmt "%s" s
| L.PTstrln, s
-> let s : string = Obj.obj s in
| L.PTstrln, s ->
let s : string = Obj.obj s in
F.fprintf fmt "%s@\n" s
| L.PTstrln_color, s
-> let (s: string), (c: Pp.color) = Obj.obj s in
| L.PTstrln_color, s ->
let (s: string), (c: Pp.color) = Obj.obj s in
if Config.write_html then
F.fprintf fmt "%a%s%a@\n" Io_infer.Html.pp_start_color c s Io_infer.Html.pp_end_color ()
else F.fprintf fmt "%s@\n" s
| L.PTsub, sub
-> let sub : Sil.subst = Obj.obj sub in
| L.PTsub, sub ->
let sub : Sil.subst = Obj.obj sub in
Prop.pp_sub pe_default fmt sub
| L.PTtexp_full, te
-> let te : Exp.t = Obj.obj te in
| L.PTtexp_full, te ->
let te : Exp.t = Obj.obj te in
Sil.pp_texp_full pe_default fmt te
| L.PTtyp_full, t
-> let t : Typ.t = Obj.obj t in
| L.PTtyp_full, t ->
let t : Typ.t = Obj.obj t in
Typ.pp_full pe_default fmt t
| L.PTtyp_list, tl
-> let tl : Typ.t list = Obj.obj tl in
| L.PTtyp_list, tl ->
let tl : Typ.t list = Obj.obj tl in
Pp.seq (Typ.pp pe_default) fmt tl
| L.PTerror, s
-> let s : string = Obj.obj s in
| L.PTerror, s ->
let s : string = Obj.obj s in
if Config.write_html then
F.fprintf fmt "%aERROR: %s%a" Io_infer.Html.pp_start_color Pp.Red s
Io_infer.Html.pp_end_color ()
else F.fprintf fmt "ERROR: %s" s
| L.PTwarning, s
-> let s : string = Obj.obj s in
| L.PTwarning, s ->
let s : string = Obj.obj s in
if Config.write_html then
F.fprintf fmt "%aWARNING: %s%a" Io_infer.Html.pp_start_color Pp.Orange s
Io_infer.Html.pp_end_color ()
else F.fprintf fmt "WARNING: %s" s
| L.PTinfo, s
-> let s : string = Obj.obj s in
| L.PTinfo, s ->
let s : string = Obj.obj s in
if Config.write_html then
F.fprintf fmt "%aINFO: %s%a" Io_infer.Html.pp_start_color Pp.Blue s
Io_infer.Html.pp_end_color ()
else F.fprintf fmt "INFO: %s" s
(** Set printer hook as soon as this module is loaded *)
let () = L.printer_hook := force_delayed_print
@ -307,6 +318,7 @@ let force_delayed_prints () =
L.reset_delayed_prints () ;
Config.forcing_delayed_prints := false
(** Start a session, and create a new html fine for the node if it does not exist yet *)
let start_session node (loc: Location.t) proc_name session source =
let node_id = Procdesc.Node.get_id node in
@ -324,6 +336,7 @@ let start_session node (loc: Location.t) proc_name session source =
((node_id :> int), session, loc.Location.line) ;
F.fprintf !curr_html_formatter "<LISTING>%a" Io_infer.Html.pp_start_color Pp.Black
let node_start_session node session =
if Config.write_html then
let loc = Procdesc.Node.get_loc node in
@ -331,16 +344,19 @@ let node_start_session node session =
let pname = Procdesc.Node.get_proc_name node in
start_session node loc pname session source
(** Finish a session, and perform delayed print actions if required *)
let node_finish_session node =
if not Config.only_cheap_debug then force_delayed_prints () else L.reset_delayed_prints () ;
if Config.write_html then (
F.fprintf !curr_html_formatter "</LISTING>%a" Io_infer.Html.pp_end_color () ;
let source = (Procdesc.Node.get_loc node).file in
NodesHtml.finish_node (Procdesc.Node.get_proc_name node)
NodesHtml.finish_node
(Procdesc.Node.get_proc_name node)
(Procdesc.Node.get_id node :> int)
source )
(** Write html file for the procedure.
The boolean indicates whether to print whole seconds only *)
let write_proc_html pdesc =
@ -368,12 +384,13 @@ let write_proc_html pdesc =
(Procdesc.Node.get_id n :> int))
nodes ;
match Specs.get_summary pname with
| None
-> ()
| Some summary
-> Specs.pp_summary_html source Black fmt summary ;
| None ->
()
| Some summary ->
Specs.pp_summary_html source Black fmt summary ;
Io_infer.Html.close (fd, fmt)
(** Creare a hash table mapping line numbers to the set of errors occurring on that line *)
let create_table_err_per_line err_log =
let err_per_line = Hashtbl.create 17 in
@ -389,10 +406,12 @@ let create_table_err_per_line err_log =
in
Errlog.iter add_err err_log ; err_per_line
(** Create error message for html file *)
let create_err_message err_string =
"\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>"
let write_html_proc source proof_cover table_nodes_at_linenum global_err_log proc_desc =
let proc_name = Procdesc.get_proc_name proc_desc in
let process_node n =
@ -408,22 +427,23 @@ let write_html_proc source proof_cover table_nodes_at_linenum global_err_log pro
Procdesc.is_defined proc_desc && SourceFile.equal proc_loc.Location.file source
&&
match Attributes.find_file_capturing_procedure proc_name with
| None
-> true
| Some (source_captured, _)
-> SourceFile.equal source_captured (Procdesc.get_loc proc_desc).file
| None ->
true
| Some (source_captured, _) ->
SourceFile.equal source_captured (Procdesc.get_loc proc_desc).file
in
if process_proc then (
List.iter ~f:process_node (Procdesc.get_nodes proc_desc) ;
match Specs.get_summary proc_name with
| None
-> ()
| Some summary
-> List.iter
| None ->
()
| Some summary ->
List.iter
~f:(fun sp -> proof_cover := Specs.Visitedset.union sp.Specs.visited !proof_cover)
(Specs.get_specs_from_payload summary) ;
Errlog.update global_err_log summary.Specs.attributes.ProcAttributes.err_log )
(** Create filename.ext.html. *)
let write_html_file linereader filename procs =
let fname_encoding = DB.source_file_encoding filename in
@ -437,10 +457,10 @@ let write_html_file linereader filename procs =
let print_one_line proof_cover table_nodes_at_linenum table_err_per_line line_number =
let line_html =
match LineReader.from_file_linenum linereader filename line_number with
| Some line_raw
-> Escape.escape_xml line_raw
| None
-> raise End_of_file
| Some line_raw ->
Escape.escape_xml line_raw
| None ->
raise End_of_file
in
let nodes_at_linenum =
try Hashtbl.find table_nodes_at_linenum line_number
@ -473,21 +493,21 @@ let write_html_file linereader filename procs =
List.iter
~f:(fun n ->
match Procdesc.Node.get_kind n with
| Procdesc.Node.Start_node proc_name
-> let num_specs =
| Procdesc.Node.Start_node proc_name ->
let num_specs =
match Specs.get_summary proc_name with
| None
-> 0
| Some summary
-> List.length (Specs.get_specs_from_payload summary)
| None ->
0
| Some summary ->
List.length (Specs.get_specs_from_payload summary)
in
let label =
Escape.escape_xml (Typ.Procname.to_string proc_name) ^ ": " ^ string_of_int num_specs
^ " specs"
in
Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label
| _
-> ())
| _ ->
())
nodes_at_linenum ;
List.iter
~f:(fun err_string -> F.fprintf fmt "%s" (create_err_message err_string))
@ -511,6 +531,7 @@ let write_html_file linereader filename procs =
Errlog.pp_html filename [fname_encoding] fmt global_err_log ;
Io_infer.Html.close (fd, fmt)
(** Create filename.ext.html for each file in the cluster. *)
let write_all_html_files cluster =
let exe_env = Exe_env.from_cluster cluster in
@ -518,10 +539,10 @@ let write_all_html_files cluster =
let () = List.iter ~f:load_proc_desc (Cg.get_defined_nodes (Exe_env.get_cg exe_env)) in
let opt_whitelist_regex =
match Config.write_html_whitelist_regex with
| []
-> None
| _ as reg_list
-> Some (Str.regexp (String.concat ~sep:"\\|" reg_list))
| [] ->
None
| _ as reg_list ->
Some (Str.regexp (String.concat ~sep:"\\|" reg_list))
in
let is_whitelisted file =
Option.value_map opt_whitelist_regex ~default:true ~f:(fun regex ->
@ -543,3 +564,4 @@ let write_all_html_files cluster =
(fun file -> write_html_file linereader file (Cfg.get_all_procs cfg))
source_files_in_cfg)
exe_env

1770
infer/src/backend/prop.ml
View File

File diff suppressed because it is too large Load Diff

243
infer/src/backend/propgraph.ml
Unescape View File

@ -27,14 +27,15 @@ let from_prop p = p
(** Return [true] if root node *)
let rec is_root = function
| Exp.Var id
-> Ident.is_normal id
| Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Lvar _
-> true
| Exp.Cast (_, e)
-> is_root e
| Exp.UnOp _ | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ | Exp.Sizeof _
-> false
| Exp.Var id ->
Ident.is_normal id
| Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Lvar _ ->
true
| Exp.Cast (_, e) ->
is_root e
| Exp.UnOp _ | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ | Exp.Sizeof _ ->
false
(** Return [true] if the nodes are connected. Used to compute reachability. *)
let nodes_connected n1 n2 = Exp.equal n1 n2
@ -46,35 +47,37 @@ let edge_is_hpred = function Ehpred _ -> true | Eatom _ -> false | Esub_entry _
(** Return the source of the edge *)
let edge_get_source = function
| Ehpred Sil.Hpointsto (e, _, _)
-> Some e
| Ehpred Sil.Hlseg (_, _, e, _, _)
-> Some e
| Ehpred Sil.Hdllseg (_, _, e1, _, _, _, _)
-> Some e1 (* only one direction supported for now *)
| Eatom Sil.Aeq (e1, _)
-> Some e1
| Eatom Sil.Aneq (e1, _)
-> Some e1
| Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _))
-> Some e
| Eatom (Sil.Apred (_, []) | Anpred (_, []))
-> None
| Esub_entry (x, _)
-> Some (Exp.Var x)
| Ehpred Sil.Hpointsto (e, _, _) ->
Some e
| Ehpred Sil.Hlseg (_, _, e, _, _) ->
Some e
| Ehpred Sil.Hdllseg (_, _, e1, _, _, _, _) ->
Some e1 (* only one direction supported for now *)
| Eatom Sil.Aeq (e1, _) ->
Some e1
| Eatom Sil.Aneq (e1, _) ->
Some e1
| Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) ->
Some e
| Eatom (Sil.Apred (_, []) | Anpred (_, [])) ->
None
| Esub_entry (x, _) ->
Some (Exp.Var x)
(** Return the successor nodes of the edge *)
let edge_get_succs = function
| Ehpred hpred
-> Exp.Set.elements (Prop.hpred_get_targets hpred)
| Eatom Sil.Aeq (_, e2)
-> [e2]
| Eatom Sil.Aneq (_, e2)
-> [e2]
| Eatom (Sil.Apred _ | Anpred _)
-> []
| Esub_entry (_, e)
-> [e]
| Ehpred hpred ->
Exp.Set.elements (Prop.hpred_get_targets hpred)
| Eatom Sil.Aeq (_, e2) ->
[e2]
| Eatom Sil.Aneq (_, e2) ->
[e2]
| Eatom (Sil.Apred _ | Anpred _) ->
[]
| Esub_entry (_, e) ->
[e]
let get_sigma footprint_part g = if footprint_part then g.Prop.sigma_fp else g.Prop.sigma
@ -95,11 +98,13 @@ let edge_from_source g n footprint_part is_hpred =
in
match List.filter ~f:starts_from edges with [] -> None | edge :: _ -> Some edge
(** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g].
[footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *)
let get_succs g n footprint_part is_hpred =
match edge_from_source g n footprint_part is_hpred with None -> [] | Some e -> edge_get_succs e
(** [get_edges footprint_part g] returns the list of edges in [g], in the footprint part if [fotprint_part] is true *)
let get_edges footprint_part g =
let hpreds = get_sigma footprint_part g in
@ -108,22 +113,25 @@ let get_edges footprint_part g =
List.map ~f:(fun hpred -> Ehpred hpred) hpreds @ List.map ~f:(fun a -> Eatom a) atoms
@ List.map ~f:(fun entry -> Esub_entry entry) subst_entries
let edge_equal e1 e2 =
match (e1, e2) with
| Ehpred hp1, Ehpred hp2
-> Sil.equal_hpred hp1 hp2
| Eatom a1, Eatom a2
-> Sil.equal_atom a1 a2
| Esub_entry (x1, e1), Esub_entry (x2, e2)
-> Ident.equal x1 x2 && Exp.equal e1 e2
| _
-> false
| Ehpred hp1, Ehpred hp2 ->
Sil.equal_hpred hp1 hp2
| Eatom a1, Eatom a2 ->
Sil.equal_atom a1 a2
| Esub_entry (x1, e1), Esub_entry (x2, e2) ->
Ident.equal x1 x2 && Exp.equal e1 e2
| _ ->
false
(** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e],
searching the footprint part if [footprint_part] is true. *)
let contains_edge (footprint_part: bool) (g: t) (e: edge) =
List.exists ~f:(fun e' -> edge_equal e e') (get_edges footprint_part g)
(** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges];
if [footprint_part] is true the edges are taken from the footprint part. *)
let iter_edges footprint_part f g = List.iter ~f (get_edges footprint_part g)
@ -140,66 +148,71 @@ type diff =
let compute_exp_diff (e1: Exp.t) (e2: Exp.t) : Obj.t list =
if Exp.equal e1 e2 then [] else [Obj.repr e2]
(** Compute the subobjects in [se2] which are different from those in [se1] *)
let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list =
match (se1, se2) with
| Sil.Eexp (e1, _), Sil.Eexp (e2, _)
-> if Exp.equal e1 e2 then [] else [Obj.repr se2]
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _)
-> compute_fsel_diff fsel1 fsel2
| Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _)
-> compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2
| _
-> [Obj.repr se2]
| Sil.Eexp (e1, _), Sil.Eexp (e2, _) ->
if Exp.equal e1 e2 then [] else [Obj.repr se2]
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) ->
compute_fsel_diff fsel1 fsel2
| Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) ->
compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2
| _ ->
[Obj.repr se2]
and compute_fsel_diff fsel1 fsel2 : Obj.t list =
match (fsel1, fsel2) with
| (f1, se1) :: fsel1', (f2, se2 as x) :: fsel2' -> (
| (f1, se1) :: fsel1', ((f2, se2) as x) :: fsel2' -> (
match Typ.Fieldname.compare f1 f2 with
| n when n < 0
-> compute_fsel_diff fsel1' fsel2
| 0
-> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2'
| _
-> Obj.repr x :: compute_fsel_diff fsel1 fsel2' )
| _, []
-> []
| [], x :: fsel2'
-> Obj.repr x :: compute_fsel_diff [] fsel2'
| n when n < 0 ->
compute_fsel_diff fsel1' fsel2
| 0 ->
compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2'
| _ ->
Obj.repr x :: compute_fsel_diff fsel1 fsel2' )
| _, [] ->
[]
| [], x :: fsel2' ->
Obj.repr x :: compute_fsel_diff [] fsel2'
and compute_esel_diff esel1 esel2 : Obj.t list =
match (esel1, esel2) with
| (e1, se1) :: esel1', (e2, se2 as x) :: esel2' -> (
| (e1, se1) :: esel1', ((e2, se2) as x) :: esel2' -> (
match Exp.compare e1 e2 with
| n when n < 0
-> compute_esel_diff esel1' esel2
| 0
-> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2'
| _
-> Obj.repr x :: compute_esel_diff esel1 esel2' )
| _, []
-> []
| [], x :: esel2'
-> Obj.repr x :: compute_esel_diff [] esel2'
| n when n < 0 ->
compute_esel_diff esel1' esel2
| 0 ->
compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2'
| _ ->
Obj.repr x :: compute_esel_diff esel1 esel2' )
| _, [] ->
[]
| [], x :: esel2' ->
Obj.repr x :: compute_esel_diff [] esel2'
(** Compute the subobjects in [newedge] which are different from those in [oldedge] *)
let compute_edge_diff (oldedge: edge) (newedge: edge) : Obj.t list =
match (oldedge, newedge) with
| Ehpred Sil.Hpointsto (_, se1, e1), Ehpred Sil.Hpointsto (_, se2, e2)
-> compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2
| Eatom Sil.Aeq (_, e1), Eatom Sil.Aeq (_, e2)
-> compute_exp_diff e1 e2
| Eatom Sil.Aneq (_, e1), Eatom Sil.Aneq (_, e2)
-> compute_exp_diff e1 e2
| Ehpred Sil.Hpointsto (_, se1, e1), Ehpred Sil.Hpointsto (_, se2, e2) ->
compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2
| Eatom Sil.Aeq (_, e1), Eatom Sil.Aeq (_, e2) ->
compute_exp_diff e1 e2
| Eatom Sil.Aneq (_, e1), Eatom Sil.Aneq (_, e2) ->
compute_exp_diff e1 e2
| Eatom Sil.Apred (_, es1), Eatom Sil.Apred (_, es2)
| Eatom Sil.Anpred (_, es1), Eatom Sil.Anpred (_, es2)
-> List.concat
| Eatom Sil.Anpred (_, es1), Eatom Sil.Anpred (_, es2) ->
List.concat
( try List.map2_exn ~f:compute_exp_diff es1 es2
with Invalid_argument _ -> [] )
| Esub_entry (_, e1), Esub_entry (_, e2)
-> compute_exp_diff e1 e2
| _
-> [Obj.repr newedge]
| Esub_entry (_, e1), Esub_entry (_, e2) ->
compute_exp_diff e1 e2
| _ ->
[Obj.repr newedge]
(** [compute_diff oldgraph newgraph] returns the list of edges which are only in [newgraph] *)
let compute_diff default_color oldgraph newgraph : diff =
@ -211,21 +224,21 @@ let compute_diff default_color oldgraph newgraph : diff =
match edge_get_source edge with
| Some source -> (
match edge_from_source oldgraph source footprint_part (edge_is_hpred edge) with
| None
-> let changed_obj =
| None ->
let changed_obj =
match edge with
| Ehpred hpred
-> Obj.repr hpred
| Eatom a
-> Obj.repr a
| Esub_entry entry
-> Obj.repr entry
| Ehpred hpred ->
Obj.repr hpred
| Eatom a ->
Obj.repr a
| Esub_entry entry ->
Obj.repr entry
in
changed := changed_obj :: !changed
| Some oldedge
-> changed := compute_edge_diff oldedge edge @ !changed )
| None
-> ()
| Some oldedge ->
changed := compute_edge_diff oldedge edge @ !changed )
| None ->
()
in
List.iter ~f:build_changed newedges ;
let colormap (o: Obj.t) =
@ -241,11 +254,13 @@ let compute_diff default_color oldgraph newgraph : diff =
; diff_changed_foot= changed_foot
; diff_cmap_foot= colormap_foot }
(** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff,
selecting the footprint colormap if [footprint_part] is true. *)
let diff_get_colormap footprint_part diff =
if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm
(** Print a list of propositions, prepending each one with the given string.
If !Config.pring_using_diff is true, print the diff w.r.t. the given prop,
extracting its local stack vars if the boolean is true. *)
@ -264,38 +279,40 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist =
else pe0
in
let rec pp_seq_newline n f = function
| []
-> ()
| [] ->
()
| [_x]
-> (
-> (
let pe = update_pe_diff _x in
let x = add_base_stack _x in
match pe.kind with
| TEXT
-> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x
| HTML
-> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x
| LATEX
-> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x )
| _x :: l
-> let pe = update_pe_diff _x in
| TEXT ->
F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x
| HTML ->
F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x
| LATEX ->
F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x )
| _x :: l ->
let pe = update_pe_diff _x in
let x = add_base_stack _x in
match pe.kind with
| TEXT
-> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x
| TEXT ->
F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x
(pp_seq_newline (n + 1))
l
| HTML
-> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x
| HTML ->
F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x
(pp_seq_newline (n + 1))
l
| LATEX
-> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x
| LATEX ->
F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x
(pp_seq_newline (n + 1))
l
in
pp_seq_newline 1 f plist
(** dump a propset *)
let d_proplist (p: 'a Prop.t) (pl: 'b Prop.t list) =
L.add_print_action (L.PTproplist, Obj.repr (p, pl))

5
infer/src/backend/propset.ml
Unescape View File

@ -35,6 +35,7 @@ let add tenv p pset =
~f:(fun pset' p' -> PropSet.add (Prop.prop_rename_primed_footprint_vars tenv p') pset')
~init:pset ps
(** Singleton set. *)
let singleton tenv p = add tenv p PropSet.empty
@ -71,6 +72,7 @@ let map_option tenv f pset =
let plist = List.map ~f:(function Some p -> p | None -> assert false) plisto in
from_proplist tenv plist
(** Apply function to all the elements of [propset]. *)
let map tenv f pset = from_proplist tenv (List.map ~f (to_proplist pset))
@ -80,6 +82,7 @@ let fold f a pset =
let l = to_proplist pset in
List.fold ~f ~init:a l
(** [iter f pset] computes (f p1;f p2;..;f pN)
where [p1 ... pN] are the elements of pset, in increasing order. *)
let iter = PropSet.iter
@ -95,6 +98,8 @@ let pp pe prop f pset =
let plist = to_proplist pset in
Propgraph.pp_proplist pe "PROP" (prop, false) f plist
let d p ps =
let plist = to_proplist ps in
Propgraph.d_proplist p plist

1622
infer/src/backend/prover.ml
View File

File diff suppressed because it is too large Load Diff

837
infer/src/backend/rearrange.ml
View File

File diff suppressed because it is too large Load Diff

14
infer/src/backend/reporting.ml
Unescape View File

@ -30,6 +30,7 @@ let log_issue_from_errlog err_kind err_log ?loc ?node_id ?session ?ltr ?linters_
if not Config.filtering (* no-filtering takes priority *) || issue_type.IssueType.enabled then
Errlog.log_issue err_kind err_log loc node_id session ltr ?linters_def_file ?doc_url exn
let log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url
exn =
let is_generated_method = Typ.Procname.java_is_generated (Specs.get_proc_name summary) in
@ -44,20 +45,22 @@ let log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters
log_issue_from_errlog err_kind err_log ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url
exn
let log_issue_deprecated ?(store_summary= false) err_kind proc_name ?loc ?node_id ?session ?ltr
?linters_def_file ?doc_url exn =
match Specs.get_summary proc_name with
| Some summary
-> log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file
| Some summary ->
log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file
?doc_url exn ;
if store_summary then
(* TODO (#16348004): This is currently needed as ThreadSafety works as a cluster checker *)
Specs.store_summary summary
| None
-> L.(die InternalError)
| None ->
L.(die InternalError)
"Trying to report error on procedure %a, but cannot because no summary exists for this procedure. Did you mean to log the error on the caller of %a instead?"
Typ.Procname.pp proc_name Typ.Procname.pp proc_name
let log_error_from_errlog = log_issue_from_errlog Exceptions.Kerror
let log_warning_from_errlog = log_issue_from_errlog Exceptions.Kwarning
@ -73,8 +76,11 @@ let log_info = log_issue_from_summary Exceptions.Kwarning
let log_error_deprecated ?(store_summary= false) =
log_issue_deprecated ~store_summary Exceptions.Kerror
let log_warning_deprecated ?(store_summary= false) =
log_issue_deprecated ~store_summary Exceptions.Kwarning
let log_info_deprecated ?(store_summary= false) =
log_issue_deprecated ~store_summary Exceptions.Kinfo

294
infer/src/backend/specs.ml
Unescape View File

@ -43,23 +43,26 @@ module Jprop = struct
let to_number = function Prop (n, _) -> n | Joined (n, _, _, _) -> n
let rec fav_add_dfs tenv fav = function
| Prop (_, p)
-> Prop.prop_fav_add_dfs tenv fav p
| Joined (_, p, jp1, jp2)
-> Prop.prop_fav_add_dfs tenv fav p ; fav_add_dfs tenv fav jp1 ; fav_add_dfs tenv fav jp2
| Prop (_, p) ->
Prop.prop_fav_add_dfs tenv fav p
| Joined (_, p, jp1, jp2) ->
Prop.prop_fav_add_dfs tenv fav p ; fav_add_dfs tenv fav jp1 ; fav_add_dfs tenv fav jp2
let rec normalize tenv = function
| Prop (n, p)
-> Prop (n, Prop.normalize tenv p)
| Joined (n, p, jp1, jp2)
-> Joined (n, Prop.normalize tenv p, normalize tenv jp1, normalize tenv jp2)
| Prop (n, p) ->
Prop (n, Prop.normalize tenv p)
| Joined (n, p, jp1, jp2) ->
Joined (n, Prop.normalize tenv p, normalize tenv jp1, normalize tenv jp2)
(** Return a compact representation of the jprop *)
let rec compact sh = function
| Prop (n, p)
-> Prop (n, Prop.prop_compact sh p)
| Joined (n, p, jp1, jp2)
-> Joined (n, Prop.prop_compact sh p, compact sh jp1, compact sh jp2)
| Prop (n, p) ->
Prop (n, Prop.prop_compact sh p)
| Joined (n, p, jp1, jp2) ->
Joined (n, Prop.prop_compact sh p, compact sh jp1, compact sh jp2)
(** Print the toplevel prop *)
let pp_short pe f jp = Prop.pp_prop pe f (to_prop jp)
@ -73,59 +76,65 @@ module Jprop = struct
(** Print a list of joined props, the boolean indicates whether to print subcomponents of joined props *)
let pp_list pe shallow f jplist =
let rec pp_seq_newline f = function
| []
-> ()
| [(Prop (n, p))]
-> F.fprintf f "PROP %d:@\n%a" n (Prop.pp_prop pe) p
| [(Joined (n, p, p1, p2))]
-> if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p1] ;
| [] ->
()
| [(Prop (n, p))] ->
F.fprintf f "PROP %d:@\n%a" n (Prop.pp_prop pe) p
| [(Joined (n, p, p1, p2))] ->
if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p1] ;
if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p2] ;
F.fprintf f "PROP %d (join of %d,%d):@\n%a" n (get_id p1) (get_id p2) (Prop.pp_prop pe) p
| jp :: l
-> F.fprintf f "%a@\n" pp_seq_newline [jp] ;
| jp :: l ->
F.fprintf f "%a@\n" pp_seq_newline [jp] ;
pp_seq_newline f l
in
pp_seq_newline f jplist
(** dump a joined prop list, the boolean indicates whether to print toplevel props only *)
let d_list (shallow: bool) (jplist: Prop.normal t list) =
L.add_print_action (L.PTjprop_list, Obj.repr (shallow, jplist))
let rec fav_add fav = function
| Prop (_, p)
-> Prop.prop_fav_add fav p
| Joined (_, p, jp1, jp2)
-> Prop.prop_fav_add fav p ; fav_add fav jp1 ; fav_add fav jp2
| Prop (_, p) ->
Prop.prop_fav_add fav p
| Joined (_, p, jp1, jp2) ->
Prop.prop_fav_add fav p ; fav_add fav jp1 ; fav_add fav jp2
let rec jprop_sub sub = function
| Prop (n, p)
-> Prop (n, Prop.prop_sub sub p)
| Joined (n, p, jp1, jp2)
-> let p' = Prop.prop_sub sub p in
| Prop (n, p) ->
Prop (n, Prop.prop_sub sub p)
| Joined (n, p, jp1, jp2) ->
let p' = Prop.prop_sub sub p in
let jp1' = jprop_sub sub jp1 in
let jp2' = jprop_sub sub jp2 in
Joined (n, p', jp1', jp2')
let filter (f: 'a t -> 'b option) jpl =
let rec do_filter acc = function
| []
-> acc
| [] ->
acc
| (Prop _ as jp) :: jpl -> (
match f jp with Some x -> do_filter (x :: acc) jpl | None -> do_filter acc jpl )
| (Joined (_, _, jp1, jp2) as jp) :: jpl ->
match f jp with
| Some x
-> do_filter (x :: acc) jpl
| None
-> do_filter acc (jpl @ [jp1; jp2])
| Some x ->
do_filter (x :: acc) jpl
| None ->
do_filter acc (jpl @ [jp1; jp2])
in
do_filter [] jpl
let rec map (f: 'a Prop.t -> 'b Prop.t) = function
| Prop (n, p)
-> Prop (n, f p)
| Joined (n, p, jp1, jp2)
-> Joined (n, f p, map f jp1, map f jp2)
| Prop (n, p) ->
Prop (n, f p)
| Joined (n, p, jp1, jp2) ->
Joined (n, f p, map f jp1, map f jp2)
(*
let rec jprop_sub sub = function
@ -159,6 +168,7 @@ let visited_str vis =
Int.Set.iter ~f:(fun n -> s := !s ^ " " ^ string_of_int n) !lines ;
!s
(** A spec consists of:
pre: a joined prop
post: a list of props with path
@ -189,12 +199,14 @@ end = struct
List.iter ~f:(fun (p, _) -> Prop.prop_fav_add_dfs tenv fav p) spec.posts ;
fav
let spec_sub tenv sub spec =
{ pre= Jprop.normalize tenv (Jprop.jprop_sub sub spec.pre)
; posts=
List.map ~f:(fun (p, path) -> (Prop.normalize tenv (Prop.prop_sub sub p), path)) spec.posts
; visited= spec.visited }
(** Convert spec into normal form w.r.t. variable renaming *)
let normalize tenv (spec: Prop.normal spec) : Prop.normal spec =
let fav = spec_fav tenv spec in
@ -208,16 +220,19 @@ end = struct
in
spec_sub tenv sub spec
(** Return a compact representation of the spec *)
let compact sh spec =
let pre = Jprop.compact sh spec.pre in
let posts = List.map ~f:(fun (p, path) -> (Prop.prop_compact sh p, path)) spec.posts in
{pre; posts; visited= spec.visited}
(** Erase join info from pre of spec *)
let erase_join_info_pre tenv spec =
let spec' = {spec with pre= Jprop.Prop (1, Jprop.to_prop spec.pre)} in
normalize tenv spec'
end
(** Convert spec into normal form w.r.t. variable renaming *)
@ -256,6 +271,7 @@ module CallStats = struct
let do_call pn_loc = PnameLocHash.add hash pn_loc empty_trace in
List.iter ~f:do_call calls ; hash
let trace t proc_name loc res in_footprint =
let tr_old =
try PnameLocHash.find t (proc_name, loc)
@ -266,21 +282,23 @@ module CallStats = struct
let tr_new = trace_add tr_old res in_footprint in
PnameLocHash.replace t (proc_name, loc) tr_new
let tr_elem_str (cr, in_footprint) =
let s1 =
match cr with
| CR_success
-> "OK"
| CR_not_met
-> "NotMet"
| CR_not_found
-> "NotFound"
| CR_skip
-> "Skip"
| CR_success ->
"OK"
| CR_not_met ->
"NotMet"
| CR_not_found ->
"NotFound"
| CR_skip ->
"Skip"
in
let s2 = if in_footprint then "FP" else "RE" in
s1 ^ ":" ^ s2
let pp_trace fmt tr = Pp.seq (fun fmt x -> F.fprintf fmt "%s" (tr_elem_str x)) fmt (List.rev tr)
let iter f t =
@ -294,6 +312,7 @@ module CallStats = struct
in
List.iter ~f:(fun (x, tr) -> f x tr) sorted_elems
(*
let pp fmt t =
let do_call (pname, loc) tr =
@ -358,51 +377,55 @@ let clear_spec_tbl () = Typ.Procname.Hash.clear spec_tbl
let pp_failure_kind_opt fmt failure_kind_opt =
match failure_kind_opt with
| Some failure_kind
-> SymOp.pp_failure_kind fmt failure_kind
| None
-> F.fprintf fmt "NONE"
| Some failure_kind ->
SymOp.pp_failure_kind fmt failure_kind
| None ->
F.fprintf fmt "NONE"
let pp_errlog fmt err_log =
F.fprintf fmt "ERRORS: @[<h>%a@]@\n%!" Errlog.pp_errors err_log ;
F.fprintf fmt "WARNINGS: @[<h>%a@]" Errlog.pp_warnings err_log
let pp_stats fmt stats =
F.fprintf fmt "FAILURE:%a SYMOPS:%d@\n" pp_failure_kind_opt stats.stats_failure stats.symops
(** Print the spec *)
let pp_spec pe num_opt fmt spec =
let num_str =
match num_opt with
| None
-> "----------"
| Some (n, tot)
-> Format.sprintf "%d of %d [nvisited:%s]" n tot (visited_str spec.visited)
| None ->
"----------"
| Some (n, tot) ->
Format.sprintf "%d of %d [nvisited:%s]" n tot (visited_str spec.visited)
in
let pre = Jprop.to_prop spec.pre in
let pe_post = Prop.prop_update_obj_sub pe pre in
let post_list = List.map ~f:fst spec.posts in
match pe.Pp.kind with
| TEXT
-> F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ;
| TEXT ->
F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ;
F.fprintf fmt "PRE:@\n%a@\n" (Prop.pp_prop Pp.text) pre ;
F.fprintf fmt "%a@\n" (Propgraph.pp_proplist pe_post "POST" (pre, true)) post_list ;
F.fprintf fmt "----------------------------------------------------------------"
| HTML
-> F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ;
| HTML ->
F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ;
F.fprintf fmt "PRE:@\n%a%a%a@\n" Io_infer.Html.pp_start_color Pp.Blue
(Prop.pp_prop (Pp.html Blue))
pre Io_infer.Html.pp_end_color () ;
F.fprintf fmt "%a" (Propgraph.pp_proplist pe_post "POST" (pre, true)) post_list ;
F.fprintf fmt "----------------------------------------------------------------"
| LATEX
-> F.fprintf fmt "\\textbf{\\large Requires}\\\\@\n@[%a%a%a@]\\\\@\n" Latex.pp_color Pp.Blue
| LATEX ->
F.fprintf fmt "\\textbf{\\large Requires}\\\\@\n@[%a%a%a@]\\\\@\n" Latex.pp_color Pp.Blue
(Prop.pp_prop (Pp.latex Blue))
pre Latex.pp_color pe.Pp.color ;
F.fprintf fmt "\\textbf{\\large Ensures}\\\\@\n@[%a@]"
(Propgraph.pp_proplist pe_post "POST" (pre, true))
post_list
(** Dump a spec *)
let d_spec (spec: 'a spec) = L.add_print_action (L.PTspec, Obj.repr spec)
@ -410,29 +433,31 @@ let pp_specs pe fmt specs =
let total = List.length specs in
let cnt = ref 0 in
match pe.Pp.kind with
| TEXT
-> List.iter
| TEXT ->
List.iter
~f:(fun spec ->
incr cnt ;
F.fprintf fmt "%a" (pp_spec pe (Some (!cnt, total))) spec)
specs
| HTML
-> List.iter
| HTML ->
List.iter
~f:(fun spec ->
incr cnt ;
F.fprintf fmt "%a<br>@\n" (pp_spec pe (Some (!cnt, total))) spec)
specs
| LATEX
-> List.iter
| LATEX ->
List.iter
~f:(fun spec ->
incr cnt ;
F.fprintf fmt "\\subsection*{Spec %d of %d}@\n\\(%a\\)@\n" !cnt total (pp_spec pe None)
spec)
specs
let describe_phase summary =
("Phase", if equal_phase summary.phase FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION")
(** Return the signature of a procedure declaration as a string *)
let get_signature summary =
let s = ref "" in
@ -449,6 +474,7 @@ let get_signature summary =
let decl = F.asprintf "%t" pp in
decl ^ "(" ^ !s ^ ")"
let get_specs_from_preposts preposts = Option.value_map ~f:NormSpec.tospecs ~default:[] preposts
let get_specs_from_payload summary = get_specs_from_preposts summary.payload.preposts
@ -459,6 +485,7 @@ let pp_summary_no_stats_specs fmt summary =
F.fprintf fmt "%a@\n" pp_status summary.status ;
F.fprintf fmt "%a@\n" pp_pair (describe_phase summary)
let pp_payload pe fmt
{ preposts
; typestate
@ -470,21 +497,29 @@ let pp_payload pe fmt
; annot_map
; uninit } =
let pp_opt prefix pp fmt = function
| Some x
-> F.fprintf fmt "%s: %a@\n" prefix pp x
| None
-> ()
| Some x ->
F.fprintf fmt "%s: %a@\n" prefix pp x
| None ->
()
in
F.fprintf fmt "%a%a%a%a%a%a%a%a%a@\n"
(pp_opt "PrePosts" (pp_specs pe))
(Option.map ~f:NormSpec.tospecs preposts)
(pp_opt "TypeState" (TypeState.pp TypeState.unit_ext))
typestate (pp_opt "CrashContext" Crashcontext.pp_stacktree) crashcontext_frame
(pp_opt "Quandary" QuandarySummary.pp) quandary (pp_opt "Siof" SiofDomain.pp) siof
(pp_opt "RacerD" RacerDDomain.pp_summary) racerd
(pp_opt "BufferOverrun" BufferOverrunDomain.Summary.pp) buffer_overrun
(pp_opt "AnnotationReachability" AnnotReachabilityDomain.pp) annot_map
(pp_opt "Uninitialised" UninitDomain.pp_summary) uninit
typestate
(pp_opt "CrashContext" Crashcontext.pp_stacktree)
crashcontext_frame
(pp_opt "Quandary" QuandarySummary.pp)
quandary (pp_opt "Siof" SiofDomain.pp) siof
(pp_opt "RacerD" RacerDDomain.pp_summary)
racerd
(pp_opt "BufferOverrun" BufferOverrunDomain.Summary.pp)
buffer_overrun
(pp_opt "AnnotationReachability" AnnotReachabilityDomain.pp)
annot_map
(pp_opt "Uninitialised" UninitDomain.pp_summary)
uninit
let pp_summary_text fmt summary =
let err_log = summary.attributes.ProcAttributes.err_log in
@ -493,6 +528,7 @@ let pp_summary_text fmt summary =
F.fprintf fmt "%a@\n%a%a" pp_errlog err_log pp_stats summary.stats (pp_payload pe)
summary.payload
let pp_summary_latex color fmt summary =
let err_log = summary.attributes.ProcAttributes.err_log in
let pe = Pp.latex color in
@ -503,6 +539,7 @@ let pp_summary_latex color fmt summary =
F.fprintf fmt "\\end{verbatim}@\n" ;
F.fprintf fmt "%a@\n" (pp_specs pe) (get_specs_from_payload summary)
let pp_summary_html source color fmt summary =
let err_log = summary.attributes.ProcAttributes.err_log in
let pe = Pp.html color in
@ -516,6 +553,7 @@ let pp_summary_html source color fmt summary =
pp_payload pe fmt summary.payload ;
F.fprintf fmt "</LISTING>@\n"
let empty_stats calls =
{ stats_failure= None
; symops= 0
@ -523,12 +561,14 @@ let empty_stats calls =
; nodes_visited_re= IntSet.empty
; call_stats= CallStats.init calls }
let payload_compact sh payload =
match payload.preposts with
| Some specs
-> {payload with preposts= Some (List.map ~f:(NormSpec.compact sh) specs)}
| None
-> payload
| Some specs ->
{payload with preposts= Some (List.map ~f:(NormSpec.compact sh) specs)}
| None ->
payload
(** Return a compact representation of the summary *)
let summary_compact sh summary = {summary with payload= payload_compact sh summary.payload}
@ -539,15 +579,18 @@ let add_summary (proc_name: Typ.Procname.t) (summary: summary) : unit =
"Adding summary for %a@\n@[<v 2> %a@]@." Typ.Procname.pp proc_name pp_summary_text summary ;
Typ.Procname.Hash.replace spec_tbl proc_name summary
let specs_filename pname =
let pname_file = Typ.Procname.to_filename pname in
pname_file ^ Config.specs_files_suffix
(** path to the .specs file for the given procedure in the current results directory *)
let res_dir_specs_filename pname =
DB.Results_dir.path_to_filename DB.Results_dir.Abs_root
[Config.specs_dir_name; specs_filename pname]
(** paths to the .specs file for the given procedure in the current spec libraries *)
let specs_library_filenames pname =
List.map
@ -555,16 +598,20 @@ let specs_library_filenames pname =
DB.filename_from_string (Filename.concat specs_dir (specs_filename pname)))
Config.specs_library
(** paths to the .specs file for the given procedure in the models folder *)
let specs_models_filename pname =
DB.filename_from_string (Filename.concat Config.models_dir (specs_filename pname))
let summary_exists_in_models pname =
Sys.file_exists (DB.filename_to_string (specs_models_filename pname)) = `Yes
let summary_serializer : summary Serialization.serializer =
Serialization.create_serializer Serialization.Key.summary
(** Load procedure summary from the given file *)
let load_summary specs_file = Serialization.read_from_file summary_serializer specs_file
@ -575,57 +622,61 @@ let load_summary_to_spec_table proc_name =
match load_summary models_dir with None -> false | Some summ -> add summ
in
let rec load_summary_libs = function
| (* try to load the summary from a list of libs *)
[]
-> false
(* try to load the summary from a list of libs *)
| [] ->
false
| spec_path :: spec_paths ->
match load_summary spec_path with
| None
-> load_summary_libs spec_paths
| Some summ
-> add summ
| None ->
load_summary_libs spec_paths
| Some summ ->
add summ
in
let load_summary_ziplibs zip_specs_filename =
let zip_specs_path = Filename.concat Config.specs_dir_name zip_specs_filename in
match ZipLib.load summary_serializer zip_specs_path with
| None
-> false
| Some summary
-> add summary
| None ->
false
| Some summary ->
add summary
in
let default_spec_dir = res_dir_specs_filename proc_name in
match load_summary default_spec_dir with
| None
-> (* search on models, libzips, and libs *)
| None ->
(* search on models, libzips, and libs *)
load_summary_models (specs_models_filename proc_name)
|| load_summary_ziplibs (specs_filename proc_name)
|| load_summary_libs (specs_library_filenames proc_name)
| Some summ
-> add summ
| Some summ ->
add summ
let rec get_summary proc_name =
try Some (Typ.Procname.Hash.find spec_tbl proc_name)
with Not_found -> if load_summary_to_spec_table proc_name then get_summary proc_name else None
let get_summary_unsafe s proc_name =
match get_summary proc_name with
| None
-> L.(die InternalError)
| None ->
L.(die InternalError)
"[%s] Specs.get_summary_unsafe: %a Not found" s Typ.Procname.pp proc_name
| Some summary
-> summary
| Some summary ->
summary
(** Check if the procedure is from a library:
It's not defined, and there is no spec file for it. *)
let proc_is_library proc_attributes =
if not proc_attributes.ProcAttributes.is_defined then
match get_summary proc_attributes.ProcAttributes.proc_name with
| None
-> true
| Some _
-> false
| None ->
true
| Some _ ->
false
else false
(** Try to find the attributes for a defined proc.
First look at specs (to get attributes computed by analysis)
then look at the attributes table.
@ -638,27 +689,29 @@ let proc_resolve_attributes proc_name =
in
match from_specs () with
| Some attributes
-> (
-> (
if attributes.ProcAttributes.is_defined then Some attributes
else
match from_attributes_table () with
| Some attributes'
-> Some attributes'
| None
-> Some attributes )
| None
-> from_attributes_table ()
| Some attributes' ->
Some attributes'
| None ->
Some attributes )
| None ->
from_attributes_table ()
(** Like proc_resolve_attributes but start from a proc_desc. *)
let pdesc_resolve_attributes proc_desc =
let proc_name = Procdesc.get_proc_name proc_desc in
match proc_resolve_attributes proc_name with
| Some proc_attributes
-> proc_attributes
| None
-> (* this should not happen *)
| Some proc_attributes ->
proc_attributes
| None ->
(* this should not happen *)
assert false
let summary_exists proc_name = match get_summary proc_name with Some _ -> true | None -> false
let get_status summary = summary.status
@ -684,9 +737,11 @@ let store_summary (summ1: summary) =
let proc_name = get_proc_name final_summary in
(* Make sure the summary in memory is identical to the saved one *)
add_summary proc_name final_summary ;
Serialization.write_to_file summary_serializer (res_dir_specs_filename proc_name)
Serialization.write_to_file summary_serializer
(res_dir_specs_filename proc_name)
~data:final_summary
let empty_payload =
{ preposts= None
; typestate= None
@ -699,6 +754,7 @@ let empty_payload =
; buffer_overrun= None
; uninit= None }
(** [init_summary (depend_list, nodes,
proc_flags, calls, in_out_calls_opt, proc_attributes)]
initializes the summary for [proc_name] given dependent procs in list [depend_list]. *)
@ -710,10 +766,12 @@ let init_summary (nodes, proc_flags, calls, proc_attributes, proc_desc_option) =
; payload= empty_payload
; stats= empty_stats calls
; status= Pending
; attributes= {proc_attributes with ProcAttributes.proc_flags= proc_flags}
; attributes= {proc_attributes with ProcAttributes.proc_flags}
; proc_desc_option }
in
Typ.Procname.Hash.replace spec_tbl proc_attributes.ProcAttributes.proc_name summary ; summary
Typ.Procname.Hash.replace spec_tbl proc_attributes.ProcAttributes.proc_name summary ;
summary
let dummy =
init_summary
@ -723,6 +781,7 @@ let dummy =
, ProcAttributes.default Typ.Procname.empty_block Config.Java
, None )
(** Reset a summary rebuilding the dependents and preserving the proc attributes if present. *)
let reset_summary proc_desc =
let proc_desc_option =
@ -732,6 +791,7 @@ let reset_summary proc_desc =
let proc_flags = attributes.ProcAttributes.proc_flags in
init_summary ([], proc_flags, [], attributes, proc_desc_option)
(* =============== END of support for spec tables =============== *)
(*
let rec post_equal pl1 pl2 = match pl1, pl2 with

104
infer/src/backend/state.ml
Unescape View File

@ -57,6 +57,7 @@ let initial () =
; last_session= 0
; failure_map= NodeHash.create 1 }
(** Global state *)
let gs = ref (initial ())
@ -66,6 +67,7 @@ let save_state () =
gs := initial () ;
old
(** Restore the old state. *)
let restore_state st = gs := st
@ -77,12 +79,15 @@ let get_failure_stats node =
try NodeHash.find !gs.failure_map node
with Not_found ->
let fs = {instr_fail= 0; instr_ok= 0; node_fail= 0; node_ok= 0; first_failure= None} in
NodeHash.add !gs.failure_map node fs ; fs
NodeHash.add !gs.failure_map node fs ;
fs
let add_diverging_states pset =
!gs.diverging_states_proc <- Paths.PathSet.union pset !gs.diverging_states_proc ;
!gs.diverging_states_node <- Paths.PathSet.union pset !gs.diverging_states_node
let get_diverging_states_node () = !gs.diverging_states_node
let get_diverging_states_proc () = !gs.diverging_states_proc
@ -91,10 +96,11 @@ let get_instr () = !gs.last_instr
let get_loc () =
match !gs.last_instr with
| Some instr
-> Sil.instr_get_loc instr
| None
-> Procdesc.Node.get_loc !gs.last_node
| Some instr ->
Sil.instr_get_loc instr
| None ->
Procdesc.Node.get_loc !gs.last_node
let get_node () = !gs.last_node
@ -106,26 +112,27 @@ let node_simple_key node =
if Sil.instr_is_auxiliary instr then ()
else
match instr with
| Sil.Load _
-> add_key 1
| Sil.Store _
-> add_key 2
| Sil.Prune _
-> add_key 3
| Sil.Call _
-> add_key 4
| Sil.Nullify _
-> add_key 5
| Sil.Abstract _
-> add_key 6
| Sil.Remove_temps _
-> add_key 7
| Sil.Declare_locals _
-> add_key 8
| Sil.Load _ ->
add_key 1
| Sil.Store _ ->
add_key 2
| Sil.Prune _ ->
add_key 3
| Sil.Call _ ->
add_key 4
| Sil.Nullify _ ->
add_key 5
| Sil.Abstract _ ->
add_key 6
| Sil.Remove_temps _ ->
add_key 7
| Sil.Declare_locals _ ->
add_key 8
in
List.iter ~f:do_instr (Procdesc.Node.get_instrs node) ;
Hashtbl.hash !key
(** key for a node: look at the current node, successors and predecessors *)
let node_key node =
let succs = Procdesc.Node.get_succs node in
@ -135,6 +142,7 @@ let node_key node =
in
Hashtbl.hash v
(** normalize the list of instructions by renaming let-bound ids *)
let instrs_normalize instrs =
let bound_ids =
@ -151,6 +159,7 @@ let instrs_normalize instrs =
in
List.map ~f:(Sil.instr_sub subst) instrs
(** Create a function to find duplicate nodes.
A node is a duplicate of another one if they have the same kind and location
and normalized (w.r.t. renaming of let - bound ids) list of instructions. *)
@ -202,10 +211,10 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t =
let (_, node_normalized_instrs), _ =
let filter (node', _) = Procdesc.Node.equal node node' in
match List.partition_tf ~f:filter elements with
| [this], others
-> (this, others)
| _
-> raise Not_found
| [this], others ->
(this, others)
| _ ->
raise Not_found
in
let duplicates =
let equal_normalized_instrs (_, normalized_instrs') =
@ -220,6 +229,7 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t =
in
find_duplicate_nodes
let get_node_id () = Procdesc.Node.get_id !gs.last_node
let get_node_id_key () = (Procdesc.Node.get_id !gs.last_node, node_key !gs.last_node)
@ -228,17 +238,20 @@ let get_inst_update pos =
let loc = get_loc () in
Sil.inst_update loc pos
let get_path () =
match !gs.last_path with
| None
-> (Paths.Path.start !gs.last_node, None)
| Some (path, pos_opt)
-> (path, pos_opt)
| None ->
(Paths.Path.start !gs.last_node, None)
| Some (path, pos_opt) ->
(path, pos_opt)
let get_loc_trace () : Errlog.loc_trace =
let path, pos_opt = get_path () in
Paths.Path.create_loc_trace path pos_opt
let get_prop_tenv_pdesc () = !gs.last_prop_tenv_pdesc
(** extract the footprint of the prop, and turn it into a normalized precondition using spec variables *)
@ -260,34 +273,38 @@ let extract_pre p tenv pdesc abstract_fun =
in
Prop.normalize tenv (Prop.prop_sub sub pre')
(** return the normalized precondition extracted form the last prop seen, if any
the abstraction function is a parameter to get around module dependencies *)
let get_normalized_pre (abstract_fun: Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t)
: Prop.normal Prop.t option =
match get_prop_tenv_pdesc () with
| None
-> None
| Some (prop, tenv, pdesc)
-> Some (extract_pre prop tenv pdesc abstract_fun)
| None ->
None
| Some (prop, tenv, pdesc) ->
Some (extract_pre prop tenv pdesc abstract_fun)
let get_session () = !gs.last_session
let get_path_pos () =
let pname =
match get_prop_tenv_pdesc () with
| Some (_, _, pdesc)
-> Procdesc.get_proc_name pdesc
| None
-> Typ.Procname.from_string_c_fun "unknown_procedure"
| Some (_, _, pdesc) ->
Procdesc.get_proc_name pdesc
| None ->
Typ.Procname.from_string_c_fun "unknown_procedure"
in
let nid = get_node_id () in
(pname, (nid :> int))
let mark_execution_start node =
let fs = get_failure_stats node in
fs.instr_ok <- 0 ;
fs.instr_fail <- 0
let mark_execution_end node =
let fs = get_failure_stats node in
let success = Int.equal fs.instr_fail 0 in
@ -295,10 +312,12 @@ let mark_execution_end node =
fs.instr_fail <- 0 ;
if success then fs.node_ok <- fs.node_ok + 1 else fs.node_fail <- fs.node_fail + 1
let mark_instr_ok () =
let fs = get_failure_stats (get_node ()) in
fs.instr_ok <- fs.instr_ok + 1
let mark_instr_fail exn =
let loc = get_loc () in
let key = (get_node_id_key () :> int * int) in
@ -309,6 +328,7 @@ let mark_instr_fail exn =
fs.first_failure <- Some (loc, key, (session :> int), loc_trace, exn) ;
fs.instr_fail <- fs.instr_fail + 1
type log_issue =
?store_summary:bool -> Typ.Procname.t -> ?loc:Location.t -> ?node_id:int * int -> ?session:int
-> ?ltr:Errlog.loc_trace -> ?linters_def_file:string -> ?doc_url:string -> exn -> unit
@ -317,16 +337,17 @@ let process_execution_failures (log_issue: log_issue) pname =
let do_failure _ fs =
(* L.out "Node:%a node_ok:%d node_fail:%d@." Procdesc.Node.pp node fs.node_ok fs.node_fail; *)
match (fs.node_ok, fs.first_failure) with
| 0, Some (loc, key, _, loc_trace, exn) when not Config.debug_exceptions
-> let error = Exceptions.recognize_exception exn in
| 0, Some (loc, key, _, loc_trace, exn) when not Config.debug_exceptions ->
let error = Exceptions.recognize_exception exn in
let desc' = Localise.verbatim_desc ("exception: " ^ error.name.IssueType.unique_id) in
let exn' = Exceptions.Analysis_stops (desc', error.ml_loc) in
log_issue pname ~loc ~node_id:key ~ltr:loc_trace exn'
| _
-> ()
| _ ->
()
in
NodeHash.iter do_failure !gs.failure_map
let set_instr (instr: Sil.instr) = !gs.last_instr <- Some instr
let set_path path pos_opt = !gs.last_path <- Some (path, pos_opt)
@ -337,6 +358,7 @@ let set_node (node: Procdesc.Node.t) =
!gs.last_instr <- None ;
!gs.last_node <- node
let set_session (session: int) = !gs.last_session <- session
let get_const_map () = !gs.const_map

1000
infer/src/backend/symExec.ml
View File

File diff suppressed because it is too large Load Diff

703
infer/src/backend/tabulation.ml
View File

File diff suppressed because it is too large Load Diff

64
infer/src/backend/timeout.ml
Unescape View File

@ -26,48 +26,59 @@ module GlobalState = struct
let pop () =
match !stack with
| top_status :: l
-> stack := l ;
| top_status :: l ->
stack := l ;
Some top_status
| []
-> None
| [] ->
None
let push status = stack := status :: !stack
end
let set_alarm nsecs =
match Config.os_type with
| Config.Unix | Config.Cygwin
-> ignore
| Config.Unix | Config.Cygwin ->
ignore
(Unix.setitimer Unix.ITIMER_REAL
{ Unix.it_interval= 3.0
; (* try again after 3 seconds if the signal is lost *)
Unix.it_value= nsecs })
| Config.Win32
-> SymOp.set_wallclock_alarm nsecs
| Config.Win32 ->
SymOp.set_wallclock_alarm nsecs
let unset_alarm () =
match Config.os_type with
| Config.Unix | Config.Cygwin
-> set_alarm 0.0
| Config.Win32
-> SymOp.unset_wallclock_alarm ()
| Config.Unix | Config.Cygwin ->
set_alarm 0.0
| Config.Win32 ->
SymOp.unset_wallclock_alarm ()
let get_seconds_remaining () =
match Config.os_type with
| Config.Unix | Config.Cygwin
-> (Unix.getitimer Unix.ITIMER_REAL).Unix.it_value
| Config.Win32
-> SymOp.get_remaining_wallclock_time ()
| Config.Unix | Config.Cygwin ->
(Unix.getitimer Unix.ITIMER_REAL).Unix.it_value
| Config.Win32 ->
SymOp.get_remaining_wallclock_time ()
let get_current_status ~keep_symop_total =
let seconds_remaining = get_seconds_remaining () in
let symop_state = SymOp.save_state ~keep_symop_total in
{seconds_remaining; symop_state}
let set_status status = SymOp.restore_state status.symop_state ; set_alarm status.seconds_remaining
let timeout_action _ = unset_alarm () ; raise (SymOp.Analysis_failure_exe FKtimeout)
let set_status status =
SymOp.restore_state status.symop_state ;
set_alarm status.seconds_remaining
let timeout_action _ =
unset_alarm () ;
raise (SymOp.Analysis_failure_exe FKtimeout)
let () =
(* Can't use Core since it wraps signal handlers and alarms with catch-all exception handlers that
@ -75,24 +86,27 @@ let () =
let module Gc = Caml.Gc in
let module Sys = Caml.Sys in
match Config.os_type with
| Config.Unix | Config.Cygwin
-> Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action) ;
| Config.Unix | Config.Cygwin ->
Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action) ;
Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action)
| Config.Win32
-> SymOp.set_wallclock_timeout_handler timeout_action ;
| Config.Win32 ->
SymOp.set_wallclock_timeout_handler timeout_action ;
(* use the Gc alarm for periodic timeout checks *)
ignore (Gc.create_alarm SymOp.check_wallclock_alarm)
let unwind () = unset_alarm () ; SymOp.unset_alarm () ; GlobalState.pop ()
let suspend_existing_timeout ~keep_symop_total =
let current_status = get_current_status ~keep_symop_total in
unset_alarm () ; GlobalState.push current_status
let resume_previous_timeout () =
let status_opt = unwind () in
Option.iter ~f:set_status status_opt
let exe_timeout f x =
let suspend_existing_timeout_and_start_new_one () =
suspend_existing_timeout ~keep_symop_total:true ;
@ -101,9 +115,13 @@ let exe_timeout f x =
in
try
SymOp.try_finally
~f:(fun () -> suspend_existing_timeout_and_start_new_one () ; f x ; None)
~f:(fun () ->
suspend_existing_timeout_and_start_new_one () ;
f x ;
None)
~finally:resume_previous_timeout
with SymOp.Analysis_failure_exe kind ->
L.progressbar_timeout_event kind ;
Errdesc.warning_err (State.get_loc ()) "TIMEOUT: %a@." SymOp.pp_failure_kind kind ;
Some kind

12
infer/src/base/CommandDoc.ml
Unescape View File

@ -48,6 +48,7 @@ let mk_command_doc ~see_also:see_also_commands ?environment:environment_opt ?fil
~date:Version.man_pages_last_modify_date ~synopsis:[`Pre synopsis] ~environment ~files
~see_also
let analyze =
mk_command_doc ~title:"Infer Analysis" ~short_description:"analyze the files captured by infer"
~synopsis:{|$(b,infer) $(b,analyze) $(i,[options])
@ -55,6 +56,7 @@ $(b,infer) $(i,[options])|}
~description:[`P "Analyze the files captured in the project results directory and report."]
~see_also:CLOpt.([Report; Run])
let capture =
mk_command_doc ~title:"Infer Compilation Capture"
~short_description:"capture source files for later analysis"
@ -76,6 +78,7 @@ $(b,infer) $(b,capture) $(i,[--no-xcpretty]) $(i,[options]) $(b,--) $(b,xcodebui
]
~see_also:CLOpt.([Analyze; Compile; Run])
let compile =
mk_command_doc ~title:"Infer Project Compilation"
~short_description:"compile project from within the infer environment"
@ -103,6 +106,7 @@ let compile =
]
~see_also:CLOpt.([Capture])
let diff =
mk_command_doc ~title:"Infer Differential Analysis of a Project"
~short_description:"Report the difference between two versions of a project"
@ -110,6 +114,7 @@ let diff =
~description:[`P "EXPERIMENTAL AND IN NO WAY READY TO USE"]
~see_also:CLOpt.([ReportDiff; Run])
let explore =
mk_command_doc ~title:"Infer Explore"
~short_description:"explore the error traces in infer reports"
@ -120,6 +125,7 @@ let explore =
]
~see_also:CLOpt.([Report; Run])
let infer =
mk_command_doc ~title:"Infer Static Analyzer"
~short_description:"static analysis for Java and C/C++/Objective-C/Objective-C++"
@ -199,6 +205,7 @@ $(b,infer) $(i,[options])|}
}|}
] ~see_also:CLOpt.all_commands "infer"
let report =
mk_command_doc ~title:"Infer Reporting" ~short_description:"compute and manipulate infer results"
~synopsis:"$(b,infer) $(b,report) $(i,[options]) [$(i,file.specs)...]"
@ -210,6 +217,7 @@ let report =
]
~see_also:CLOpt.([ReportDiff; Run])
let reportdiff =
mk_command_doc ~title:"Infer Report Difference"
~short_description:"compute the differences between two infer reports"
@ -229,6 +237,7 @@ let reportdiff =
; `P "All three files follow the same format as normal infer reports." ]
~see_also:CLOpt.([Report])
let run =
mk_command_doc ~title:"Infer Analysis of a Project"
~short_description:"capture source files, analyze, and report"
@ -242,6 +251,7 @@ $(b,infer) $(i,[options]) $(b,--) $(i,compile command)|}
$(b,infer) $(b,analyze) $(i,[options])|} ]
~see_also:CLOpt.([Analyze; Capture; Report])
let command_to_data =
let mk cmd mk_doc =
let name = CLOpt.name_of_command cmd in
@ -258,5 +268,7 @@ let command_to_data =
; mk ReportDiff reportdiff
; mk Run run ]
let data_of_command command =
List.Assoc.find_exn ~equal:CLOpt.equal_command command_to_data command

336
infer/src/base/CommandLineOption.ml
Unescape View File

@ -24,11 +24,13 @@ let is_env_var_set v = Option.value (Option.map (Sys.getenv v) ~f:(( = ) "1")) ~
options are relative. *)
let init_work_dir, is_originator =
match Sys.getenv "INFER_CWD" with
| Some dir
-> (dir, false)
| None
-> let real_cwd = Utils.realpath (Sys.getcwd ()) in
Unix.putenv ~key:"INFER_CWD" ~data:real_cwd ; (real_cwd, true)
| Some dir ->
(dir, false)
| None ->
let real_cwd = Utils.realpath (Sys.getcwd ()) in
Unix.putenv ~key:"INFER_CWD" ~data:real_cwd ;
(real_cwd, true)
let strict_mode_env_var = "INFER_STRICT_MODE"
@ -39,6 +41,7 @@ let warnf =
else if not is_originator then fun fmt -> F.ifprintf F.err_formatter fmt
else F.eprintf
(** This is the subset of Arg.spec that we actually use. What's important is that all these specs
call back functions. We use this to mark deprecated arguments. What's not important is that, eg,
Arg.Float is missing. *)
@ -49,14 +52,15 @@ type spec =
| Rest of (string -> unit)
let to_arg_spec = function
| Unit f
-> Arg.Unit f
| String f
-> Arg.String f
| Symbol (symbols, f)
-> Arg.Symbol (symbols, f)
| Rest f
-> Arg.Rest f
| Unit f ->
Arg.Unit f
| String f ->
Arg.String f
| Symbol (symbols, f) ->
Arg.Symbol (symbols, f)
| Rest f ->
Arg.Rest f
let to_arg_spec_triple (x, spec, y) = (x, to_arg_spec spec, y)
@ -75,15 +79,16 @@ type anon_arg_action =
let anon_arg_action_of_parse_mode parse_mode =
let parse_subcommands, parse_argfiles, on_unknown =
match parse_mode with
| InferCommand
-> (true, true, `Reject)
| Javac
-> (false, true, `Skip)
| NoParse
-> (false, false, `Skip)
| InferCommand ->
(true, true, `Reject)
| Javac ->
(false, true, `Skip)
| NoParse ->
(false, false, `Skip)
in
{parse_subcommands; parse_argfiles; on_unknown}
(* NOTE: All variants must be also added to `all_commands` below *)
type command =
| Analyze
@ -110,6 +115,7 @@ let command_to_name =
; (ReportDiff, "reportdiff")
; (Run, "run") ]
let all_commands = List.map ~f:fst command_to_name
let name_of_command = List.Assoc.find_exn ~equal:equal_command command_to_name
@ -122,6 +128,7 @@ let command_of_exe_name exe_name =
List.find_map command_to_name ~f:(fun (cmd, name) ->
if String.equal exe_name (exe_name_of_command_name name) then Some cmd else None )
type command_doc =
{ title: Cmdliner.Manpage.title
; manual_before_options: Cmdliner.Manpage.block list
@ -140,54 +147,58 @@ type desc =
let dashdash ?short long =
match (long, short) with
| "", (None | Some "") | "--", _
-> long
| "", Some short
-> "-" ^ short
| _
-> "--" ^ long
| "", (None | Some "") | "--", _ ->
long
| "", Some short ->
"-" ^ short
| _ ->
"--" ^ long
let xdesc {long; short; spec} =
let key long short =
match (long, short) with
| "", ""
-> ""
| "--", _
-> "--"
| "", _
-> "-" ^ short
| _
-> "--" ^ long
| "", "" ->
""
| "--", _ ->
"--"
| "", _ ->
"-" ^ short
| _ ->
"--" ^ long
in
let xspec =
match spec with
(* translate Symbol to String for better formatting of --help messages *)
| Symbol (symbols, action)
-> String
| Symbol (symbols, action) ->
String
(fun arg ->
if List.mem ~equal:String.equal symbols arg then action arg
else
raise
(Arg.Bad
(F.sprintf "wrong argument '%s'; option '%s' expects one of: %s" arg
(dashdash ~short long) (String.concat ~sep:" | " symbols))))
| _
-> spec
(dashdash ~short long)
(String.concat ~sep:" | " symbols))))
| _ ->
spec
in
(* Arg doesn't need to know anything about documentation since we generate our own *)
(key long short, xspec, "")
let check_no_duplicates desc_list =
let rec check_for_duplicates_ = function
| [] | [_]
-> true
| (x, _, _) :: (y, _, _) :: _ when x <> "" && x = y
-> L.(die InternalError) "Multiple definitions of command line option: %s" x
| _ :: tl
-> check_for_duplicates_ tl
| [] | [_] ->
true
| (x, _, _) :: (y, _, _) :: _ when x <> "" && x = y ->
L.(die InternalError) "Multiple definitions of command line option: %s" x
| _ :: tl ->
check_for_duplicates_ tl
in
check_for_duplicates_ (List.sort ~cmp:(fun (x, _, _) (y, _, _) -> String.compare x y) desc_list)
let parse_mode_desc_lists = List.map ~f:(fun parse_mode -> (parse_mode, ref [])) all_parse_modes
module SectionMap = Caml.Map.Make (struct
@ -205,11 +216,13 @@ module SectionMap = Caml.Map.Make (struct
-1
else (* reverse order *)
String.compare s2 s1
end)
let help_sections_desc_lists =
List.map all_commands ~f:(fun command -> (command, ref SectionMap.empty))
let visible_descs_list = ref []
let hidden_descs_list = ref []
@ -236,16 +249,16 @@ let add parse_mode sections desc =
let oxford_comma l =
let rec aux acc l =
match (l, acc) with
| [], _
-> assert false
| [x], []
-> x
| [x; y], []
-> Printf.sprintf "%s and %s" x y
| [x; y], acc
-> Printf.sprintf "%s, %s, and %s" (String.concat ~sep:", " (List.rev acc)) x y
| x :: tl, acc
-> aux (x :: acc) tl
| [], _ ->
assert false
| [x], [] ->
x
| [x; y], [] ->
Printf.sprintf "%s and %s" x y
| [x; y], acc ->
Printf.sprintf "%s, %s, and %s" (String.concat ~sep:", " (List.rev acc)) x y
| x :: tl, acc ->
aux (x :: acc) tl
in
aux [] l
in
@ -263,26 +276,27 @@ let add parse_mode sections desc =
visible_descs_list := desc_infer :: !visible_descs_list ;
()
let deprecate_desc parse_mode ~long ~short ~deprecated desc =
let warn () =
match parse_mode with
| Javac | NoParse
-> ()
| InferCommand
-> warnf "WARNING: '-%s' is deprecated. Use '--%s'%s instead.@." deprecated long
| Javac | NoParse ->
()
| InferCommand ->
warnf "WARNING: '-%s' is deprecated. Use '--%s'%s instead.@." deprecated long
(if short = "" then "" else Printf.sprintf " or '-%s'" short)
in
let warn_then_f f x = warn () ; f x in
let deprecated_spec =
match desc.spec with
| Unit f
-> Unit (warn_then_f f)
| String f
-> String (warn_then_f f)
| Symbol (symbols, f)
-> Symbol (symbols, warn_then_f f)
| Rest _ as spec
-> spec
| Unit f ->
Unit (warn_then_f f)
| String f ->
String (warn_then_f f)
| Symbol (symbols, f) ->
Symbol (symbols, warn_then_f f)
| Rest _ as spec ->
spec
in
let deprecated_decode_json ~inferconfig_dir j =
warnf "WARNING: in .inferconfig: '%s' is deprecated. Use '%s' instead." deprecated long ;
@ -295,6 +309,7 @@ let deprecate_desc parse_mode ~long ~short ~deprecated desc =
; spec= deprecated_spec
; decode_json= deprecated_decode_json }
let mk ?(deprecated= []) ?(parse_mode= InferCommand) ?(in_help= []) ~long ?short:short0 ~default
~meta doc ~default_to_string ~decode_json ~mk_setter ~mk_spec =
let variable = ref default in
@ -323,6 +338,7 @@ let mk ?(deprecated= []) ?(parse_mode= InferCommand) ?(in_help= []) ~long ?short
deprecate_desc parse_mode ~long ~short ~deprecated desc |> add parse_mode [] ) ;
variable
(* begin parsing state *)
(* arguments passed to Arg.parse_argv_dynamic, susceptible to be modified on the fly when parsing *)
let args_to_parse : string array ref = ref (Array.of_list [])
@ -359,9 +375,11 @@ let path_json_decoder ~long ~inferconfig_dir json =
in
[dashdash long; abs_path]
let list_json_decoder json_decoder ~inferconfig_dir json =
List.concat (YBU.convert_each (json_decoder ~inferconfig_dir) json)
let mk_set var value ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "") doc =
let setter () = var := value in
ignore
@ -369,6 +387,7 @@ let mk_set var value ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta=
~default_to_string:(fun () -> "") ~decode_json:(string_json_decoder ~long)
~mk_setter:(fun _ _ -> setter ()) ~mk_spec:(fun _ -> Unit setter ))
let mk_with_reset value ~reset_doc ?deprecated ~long ?parse_mode mk =
let var = mk () in
if not (String.equal "" long) then
@ -377,6 +396,7 @@ let mk_with_reset value ~reset_doc ?deprecated ~long ?parse_mode mk =
mk_set var value ?deprecated ~long:(long ^ "-reset") ?parse_mode reset_doc ;
var
let reset_doc_opt ~long = Printf.sprintf "Cancel the effect of $(b,%s)." (dashdash long)
let reset_doc_list ~long = Printf.sprintf "Set $(b,%s) to the empty list." (dashdash long)
@ -393,6 +413,7 @@ let mk_option ?(default= None) ?(default_to_string= fun _ -> "") ~f ?(mk_reset=
mk_with_reset None ~reset_doc ~long ?parse_mode mk
else mk ()
let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated= []) ~long ?short
?parse_mode ?in_help ?(meta= "") doc0 =
let nolong =
@ -407,10 +428,10 @@ let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated
in
let doc long short =
match short with
| Some short
-> doc0 ^ " (Conversely: $(b,--" ^ long ^ ") | $(b,-" ^ String.of_char short ^ "))"
| None
-> doc0 ^ " (Conversely: $(b,--" ^ long ^ "))"
| Some short ->
doc0 ^ " (Conversely: $(b,--" ^ long ^ ") | $(b,-" ^ String.of_char short ^ "))"
| None ->
doc0 ^ " (Conversely: $(b,--" ^ long ^ "))"
in
let doc, nodoc =
if String.equal doc0 "" then ("", "")
@ -435,6 +456,7 @@ let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated
~mk_spec) ;
var
let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(deprecated= []) ~long
?short ?parse_mode ?in_help ?meta doc children no_children =
let f b =
@ -444,34 +466,40 @@ let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(depre
in
mk_bool ~deprecated ~deprecated_no ~default ~long ?short ~f ?parse_mode ?in_help ?meta doc
let mk_int ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "int")
doc =
mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc
~default_to_string:string_of_int ~mk_setter:(fun var str -> var := f (int_of_string str))
~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set )
let mk_int_opt ?default ?f:(f0 = Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help
?(meta= "int") doc =
let default_to_string = function Some f -> string_of_int f | None -> "" in
let f s = Some (f0 (int_of_string s)) in
mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc
let mk_float ~default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "float") doc =
mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc
~default_to_string:string_of_float ~mk_setter:(fun var str -> var := float_of_string str)
~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set )
let mk_float_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "float") doc =
let default_to_string = function Some f -> string_of_float f | None -> "" in
let f s = Some (float_of_string s) in
mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc
let mk_string ~default ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode ?in_help
?(meta= "string") doc =
mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc
~default_to_string:(fun s -> s) ~mk_setter:(fun var str -> var := f str)
~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set )
let mk_string_opt ?default ?(f= fun s -> s) ?mk_reset ?(deprecated= []) ~long ?short ?parse_mode
?in_help ?(meta= "string") doc =
let default_to_string = function Some s -> s | None -> "" in
@ -479,6 +507,7 @@ let mk_string_opt ?default ?(f= fun s -> s) ?mk_reset ?(deprecated= []) ~long ?s
mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?mk_reset ?parse_mode ?in_help
~meta doc
let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode
?in_help ?(meta= "string") doc =
let mk () =
@ -490,6 +519,7 @@ let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?shor
let reset_doc = reset_doc_list ~long in
mk_with_reset [] ~reset_doc ~long ?parse_mode mk
let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str =
if Filename.is_relative str then
(* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes
@ -502,6 +532,7 @@ let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str =
abs_path
else str
let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short ~parse_mode
~in_help ~meta ~decode_json doc =
mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~decode_json
@ -510,6 +541,7 @@ let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short
let abs_path = normalize_path_in_args_being_parsed ~is_anon_arg:false str in
setter var abs_path) ~mk_spec:(fun set -> String set )
let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help
?(meta= "path") =
mk_path_helper
@ -518,6 +550,7 @@ let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_
~default_to_string:(fun s -> s)
~default ~deprecated ~long ~short ~parse_mode ~in_help ~meta
let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") doc =
let mk () =
mk_path_helper
@ -529,6 +562,7 @@ let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(m
let reset_doc = reset_doc_opt ~long in
mk_with_reset None ~reset_doc ~long ?parse_mode mk
let mk_path_list ?(default= []) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path")
doc =
let mk () =
@ -541,10 +575,12 @@ let mk_path_list ?(default= []) ?(deprecated= []) ~long ?short ?parse_mode ?in_h
let reset_doc = reset_doc_list ~long in
mk_with_reset [] ~reset_doc ~long ?parse_mode mk
let mk_symbols_meta symbols =
let strings = List.map ~f:fst symbols in
Printf.sprintf "{ %s }" (String.concat ~sep:" | " strings)
let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help
?meta doc =
let strings = List.map ~f:fst symbols in
@ -556,6 +592,7 @@ let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ?
~default_to_string:(fun s -> to_string s) ~mk_setter:(fun var str -> var := of_string str |> f)
~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Symbol (strings, set) )
let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long ?short ?parse_mode
?in_help ?meta doc =
let strings = List.map ~f:fst symbols in
@ -571,6 +608,7 @@ let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long
mk_with_reset None ~reset_doc ~long ?parse_mode mk
else mk ()
let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?parse_mode ?in_help
?meta doc =
let sym_to_str = List.map ~f:(fun (x, y) -> (y, x)) symbols in
@ -584,6 +622,7 @@ let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?pa
[dashdash long; String.concat ~sep:"," (YBU.convert_each YBU.to_string json)]) ~mk_spec:
(fun set -> String set )
let mk_set_from_json ~default ~default_to_string ~f ?(deprecated= []) ~long ?short ?parse_mode
?in_help ?(meta= "json") doc =
mk ~deprecated ~long ?short ?parse_mode ?in_help ~meta doc ~default ~default_to_string
@ -591,6 +630,7 @@ let mk_set_from_json ~default ~default_to_string ~f ?(deprecated= []) ~long ?sho
~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json])
~mk_spec:(fun set -> String set )
let mk_json ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json") doc =
mk ~deprecated ~long ?short ?parse_mode ?in_help ~meta doc ~default:(`List [])
~default_to_string:Yojson.Basic.to_string
@ -598,6 +638,7 @@ let mk_json ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json")
~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json])
~mk_spec:(fun set -> String set )
(** [mk_anon] always return the same ref. Anonymous arguments are only accepted if
[parse_action_accept_unknown_args] is true. *)
let mk_anon () = rev_anon_args
@ -609,6 +650,7 @@ let mk_rest ?(parse_mode= InferCommand) ?(in_help= []) doc =
{long= "--"; short= ""; meta= ""; doc; spec; decode_json= (fun ~inferconfig_dir:_ _ -> [])} ;
rest
let normalize_desc_list speclist =
let norm k =
let remove_no s =
@ -623,19 +665,20 @@ let normalize_desc_list speclist =
in
let compare_specs {long= x} {long= y} =
match (x, y) with
| "--", "--"
-> 0
| "--", _
-> 1
| _, "--"
-> -1
| _
-> let lower_norm s = String.lowercase @@ norm s in
| "--", "--" ->
0
| "--", _ ->
1
| _, "--" ->
-1
| _ ->
let lower_norm s = String.lowercase @@ norm s in
String.compare (lower_norm x) (lower_norm y)
in
let sort speclist = List.sort ~cmp:compare_specs speclist in
sort speclist
let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~description
?options ?exit_status ?environment ?files ?notes ?bugs ?examples ~see_also command_str =
let add_if section blocks =
@ -644,7 +687,7 @@ let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~
let manual_before_options =
[ `S Cmdliner.Manpage.s_name
; (* the format of the following line is mandated by man(7) *)
`Pre (Printf.sprintf "%s - %s" command_str short_description)
`Pre (Printf.sprintf "%s - %s" command_str short_description)
; `S Cmdliner.Manpage.s_synopsis
; `Blocks synopsis
; `S Cmdliner.Manpage.s_description
@ -669,6 +712,7 @@ let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~
in
command_doc
let set_curr_speclist_for_parse_mode ~usage parse_mode =
let curr_usage status =
prerr_endline (String.concat_array ~sep:" " !args_to_parse) ;
@ -694,15 +738,18 @@ let set_curr_speclist_for_parse_mode ~usage parse_mode =
assert (check_no_duplicates !curr_speclist) ;
curr_usage
let select_parse_mode ~usage parse_mode =
let print_usage = set_curr_speclist_for_parse_mode ~usage parse_mode in
anon_arg_action := anon_arg_action_of_parse_mode parse_mode ;
print_usage
let string_of_command command =
let _, s, _ = List.Assoc.find_exn !subcommands ~equal:equal_command command in
s
let mk_rest_actions ?(parse_mode= InferCommand) ?(in_help= []) doc ~usage decode_action =
let rest = ref [] in
let spec =
@ -715,6 +762,7 @@ let mk_rest_actions ?(parse_mode= InferCommand) ?(in_help= []) doc ~usage decode
{long= "--"; short= ""; meta= ""; doc; spec; decode_json= (fun ~inferconfig_dir:_ _ -> [])} ;
rest
let mk_subcommand command ?on_unknown_arg:(on_unknown = `Reject) ~name ?deprecated_long ?parse_mode
?in_help command_doc =
let switch () =
@ -722,19 +770,20 @@ let mk_subcommand command ?on_unknown_arg:(on_unknown = `Reject) ~name ?deprecat
anon_arg_action := {(!anon_arg_action) with on_unknown}
in
( match deprecated_long with
| Some long
-> ignore
| Some long ->
ignore
(mk ~long ~default:() ?parse_mode ?in_help ~meta:"" "" ~default_to_string:(fun () -> "")
~decode_json:(fun ~inferconfig_dir:_ _ ->
raise (Arg.Bad ("Bad option in config file: " ^ long)))
~mk_setter:(fun _ _ ->
warnf "WARNING: '%s' is deprecated. Please use '%s' instead.@\n" (dashdash long) name ;
switch ()) ~mk_spec:(fun set -> Unit (fun () -> set "") ))
| None
-> () ) ;
| None ->
() ) ;
subcommands := (command, (command_doc, name, in_help)) :: !subcommands ;
subcommand_actions := (name, switch) :: !subcommand_actions
(* drop well-balanced first and last characters in [s] that satisfy the [drop] predicate; for
instance, [lrstrip ~drop:(function | 'a' | 'x' -> true | _ -> false) "xaabax"] returns "ab" *)
let rec lrstrip ~drop s =
@ -746,17 +795,19 @@ let rec lrstrip ~drop s =
lrstrip ~drop (String.slice s 1 (n - 1))
else s
let args_from_argfile arg =
let abs_fname =
let fname = String.slice arg 1 (String.length arg) in
normalize_path_in_args_being_parsed ~f:(fun s -> "@" ^ s) ~is_anon_arg:true fname
in
match In_channel.read_lines abs_fname with
| lines
-> let strip = lrstrip ~drop:(function '"' | '\'' -> true | _ -> false) in
| lines ->
let strip = lrstrip ~drop:(function '"' | '\'' -> true | _ -> false) in
List.map ~f:strip lines
| exception e
-> raise (Arg.Bad ("Error reading argument file '" ^ abs_fname ^ "': " ^ Exn.to_string e))
| exception e ->
raise (Arg.Bad ("Error reading argument file '" ^ abs_fname ^ "': " ^ Exn.to_string e))
exception SubArguments of string list
@ -769,29 +820,31 @@ let anon_fun arg =
then
let command_switch = List.Assoc.find_exn !subcommand_actions ~equal:String.equal arg in
match (!curr_command, is_originator) with
| None, _ | Some _, false
-> command_switch ()
| Some command, true
-> raise
| None, _ | Some _, false ->
command_switch ()
| Some command, true ->
raise
(Arg.Bad
(Printf.sprintf "More than one subcommand specified: '%s', '%s'"
(string_of_command command) arg))
else
match !anon_arg_action.on_unknown with
| `Add
-> rev_anon_args := arg :: !rev_anon_args
| `Skip
-> ()
| `Reject
-> raise (Arg.Bad (Printf.sprintf "Unexpected anonymous argument: '%s'" arg))
| `Add ->
rev_anon_args := arg :: !rev_anon_args
| `Skip ->
()
| `Reject ->
raise (Arg.Bad (Printf.sprintf "Unexpected anonymous argument: '%s'" arg))
let decode_inferconfig_to_argv path =
let json =
match Utils.read_json_file path with
| Ok json
-> json
| Error msg
-> warnf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ; `Assoc []
| Ok json ->
json
| Error msg ->
warnf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ;
`Assoc []
in
let desc_list = List.Assoc.find_exn ~equal:equal_parse_mode parse_mode_desc_lists InferCommand in
let json_config = YBU.to_assoc json in
@ -808,15 +861,17 @@ let decode_inferconfig_to_argv path =
in
decode_json ~inferconfig_dir json_val @ result
with
| Not_found
-> warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ; result
| YBU.Type_error (msg, json)
-> warnf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@."
| Not_found ->
warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ;
result
| YBU.Type_error (msg, json) ->
warnf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@."
path (Yojson.Basic.to_string json) key msg ;
result
in
List.fold ~f:one_config_item ~init:[] json_config
(** separator of argv elements when encoded into environment variables *)
let env_var_sep = '^'
@ -831,19 +886,22 @@ let encode_argv_to_env argv =
false))
argv)
let decode_env_to_argv env =
String.split ~on:env_var_sep env |> List.filter ~f:(Fn.non String.is_empty)
(** [prefix_before_rest (prefix @ ["--" :: rest])] is [prefix] where "--" is not in [prefix]. *)
let rev_prefix_before_rest args =
let rec rev_prefix_before_rest_ rev_keep = function
| [] | "--" :: _
-> rev_keep
| keep :: args
-> rev_prefix_before_rest_ (keep :: rev_keep) args
| [] | "--" :: _ ->
rev_keep
| keep :: args ->
rev_prefix_before_rest_ (keep :: rev_keep) args
in
rev_prefix_before_rest_ [] args
(** environment variable use to pass arguments from parent to child processes *)
let args_env_var = "INFER_ARGS"
@ -867,8 +925,8 @@ let parse_args ~usage initial_action ?initial_command args =
try
Arg.parse_argv_dynamic ~current:arg_being_parsed !args_to_parse curr_speclist anon_fun usage
with
| SubArguments args
-> (* stop parsing the current arguments and parse [args] for a while *)
| SubArguments args ->
(* stop parsing the current arguments and parse [args] for a while *)
let saved_args = !args_to_parse in
let saved_current = !arg_being_parsed in
args_to_parse := Array.of_list (exe_name :: args) ;
@ -878,18 +936,19 @@ let parse_args ~usage initial_action ?initial_command args =
args_to_parse := saved_args ;
arg_being_parsed := saved_current ;
parse_loop ()
| Arg.Bad usage_msg
-> if !anon_arg_action.on_unknown <> `Reject && is_unknown usage_msg then (
| Arg.Bad usage_msg ->
if !anon_arg_action.on_unknown <> `Reject && is_unknown usage_msg then (
anon_fun !args_to_parse.(!arg_being_parsed) ;
parse_loop () )
else Pervasives.(prerr_string usage_msg ; exit 1)
| Arg.Help _
-> (* we handle --help by ourselves and error on -help, so Arg has no way to raise Help
| Arg.Help _ ->
(* we handle --help by ourselves and error on -help, so Arg has no way to raise Help
anymore *)
assert false
in
parse_loop () ; curr_usage
let parse ?config_file ~usage action initial_command =
let env_args = decode_env_to_argv (Option.value (Sys.getenv args_env_var) ~default:"") in
let inferconfig_args =
@ -921,7 +980,8 @@ let parse ?config_file ~usage action initial_command =
let curr_usage =
let cl_args = match Array.to_list Sys.argv with _ :: tl -> tl | [] -> [] in
let curr_usage = parse_args ~usage action ?initial_command cl_args in
add_parsed_args_to_args_to_export () ; curr_usage
add_parsed_args_to_args_to_export () ;
curr_usage
in
let to_export =
let argv_to_export = decode_env_to_argv !args_to_export in
@ -935,7 +995,9 @@ let parse ?config_file ~usage action initial_command =
"@" ^ file
else ""
in
Unix.putenv ~key:args_env_var ~data:to_export ; (!curr_command, curr_usage)
Unix.putenv ~key:args_env_var ~data:to_export ;
(!curr_command, curr_usage)
let wrap_line indent_string wrap_length line0 =
let line = indent_string ^ line0 in
@ -965,17 +1027,18 @@ let wrap_line indent_string wrap_length line0 =
let rev_lines, _, line, _ = List.fold ~f:add_word_to_paragraph ~init:([], false, "", 0) words in
List.rev (line :: rev_lines)
let show_manual ?internal_section format default_doc command_opt =
let command_doc =
match command_opt with
| None
-> default_doc
| None ->
default_doc
| Some command ->
match List.Assoc.find_exn ~equal:equal_command !subcommands command with
| Some command_doc, _, _
-> command_doc
| None, _, _
-> L.(die InternalError) "No manual for internal command %s" (string_of_command command)
| Some command_doc, _, _ ->
command_doc
| None, _, _ ->
L.(die InternalError) "No manual for internal command %s" (string_of_command command)
in
let pp_meta f meta =
match meta with "" -> () | meta -> F.fprintf f " $(i,%s)" (Cmdliner.Manpage.escape meta)
@ -1001,21 +1064,21 @@ let show_manual ?internal_section format default_doc command_opt =
in
let option_blocks =
match command_doc.manual_options with
| `Replace blocks
-> `S Cmdliner.Manpage.s_options :: blocks
| `Prepend blocks
-> let hidden =
| `Replace blocks ->
`S Cmdliner.Manpage.s_options :: blocks
| `Prepend blocks ->
let hidden =
match internal_section with
| Some section
-> `S section
| Some section ->
`S section
:: `P "Use at your own risk."
:: List.concat_map ~f:block_of_desc (normalize_desc_list !hidden_descs_list)
| None
-> []
:: List.concat_map ~f:block_of_desc (normalize_desc_list !hidden_descs_list)
| None ->
[]
in
match command_opt with
| Some command
-> let sections =
| Some command ->
let sections =
List.Assoc.find_exn ~equal:equal_command help_sections_desc_lists command
in
SectionMap.fold
@ -1024,8 +1087,8 @@ let show_manual ?internal_section format default_doc command_opt =
:: (if String.equal section Cmdliner.Manpage.s_options then blocks else [])
@ List.concat_map ~f:block_of_desc (normalize_desc_list descs) @ result)
!sections hidden
| None
-> `S Cmdliner.Manpage.s_options :: blocks
| None ->
`S Cmdliner.Manpage.s_options :: blocks
@ List.concat_map ~f:block_of_desc (normalize_desc_list !visible_descs_list) @ hidden
in
let blocks =
@ -1035,3 +1098,4 @@ let show_manual ?internal_section format default_doc command_opt =
in
Cmdliner.Manpage.print format Format.std_formatter (command_doc.title, blocks) ;
()

484
infer/src/base/Config.ml
View File

File diff suppressed because it is too large Load Diff

89
infer/src/base/DB.ml
Unescape View File

@ -30,6 +30,7 @@ let append_crc_cutoff ?(key= "") ?(crc_only= false) name =
in
if crc_only then crc_str else Printf.sprintf "%s%c%s" name_up_to_cutoff crc_token crc_str
(* Lengh of .crc part: 32 characters of digest, plus 1 character of crc_token *)
let dot_crc_len = 1 + 32
@ -38,10 +39,11 @@ let strip_crc str = String.slice str 0 (-dot_crc_len)
let string_crc_has_extension ~ext name_crc =
let name = strip_crc name_crc in
match Filename.split_extension name with
| _, Some ext'
-> String.equal ext ext'
| _, None
-> false
| _, Some ext' ->
String.equal ext ext'
| _, None ->
false
let curr_source_file_encoding = `Enc_crc
@ -49,15 +51,16 @@ let curr_source_file_encoding = `Enc_crc
let source_file_encoding source_file =
let source_file_s = SourceFile.to_string source_file in
match curr_source_file_encoding with
| `Enc_base
-> Filename.basename source_file_s
| `Enc_path_with_underscores
-> Escape.escape_path source_file_s
| `Enc_crc
-> let base = Filename.basename source_file_s in
| `Enc_base ->
Filename.basename source_file_s
| `Enc_path_with_underscores ->
Escape.escape_path source_file_s
| `Enc_crc ->
let base = Filename.basename source_file_s in
let dir = Filename.dirname source_file_s in
append_crc_cutoff ~key:dir base
(** {2 Source Dirs} *)
(** source directory: the directory inside the results dir corresponding to a source file *)
@ -74,10 +77,12 @@ let source_dir_get_internal_file source_dir extension =
let fname = source_dir_name ^ extension in
Filename.concat source_dir fname
(** get the source directory corresponding to a source file *)
let source_dir_from_source_file source_file =
Filename.concat Config.captured_dir (source_file_encoding source_file)
(** Find the source directories in the results dir *)
let find_source_dirs () =
let source_dirs = ref [] in
@ -97,6 +102,7 @@ let find_source_dirs () =
files_in_results_dir ;
List.rev !source_dirs
(** {2 Filename} *)
type filename = string [@@deriving compare]
@ -132,10 +138,12 @@ let file_modified_time ?(symlink= false) fname =
stat.Unix.st_mtime
with Unix.Unix_error _ -> L.(die InternalError) "File %s does not exist." fname
let filename_create_dir fname =
let dirname = Filename.dirname fname in
if Sys.file_exists dirname <> `Yes then Utils.create_dir dirname
let read_whole_file fd = In_channel.input_all (Unix.in_channel_of_descr fd)
(** Update the file contents with the update function provided.
@ -158,11 +166,13 @@ let update_file_with_lock dir fname update =
let str = update buf in
let i = Unix.write fd ~buf:str ~pos:0 ~len:(String.length str) in
if Int.equal i (String.length str) then (
Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; Unix.close fd )
Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ;
Unix.close fd )
else (
L.internal_error "@\nsave_with_lock: fail on path: %s@." path ;
assert false )
(** Read a file using a lock to allow write attempts in parallel. *)
let read_file_with_lock dir fname =
let path = Filename.concat dir fname in
@ -171,10 +181,13 @@ let read_file_with_lock dir fname =
try
Unix.lockf fd ~mode:Unix.F_RLOCK ~len:0L ;
let buf = read_whole_file fd in
Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; Unix.close fd ; Some buf
Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ;
Unix.close fd ;
Some buf
with Unix.Unix_error _ -> L.(die ExternalError) "read_file_with_lock: Unix error"
with Unix.Unix_error _ -> None
(** {2 Results Directory} *)
module Results_dir = struct
@ -190,28 +203,30 @@ module Results_dir = struct
let filename_from_base base path =
let rec f = function
| []
-> base
| name :: names
-> Filename.concat (f names)
| [] ->
base
| name :: names ->
Filename.concat (f names)
(if String.equal name ".." then Filename.parent_dir_name else name)
in
f (List.rev path)
(** convert a path to a filename *)
let path_to_filename pk path =
let base =
match pk with
| Abs_root
-> Config.results_dir
| Abs_source_dir source
-> let dir = source_dir_from_source_file source in
| Abs_root ->
Config.results_dir
| Abs_source_dir source ->
let dir = source_dir_from_source_file source in
source_dir_to_string dir
| Rel
-> Filename.current_dir_name
| Rel ->
Filename.current_dir_name
in
filename_from_base base path
(** directory of spec files *)
let specs_dir = path_to_filename Abs_root [Config.specs_dir_name]
@ -223,44 +238,49 @@ module Results_dir = struct
Utils.create_dir (path_to_filename Abs_root [Config.captured_dir_name]) ;
Utils.create_dir (path_to_filename (Abs_source_dir source) [])
let clean_specs_dir () =
Utils.create_dir specs_dir ;
(* create dir just in case it doesn't exist to avoid errors *)
let files_to_remove = Array.map ~f:(Filename.concat specs_dir) (Sys.readdir specs_dir) in
Array.iter ~f:Sys.remove files_to_remove
(** create a file at the given path, creating any missing directories *)
let create_file pk path =
let rec create = function
| []
-> let fname = path_to_filename pk [] in
| [] ->
let fname = path_to_filename pk [] in
Utils.create_dir fname ; fname
| name :: names
-> let new_path = Filename.concat (create names) name in
| name :: names ->
let new_path = Filename.concat (create names) name in
Utils.create_dir new_path ; new_path
in
let filename, dir_path =
match List.rev path with
| filename :: dir_path
-> (filename, dir_path)
| []
-> L.(die InternalError) "create_path"
| filename :: dir_path ->
(filename, dir_path)
| [] ->
L.(die InternalError) "create_path"
in
let full_fname = Filename.concat (create dir_path) filename in
Unix.openfile full_fname ~mode:Unix.([O_WRONLY; O_CREAT; O_TRUNC]) ~perm:0o777
end
let global_tenv_fname =
let basename = Config.global_tenv_filename in
filename_concat Config.captured_dir basename
let is_source_file path =
List.exists ~f:(fun ext -> Filename.check_suffix path ext) Config.source_file_extentions
let infer_start_time =
( lazy
(file_modified_time (Results_dir.path_to_filename Results_dir.Abs_root [Config.start_filename]))
)
lazy
(file_modified_time (Results_dir.path_to_filename Results_dir.Abs_root [Config.start_filename]))
(** Return whether filename was updated after analysis started. File doesn't have to exist *)
let file_was_updated_after_start fname =
@ -270,12 +290,14 @@ let file_was_updated_after_start fname =
else (* since file doesn't exist, it wasn't modified *)
false
(** Mark a file as updated by changing its timestamps to be one second in the future.
This guarantees that it appears updated after start. *)
let mark_file_updated fname =
let near_future = Unix.gettimeofday () +. 1. in
Unix.utimes fname ~access:near_future ~modif:near_future
(** Fold over all file paths recursively under [dir] which match [p]. *)
let fold_paths_matching ~dir ~p ~init ~f =
let rec paths path_list dir =
@ -287,6 +309,7 @@ let fold_paths_matching ~dir ~p ~init ~f =
in
paths init dir
(** Return all absolute paths recursively under root_dir, matching the given
matcher function p *)
let paths_matching dir p = fold_paths_matching ~dir ~p ~init:[] ~f:(fun x xs -> x :: xs)

34
infer/src/base/Die.ml
Unescape View File

@ -21,25 +21,27 @@ exception InferExit of int
let raise_error error ~msg =
match error with
| ExternalError
-> raise (InferExternalError msg)
| InternalError
-> raise (InferInternalError msg)
| UserError
-> raise (InferUserError msg)
| ExternalError ->
raise (InferExternalError msg)
| InternalError ->
raise (InferInternalError msg)
| UserError ->
raise (InferUserError msg)
let die error fmt = F.kasprintf (fun msg -> raise_error error ~msg) fmt
let exit exitcode = raise (InferExit exitcode)
let exit_code_of_exception = function
| InferUserError _
-> 1
| InferExternalError _
-> 3
| InferInternalError _
-> 4
| InferExit exitcode
-> exitcode
| _
-> (* exit code 2 is used by the OCaml runtime in cases of uncaught exceptions *) 2
| InferUserError _ ->
1
| InferExternalError _ ->
3
| InferInternalError _ ->
4
| InferExit exitcode ->
exitcode
| _ ->
(* exit code 2 is used by the OCaml runtime in cases of uncaught exceptions *) 2

5
infer/src/base/Die.mli
Unescape View File

@ -17,9 +17,8 @@ exception InferInternalError of string
exception InferUserError of string
exception
InferExit of
int(** This can be used to avoid scattering exit invocations all over the codebase *)
exception InferExit of int
(** This can be used to avoid scattering exit invocations all over the codebase *)
(** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *)
type error = ExternalError | InternalError | UserError

19
infer/src/base/Epilogues.ml
Unescape View File

@ -12,14 +12,16 @@ module F = Format
(* Run the epilogues when we get SIGINT (Control-C). We do not want to mask SIGINT unless at least
one epilogue has been registered, so make this value lazy. *)
let activate_run_epilogues_on_signal =
( lazy
(let run_epilogues_on_signal s =
F.eprintf "*** %s: Caught %s, time to die@." (Filename.basename Sys.executable_name)
(Signal.to_string s) ;
(* Epilogues are registered with [at_exit] so exiting will make them run. *)
Pervasives.exit 0
in
Signal.Expert.handle Signal.int run_epilogues_on_signal) )
lazy
(let run_epilogues_on_signal s =
F.eprintf "*** %s: Caught %s, time to die@."
(Filename.basename Sys.executable_name)
(Signal.to_string s) ;
(* Epilogues are registered with [at_exit] so exiting will make them run. *)
Pervasives.exit 0
in
Signal.Expert.handle Signal.int run_epilogues_on_signal)
let register ~f desc =
let f_no_exn () =
@ -33,3 +35,4 @@ let register ~f desc =
Pervasives.at_exit f_no_exn ;
(* Register signal masking. *)
Lazy.force activate_run_epilogues_on_signal

135
infer/src/base/Escape.ml
Unescape View File

@ -26,99 +26,106 @@ let escape_map map_fun s =
else (* not escaping anything, so don't waste memory on a copy of the string *)
s
let escape_csv s =
let map = function
| '"'
-> Some "\"\""
| c when Char.to_int c > 127
-> Some "?" (* non-ascii character: escape *)
| _
-> None
| '"' ->
Some "\"\""
| c when Char.to_int c > 127 ->
Some "?" (* non-ascii character: escape *)
| _ ->
None
in
escape_map map s
let escape_xml s =
let map = function
| '"'
-> (* on next line to avoid bad indentation *)
| '"' ->
(* on next line to avoid bad indentation *)
Some "&quot;"
| '>'
-> Some "&gt;"
| '<'
-> Some "&lt;"
| '&'
-> Some "&amp;"
| '%'
-> Some "&#37;"
| c when Char.to_int c > 127
-> (* non-ascii character: escape *)
| '>' ->
Some "&gt;"
| '<' ->
Some "&lt;"
| '&' ->
Some "&amp;"
| '%' ->
Some "&#37;"
| c when Char.to_int c > 127 ->
(* non-ascii character: escape *)
Some ("&#" ^ string_of_int (Char.to_int c) ^ ";")
| _
-> None
| _ ->
None
in
escape_map map s
let escape_url s =
let map = function
| '!'
-> Some "%21"
| '#'
-> Some "%23"
| '$'
-> Some "%24"
| '&'
-> Some "%26"
| '\''
-> Some "%27"
| '('
-> Some "%28"
| ')'
-> Some "%29"
| '*'
-> Some "%2A"
| '+'
-> Some "%2B"
| ','
-> Some "%2C"
| '/'
-> Some "%2F"
| ':'
-> Some "%3A"
| ';'
-> Some "%3B"
| '='
-> Some "%3D"
| '?'
-> Some "%3F"
| '@'
-> Some "%40"
| '['
-> Some "%5B"
| ']'
-> Some "%5D"
| _
-> None
| '!' ->
Some "%21"
| '#' ->
Some "%23"
| '$' ->
Some "%24"
| '&' ->
Some "%26"
| '\'' ->
Some "%27"
| '(' ->
Some "%28"
| ')' ->
Some "%29"
| '*' ->
Some "%2A"
| '+' ->
Some "%2B"
| ',' ->
Some "%2C"
| '/' ->
Some "%2F"
| ':' ->
Some "%3A"
| ';' ->
Some "%3B"
| '=' ->
Some "%3D"
| '?' ->
Some "%3F"
| '@' ->
Some "%40"
| '[' ->
Some "%5B"
| ']' ->
Some "%5D"
| _ ->
None
in
escape_map map s
let escape_dotty s =
let map = function '"' -> Some "\\\"" | '\\' -> Some "\\\\" | _ -> None in
escape_map map s
let escape_path s =
let map = function
| c
-> if String.equal (Char.escaped c) Filename.dir_sep then Some "_" else None
| c ->
if String.equal (Char.escaped c) Filename.dir_sep then Some "_" else None
in
escape_map map s
(* Python 2 sucks at utf8 so do not write unicode file names to disk
as Python may need to see them *)
let escape_filename s =
let map = function
| c when Char.to_int c > 127
-> Some "?" (* non-ascii character: escape *)
| _
-> None
| c when Char.to_int c > 127 ->
Some "?" (* non-ascii character: escape *)
| _ ->
None
in
escape_map map s

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save