diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 4f0f2f31e..386bfc61c 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -138,28 +138,7 @@ module MF = MarkupFormatter
- Use the `_hum` suffix to flag functions that output human-readable strings.
-- Follow the ocp-indent style in infer/.ocpindent for indentation.
-
-- Spaces around binary operators, e.g., `let x = a + 5`.
-
-- Spaces around parentheses, no space inside parentheses.
-
-- Spaces around braces and brackets, spaces inside braces and brackets.
-
-- Space after `,` and `;`, e.g. `let (a, b) = ({ foo = 4; }, ())`.
-
-- Terminate multi-line values such as lists and records with `;` so that it's easy to add new lines
- without modifying existing ones. For instance:
-```OCaml
-let foo = [
- value1;
- value2;
-]
-```
-
-### Reason
-
-Follow `refmt`.
+- Format code with ocamlformat.
### C/C++/Objective-C
diff --git a/Makefile b/Makefile
index a3c8300e2..15587c4b0 100644
--- a/Makefile
+++ b/Makefile
@@ -113,27 +113,15 @@ fb-setup:
OCAMLFORMAT_EXE=facebook/dependencies/ocamlformat/src/_build/opt/ocamlformat.exe
-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_ml
-fmt_all_ml:
- parallel $(OCAMLFORMAT_EXE) --no-warn-error -i -- $(SRC_ML)
-
-SRC_RE:=$(shell find infer/src -name '*'.re 2>/dev/null)
-SRC_REI:=$(shell find infer/src -name '*'.rei 2>/dev/null)
-SRC_RE_ML:=$(patsubst %.re,%.ml,$(SRC_RE))
-SRC_REI_MLI:=$(patsubst %.rei,%.mli,$(SRC_REI))
+.PHONY: fmt
+fmt:
+ parallel $(OCAMLFORMAT_EXE) -i -- $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$")
-%.ml: %.re
- refmt --print=binary_reason $< | $(OCAMLFORMAT_EXE) $< --reason-impl -o $@
-
-%.mli: %.rei
- refmt --print=binary_reason $< | $(OCAMLFORMAT_EXE) $< --reason-intf -o $@
+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: fmt_all_ml $(SRC_RE_ML) $(SRC_REI_MLI)
- git add $(SRC_RE_ML) $(SRC_REI_MLI)
- rm -f $(SRC_RE) $(SRC_REI)
+fmt_all:
+ parallel $(OCAMLFORMAT_EXE) -i -- $(SRC_ML)
.PHONY: src_build
src_build:
@@ -321,7 +309,7 @@ endif
.PHONY: check_missing_mli
check_missing_mli:
- $(QUIET)for x in $$(find $(INFER_DIR)/src -name "*.ml" -or -name "*.re"); do \
+ $(QUIET)for x in $$(find $(INFER_DIR)/src -name "*.ml"); do \
test -f "$$x"i || echo Missing "$$x"i; done
.PHONY: toplevel
diff --git a/Makefile.autoconf.in b/Makefile.autoconf.in
index 9de7c2676..33b474566 100644
--- a/Makefile.autoconf.in
+++ b/Makefile.autoconf.in
@@ -52,6 +52,7 @@ MKDIR_P = $(shell $(MKDIR_P_CMD))
MVN = @MVN@
NCPU = @NCPU@
NDKBUILD = @NDKBUILD@
+OCAMLBUILD = @OCAMLBUILD@
OCAMLC = @OCAMLC@
OCAMLFIND = @OCAMLFIND@
OCAMLLEX = @OCAMLLEX@
@@ -61,7 +62,6 @@ OPAMSWITCH = @OPAMSWITCH@
PATH = @PATH@
prefix = @prefix@
PYTHON_lxml = @PYTHON_lxml@
-REBUILD = @REBUILD@
SHASUM = @SHASUM@
USER_JAVA_HOME = @USER_JAVA_HOME@
XCODE_SELECT = @XCODE_SELECT@
diff --git a/configure.ac b/configure.ac
index cfc0c37a1..aef502f36 100644
--- a/configure.ac
+++ b/configure.ac
@@ -175,6 +175,7 @@ AC_ASSERT_PROG([ocamlc], [$OCAMLC])
# check the version of OCaml
AC_ASSERT_OCAML_MIN_VERSION([4.04.2])
AC_ASSERT_PROG([ocamlopt], [$OCAMLOPT])
+AC_PATH_TOOL([OCAMLBUILD], [ocamlbuild], [no])
AC_ASSERT_PROG([ocamlbuild], [$OCAMLBUILD])
AC_PROG_FINDLIB
AC_PROG_OCAMLLEX
@@ -186,12 +187,7 @@ AC_ASSERT_OCAML_PKG([biniou])
AC_ASSERT_OCAML_PKG([camlzip], [zip])
AC_ASSERT_OCAML_PKG([easy-format])
AC_ASSERT_OCAML_PKG([oUnit], [], [2.0.0])
-AC_ASSERT_OCAML_PKG([reason])
AC_ASSERT_OCAML_PKG([yojson])
-# check for rebuild after checking for Reason since `rebuild` is normally provided by Reason. This
-# way if Reason is missing we get a more helpful error message and not "rebuild not found".
-AC_PATH_TOOL([REBUILD], [rebuild], [no])
-AC_ASSERT_PROG([rebuild], [$REBUILD])
AC_ARG_VAR([CAML_LD_LIBRARY_PATH],
[Additional directories to search for dynamically-loaded libraries.])
diff --git a/dependencies/ocamldot/ocamldot.mll b/dependencies/ocamldot/ocamldot.mll
index 9883a9280..524e2829f 100644
--- a/dependencies/ocamldot/ocamldot.mll
+++ b/dependencies/ocamldot/ocamldot.mll
@@ -320,7 +320,7 @@ let dir_to_mod_names graph dir =
fold_dir (fun dir_to_mod_names path ->
let file = Filename.basename path in
let mod_name = String.capitalize (try Filename.chop_extension file with _ -> file) in
- if ((Filename.check_suffix file ".ml" || Filename.check_suffix file ".re")
+ if ((Filename.check_suffix file ".ml")
&& StringSet.mem mod_name nodes)
then
let dir = Filename.dirname path in
diff --git a/infer/src/IR/Annot.ml b/infer/src/IR/Annot.ml
new file mode 100644
index 000000000..171148f53
--- /dev/null
+++ b/infer/src/IR/Annot.ml
@@ -0,0 +1,89 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Annotations *)
+open! IStd
+module L = Logging
+module F = Format
+
+type parameters = string list [@@deriving compare]
+
+(** Type to represent one @Annotation. *)
+type t =
+ { class_name: string (** name of the annotation *)
+ ; parameters: parameters (** currently only one string parameter *) }
+ [@@deriving compare]
+
+let volatile = {class_name= "volatile"; parameters= []}
+
+(** Pretty print an annotation. *)
+let prefix = match Config.curr_language_is Config.Java with true -> "@" | false -> "_"
+
+let pp fmt annotation = F.fprintf fmt "%s%s" prefix annotation.class_name
+
+module Map = PrettyPrintable.MakePPMap (struct
+ type nonrec t = t
+
+ let compare = compare
+
+ let pp = pp
+end)
+
+module Item = struct
+ (* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 *)
+ (* type nonrec t = list (t, bool) [@@deriving compare]; *)
+ (** Annotation for one item: a list of annotations with visibility. *)
+ type _t = (t * bool) list [@@deriving compare]
+
+ type t = _t [@@deriving compare]
+
+ let equal = [%compare.equal : t]
+
+ (** Pretty print an item annotation. *)
+ let pp fmt ann =
+ 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 = []
+
+ (** Check if the item annodation is empty. *)
+ let is_empty ia = List.is_empty ia
+end
+
+module Class = struct
+ let objc_str = "ObjC-Class"
+
+ let cpp_str = "Cpp-Class"
+
+ let of_string class_string = [({class_name= class_string; parameters= []}, true)]
+
+ let objc = of_string objc_str
+
+ let cpp = of_string cpp_str
+end
+
+module Method = struct
+ (** Annotation for a method: return value and list of parameters. *)
+ type t = Item.t * Item.t list [@@deriving compare]
+
+ (** Pretty print a method annotation. *)
+ let pp s fmt (ia, ial) = F.fprintf fmt "%a %s(%a)" Item.pp ia s (Pp.seq Item.pp) ial
+
+ (** Empty method annotation. *)
+ let empty = ([], [])
+
+ (** Check if the method annodation is empty. *)
+ let is_empty (ia, ial) = List.for_all ~f:Item.is_empty (ia :: ial)
+end
diff --git a/infer/src/IR/Annot.mli b/infer/src/IR/Annot.mli
new file mode 100644
index 000000000..0b6b3d87d
--- /dev/null
+++ b/infer/src/IR/Annot.mli
@@ -0,0 +1,78 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Annotations *)
+open! IStd
+module F = Format
+
+type parameters = string list
+
+(** Type to represent one @Annotation. *)
+
+type t =
+ { class_name: string (** name of the annotation *)
+ ; parameters: parameters (** currently only one string parameter *) }
+ [@@deriving compare]
+
+(** annotation for fields/methods marked with the "volatile" keyword *)
+
+val volatile : t
+
+(** Pretty print an annotation. *)
+
+val pp : F.formatter -> t -> unit
+
+module Map : PrettyPrintable.PPMap with type key = t
+
+module Item : sig
+ (** Annotation for one item: a list of annotations with visibility. *)
+
+ type nonrec t = (t * bool) list [@@deriving compare]
+
+ val equal : t -> t -> bool
+
+ (** Pretty print an item annotation. *)
+
+ val pp : F.formatter -> t -> unit
+
+ val to_string : t -> string
+
+ (** Empty item annotation. *)
+
+ val empty : t
+
+ (** Check if the item annodation is empty. *)
+
+ val is_empty : t -> bool
+end
+
+module Class : sig
+ val objc : Item.t
+
+ val cpp : Item.t
+end
+
+module Method : sig
+ (** Annotation for a method: return value and list of parameters. *)
+
+ type t = Item.t * Item.t list [@@deriving compare]
+
+ (** Empty method annotation. *)
+
+ val empty : t
+
+ (** Check if the method annodation is empty. *)
+
+ val is_empty : t -> bool
+
+ (** Pretty print a method annotation. *)
+
+ val pp : string -> F.formatter -> t -> unit
+end
diff --git a/infer/src/IR/Annot.re b/infer/src/IR/Annot.re
deleted file mode 100644
index 6e3623be2..000000000
--- a/infer/src/IR/Annot.re
+++ /dev/null
@@ -1,90 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Annotations */
-module L = Logging;
-
-module F = Format;
-
-type parameters = list string [@@deriving compare];
-
-
-/** Type to represent one @Annotation. */
-type t = {
- class_name: string, /** name of the annotation */
- parameters /** currently only one string parameter */
-}
-[@@deriving compare];
-
-let volatile = {class_name: "volatile", parameters: []};
-
-
-/** Pretty print an annotation. */
-let prefix = Config.curr_language_is Config.Java ? "@" : "_";
-
-let pp fmt annotation => F.fprintf fmt "%s%s" prefix annotation.class_name;
-
-module Map =
- PrettyPrintable.MakePPMap {
- type nonrec t = t;
- let compare = compare;
- let pp = pp;
- };
-
-module Item = {
-
- /** Annotation for one item: a list of annotations with visibility. */
- /* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 */
- /* type nonrec t = list (t, bool) [@@deriving compare]; */
- type _t = list (t, bool) [@@deriving compare];
- type t = _t [@@deriving compare];
- let equal = [%compare.equal : t];
-
- /** Pretty print an item annotation. */
- let pp fmt ann => {
- let pp fmt (a, _) => pp fmt a;
- F.fprintf fmt "<%a>" (Pp.seq pp) ann
- };
- let to_string ann => {
- let pp fmt => pp fmt ann;
- F.asprintf "%t" pp
- };
-
- /** Empty item annotation. */
- let empty = [];
-
- /** Check if the item annodation is empty. */
- let is_empty ia => List.is_empty ia;
-};
-
-module Class = {
- let objc_str = "ObjC-Class";
- let cpp_str = "Cpp-Class";
- let of_string class_string => [({class_name: class_string, parameters: []}, true)];
- let objc = of_string objc_str;
- let cpp = of_string cpp_str;
-};
-
-module Method = {
-
- /** Annotation for a method: return value and list of parameters. */
- type t = (Item.t, list Item.t) [@@deriving compare];
-
- /** Pretty print a method annotation. */
- let pp s fmt (ia, ial) => F.fprintf fmt "%a %s(%a)" Item.pp ia s (Pp.seq Item.pp) ial;
-
- /** Empty method annotation. */
- let empty = ([], []);
-
- /** Check if the method annodation is empty. */
- let is_empty (ia, ial) => List.for_all f::Item.is_empty [ia, ...ial];
-};
diff --git a/infer/src/IR/Annot.rei b/infer/src/IR/Annot.rei
deleted file mode 100644
index 6c911a2e7..000000000
--- a/infer/src/IR/Annot.rei
+++ /dev/null
@@ -1,68 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Annotations */
-module F = Format;
-
-type parameters = list string;
-
-
-/** Type to represent one @Annotation. */
-type t = {
- class_name: string, /** name of the annotation */
- parameters /** currently only one string parameter */
-}
-[@@deriving compare];
-
-
-/** annotation for fields/methods marked with the "volatile" keyword */
-let volatile: t;
-
-
-/** Pretty print an annotation. */
-let pp: F.formatter => t => unit;
-
-module Map: PrettyPrintable.PPMap with type key = t;
-
-module Item: {
-
- /** Annotation for one item: a list of annotations with visibility. */
- type nonrec t = list (t, bool) [@@deriving compare];
- let equal: t => t => bool;
-
- /** Pretty print an item annotation. */
- let pp: F.formatter => t => unit;
- let to_string: t => string;
-
- /** Empty item annotation. */
- let empty: t;
-
- /** Check if the item annodation is empty. */
- let is_empty: t => bool;
-};
-
-module Class: {let objc: Item.t; let cpp: Item.t;};
-
-module Method: {
-
- /** Annotation for a method: return value and list of parameters. */
- type t = (Item.t, list Item.t) [@@deriving compare];
-
- /** Empty method annotation. */
- let empty: t;
-
- /** Check if the method annodation is empty. */
- let is_empty: t => bool;
-
- /** Pretty print a method annotation. */
- let pp: string => F.formatter => t => unit;
-};
diff --git a/infer/src/IR/AttributesTable.ml b/infer/src/IR/AttributesTable.ml
new file mode 100644
index 000000000..12043142d
--- /dev/null
+++ b/infer/src/IR/AttributesTable.ml
@@ -0,0 +1,233 @@
+(*
+ * Copyright (c) 2015 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+open! IStd
+open! PVariant
+module Hashtbl = Caml.Hashtbl
+module F = Format
+module L = Logging
+
+type attr_kind = ProcDefined | ProcObjCAccessor | ProcUndefined
+
+(** Module to manage the table of attributes. *)
+let serializer : ProcAttributes.t Serialization.serializer =
+ Serialization.create_serializer Serialization.Key.attributes
+
+let attributes_filename ~proc_kind pname_file =
+ let file_suffix =
+ match proc_kind with
+ | ProcDefined
+ -> ".attr"
+ | ProcObjCAccessor
+ -> ".objc_acc.attr"
+ | ProcUndefined
+ -> ".decl.attr"
+ in
+ pname_file ^ file_suffix
+
+(** path to the .attr file for the given procedure in the current results directory *)
+let res_dir_attr_filename ~create_dir ~proc_kind pname =
+ let pname_file = Typ.Procname.to_filename pname in
+ let attr_fname = attributes_filename ~proc_kind pname_file in
+ let bucket_dir =
+ let base = pname_file in
+ let len = String.length base in
+ if len < 2 then Filename.current_dir_name else String.sub base ~pos:(len - 2) ~len:2
+ in
+ let filename =
+ DB.Results_dir.path_to_filename DB.Results_dir.Abs_root
+ [Config.attributes_dir_name; bucket_dir; attr_fname]
+ in
+ if create_dir then DB.filename_create_dir filename ;
+ filename
+
+(* Load the proc attribute for the defined filename if it exists,
+ otherwise try to load the declared filename. *)
+let load_attr ~defined_only proc_name =
+ let attributes_file ~proc_kind proc_name =
+ Multilinks.resolve (res_dir_attr_filename ~create_dir:false ~proc_kind proc_name)
+ in
+ let attr =
+ Serialization.read_from_file serializer (attributes_file ~proc_kind:ProcDefined proc_name)
+ in
+ if is_none attr && not defined_only then
+ (* We try to load the objc accesor one if they exist, if not then we load the undefined one *)
+ let attr =
+ Serialization.read_from_file serializer
+ (attributes_file ~proc_kind:ProcObjCAccessor proc_name)
+ in
+ match attr with
+ | Some attr
+ -> Some attr
+ | None
+ -> Serialization.read_from_file serializer
+ (attributes_file ~proc_kind:ProcUndefined proc_name)
+ else attr
+
+let create_proc_kind (proc_attributes: ProcAttributes.t) =
+ if proc_attributes.is_defined then ProcDefined
+ else if Option.is_some proc_attributes.objc_accessor then ProcObjCAccessor
+ else ProcUndefined
+
+let less_relevant_proc_kinds proc_kind =
+ match proc_kind with
+ | ProcDefined
+ -> [ProcObjCAccessor; ProcUndefined]
+ | ProcObjCAccessor
+ -> [ProcUndefined]
+ | ProcUndefined
+ -> []
+
+(* Write a proc attributes to file.
+ If defined, delete the declared file if it exists. *)
+let write_and_delete proc_name (proc_attributes: ProcAttributes.t) =
+ let proc_kind = create_proc_kind proc_attributes in
+ let attributes_file proc_kind = res_dir_attr_filename ~create_dir:true ~proc_kind proc_name in
+ Serialization.write_to_file serializer (attributes_file proc_kind) ~data:proc_attributes ;
+ let upgrade_relevance less_relevant_proc_kind =
+ let fname_declared = DB.filename_to_string (attributes_file less_relevant_proc_kind) in
+ if Sys.file_exists fname_declared = `Yes then
+ try Unix.unlink fname_declared
+ with Unix.Unix_error _ -> ()
+ in
+ List.iter ~f:upgrade_relevance (less_relevant_proc_kinds proc_kind)
+
+(* This creates an ordering in the attribute files: 1.defined, 2.objc accessor, 3.else.
+ To be used to figure out if we should override an existing attribute file with a new
+ one, if relevant information will be updated, or lost.
+ If the relevance is not upgraded, choose based on whether its associated file has higher
+ rank (alphabetically) than the other. *)
+let should_override_attr (new_attr: ProcAttributes.t) (old_attr: ProcAttributes.t) =
+ if new_attr.is_defined then
+ if old_attr.is_defined then SourceFile.compare new_attr.loc.file old_attr.loc.file > 0
+ else true (* new becomes defined, override *)
+ else if old_attr.is_defined then false (* old was defined, new isn't, don't override *)
+ else if Option.is_some new_attr.objc_accessor then
+ if Option.is_some old_attr.objc_accessor then
+ SourceFile.compare new_attr.loc.file old_attr.loc.file > 0
+ else true (* new becomes objc accessor, override *)
+ else false
+
+(* new isn't defined or objc accessor, don't overide *)
+
+let store_attributes (proc_attributes: ProcAttributes.t) =
+ let proc_name = proc_attributes.proc_name in
+ let should_write =
+ match load_attr ~defined_only:false proc_name with
+ | None
+ -> true
+ | Some proc_attributes_on_disk
+ -> should_override_attr proc_attributes proc_attributes_on_disk
+ in
+ if should_write then write_and_delete proc_name proc_attributes
+
+let attr_tbl = Typ.Procname.Hash.create 16
+
+let defined_attr_tbl = Typ.Procname.Hash.create 16
+
+let load_attributes ~cache proc_name =
+ try Typ.Procname.Hash.find attr_tbl proc_name
+ with Not_found ->
+ let proc_attributes = load_attr ~defined_only:false proc_name in
+ ( match proc_attributes with
+ | Some attrs
+ -> if cache then (
+ Typ.Procname.Hash.add attr_tbl proc_name proc_attributes ;
+ if attrs.is_defined then Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes )
+ | None
+ -> () ) ;
+ proc_attributes
+
+let load_defined_attributes ~cache_none proc_name =
+ try Typ.Procname.Hash.find defined_attr_tbl proc_name
+ with Not_found ->
+ let proc_attributes = load_attr ~defined_only:true proc_name in
+ if proc_attributes <> None then (
+ (* procedure just got defined, replace attribute in attr_tbl with defined version *)
+ Typ.Procname.Hash.replace attr_tbl proc_name proc_attributes ;
+ Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes )
+ else if cache_none then Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes ;
+ proc_attributes
+
+(** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
+ do this by adding a method that is unique to each class, and then finding the tenv that
+ corresponds to the class definition. *)
+let get_correct_type_from_objc_class_name type_name =
+ (* ToDo: this function should return a type that includes a reference to the tenv computed by:
+ let class_method = Typ.Procname.get_default_objc_class_method (Typ.Name.name type_name);
+ switch (find_tenv_from_class_of_proc class_method) {
+ | Some tenv =>
+ *)
+ Some (Typ.mk (Tstruct type_name))
+
+type t =
+ {num_bindings: int; num_buckets: int; max_bucket_length: int; serialized_size_kb: int option}
+
+let to_json at =
+ let extra_field =
+ match at.serialized_size_kb with Some v -> [("serialized_size_kb", `Int v)] | None -> []
+ in
+ `Assoc
+ ( [ ("num_bindings", `Int at.num_bindings)
+ ; ("num_buckets", `Int at.num_buckets)
+ ; ("max_bucket_length", `Int at.max_bucket_length) ]
+ @ extra_field )
+
+let from_json json =
+ let open! Yojson.Basic.Util in
+ { num_bindings= json |> member "num_bindings" |> to_int
+ ; num_buckets= json |> member "num_buckets" |> to_int
+ ; max_bucket_length= json |> member "max_bucket_length" |> to_int
+ ; serialized_size_kb= json |> member "serialized_size_kb" |> to_option to_int }
+
+let aggregate s =
+ let all_num_bindings = List.map ~f:(fun stats -> float_of_int stats.num_bindings) s in
+ let all_num_buckets = List.map ~f:(fun stats -> float_of_int stats.num_buckets) s in
+ let all_max_bucket_length = List.map ~f:(fun stats -> float_of_int stats.max_bucket_length) s in
+ let aggr_num_bindings = StatisticsToolbox.compute_statistics all_num_bindings in
+ let aggr_num_buckets = StatisticsToolbox.compute_statistics all_num_buckets in
+ let aggr_max_bucket_length = StatisticsToolbox.compute_statistics all_max_bucket_length in
+ `Assoc
+ [ ("num_bindings", StatisticsToolbox.to_json aggr_num_bindings)
+ ; ("num_buckets", StatisticsToolbox.to_json aggr_num_buckets)
+ ; ("max_bucket_length", StatisticsToolbox.to_json aggr_max_bucket_length) ]
+
+let stats () =
+ let stats = Typ.Procname.Hash.stats attr_tbl in
+ let {Hashtbl.num_bindings; num_buckets; max_bucket_length} = stats in
+ let serialized_size_kb =
+ match Config.developer_mode with
+ | true
+ -> Some (Marshal.data_size (Marshal.to_bytes attr_tbl []) 0 / 1024)
+ | false
+ -> None
+ in
+ {num_bindings; num_buckets; max_bucket_length; serialized_size_kb}
+
+(* Find the file where the procedure was captured, if a cfg for that file exists.
+ Return also a boolean indicating whether the procedure is defined in an
+ include file. *)
+let find_file_capturing_procedure ?(cache= true) pname =
+ match load_attributes ~cache pname with
+ | 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
+ in
+ let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg" in
+ let cfg_fname_exists = Sys.file_exists (DB.filename_to_string cfg_fname) = `Yes in
+ if cfg_fname_exists then Some (source_file, origin) else None
diff --git a/infer/src/IR/AttributesTable.mli b/infer/src/IR/AttributesTable.mli
new file mode 100644
index 000000000..de3ef6534
--- /dev/null
+++ b/infer/src/IR/AttributesTable.mli
@@ -0,0 +1,49 @@
+(*
+ * Copyright (c) 2015 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** Module to manage the table of attributes. *)
+
+open! IStd
+
+(** Save .attr file for the procedure into the attributes database. *)
+
+val store_attributes : ProcAttributes.t -> unit
+
+(** Load the attributes for the procedure from the attributes database.
+ If cache is true, add the attribute to the global cache *)
+
+val load_attributes : cache:bool -> Typ.Procname.t -> ProcAttributes.t option
+
+(** Load attrubutes for the procedure but only if is_defined is true *)
+
+val load_defined_attributes : cache_none:bool -> Typ.Procname.t -> ProcAttributes.t option
+
+(** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
+ do this by adding a method that is unique to each class, and then finding the tenv that
+ corresponds to the class definition. *)
+
+val get_correct_type_from_objc_class_name : Typ.Name.t -> Typ.t option
+
+(* Find the file where the procedure was captured, if a cfg for that file exists.
+ Return also a boolean indicating whether the procedure is defined in an
+ include file.
+ If cache is true, add the attribute to the global cache *)
+
+val find_file_capturing_procedure :
+ ?cache:bool -> Typ.Procname.t -> (SourceFile.t * [`Include | `Source]) option
+
+type t
+
+val stats : unit -> t
+
+val to_json : t -> Yojson.Basic.json
+
+val from_json : Yojson.Basic.json -> t
+
+val aggregate : t list -> Yojson.Basic.json
diff --git a/infer/src/IR/AttributesTable.re b/infer/src/IR/AttributesTable.re
deleted file mode 100644
index f6d14b6dc..000000000
--- a/infer/src/IR/AttributesTable.re
+++ /dev/null
@@ -1,281 +0,0 @@
-/*
- * Copyright (c) 2015 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-open! PVariant;
-
-module Hashtbl = Caml.Hashtbl;
-
-module F = Format;
-
-module L = Logging;
-
-type attr_kind =
- | ProcDefined
- | ProcObjCAccessor
- | ProcUndefined;
-
-
-/** Module to manage the table of attributes. */
-let serializer: Serialization.serializer ProcAttributes.t =
- Serialization.create_serializer Serialization.Key.attributes;
-
-let attributes_filename ::proc_kind pname_file => {
- let file_suffix =
- switch proc_kind {
- | ProcDefined => ".attr"
- | ProcObjCAccessor => ".objc_acc.attr"
- | ProcUndefined => ".decl.attr"
- };
- pname_file ^ file_suffix
-};
-
-
-/** path to the .attr file for the given procedure in the current results directory */
-let res_dir_attr_filename ::create_dir ::proc_kind pname => {
- let pname_file = Typ.Procname.to_filename pname;
- let attr_fname = attributes_filename ::proc_kind pname_file;
- let bucket_dir = {
- let base = pname_file;
- let len = String.length base;
- if (len < 2) {
- Filename.current_dir_name
- } else {
- String.sub base pos::(len - 2) len::2
- }
- };
- let filename =
- DB.Results_dir.path_to_filename
- DB.Results_dir.Abs_root [Config.attributes_dir_name, bucket_dir, attr_fname];
- if create_dir {
- DB.filename_create_dir filename
- };
- filename
-};
-
-/* Load the proc attribute for the defined filename if it exists,
- otherwise try to load the declared filename. */
-let load_attr ::defined_only proc_name => {
- let attributes_file ::proc_kind proc_name =>
- Multilinks.resolve (res_dir_attr_filename create_dir::false ::proc_kind proc_name);
- let attr =
- Serialization.read_from_file serializer (attributes_file proc_kind::ProcDefined proc_name);
- if (is_none attr && not defined_only) {
- /* We try to load the objc accesor one if they exist, if not then we load the undefined one */
- let attr =
- Serialization.read_from_file
- serializer (attributes_file proc_kind::ProcObjCAccessor proc_name);
- switch attr {
- | Some attr => Some attr
- | None =>
- Serialization.read_from_file serializer (attributes_file proc_kind::ProcUndefined proc_name)
- }
- } else {
- attr
- }
-};
-
-let create_proc_kind (proc_attributes: ProcAttributes.t) =>
- if proc_attributes.is_defined {
- ProcDefined
- } else if (
- Option.is_some proc_attributes.objc_accessor
- ) {
- ProcObjCAccessor
- } else {
- ProcUndefined
- };
-
-let less_relevant_proc_kinds proc_kind =>
- switch proc_kind {
- | ProcDefined => [ProcObjCAccessor, ProcUndefined]
- | ProcObjCAccessor => [ProcUndefined]
- | ProcUndefined => []
- };
-
-/* Write a proc attributes to file.
- If defined, delete the declared file if it exists. */
-let write_and_delete proc_name (proc_attributes: ProcAttributes.t) => {
- let proc_kind = create_proc_kind proc_attributes;
- let attributes_file proc_kind => res_dir_attr_filename create_dir::true ::proc_kind proc_name;
- Serialization.write_to_file serializer (attributes_file proc_kind) data::proc_attributes;
- let upgrade_relevance less_relevant_proc_kind => {
- let fname_declared = DB.filename_to_string (attributes_file less_relevant_proc_kind);
- if (Sys.file_exists fname_declared == `Yes) {
- try (Unix.unlink fname_declared) {
- | Unix.Unix_error _ => ()
- }
- }
- };
- List.iter f::upgrade_relevance (less_relevant_proc_kinds proc_kind)
-};
-
-/* This creates an ordering in the attribute files: 1.defined, 2.objc accessor, 3.else.
- To be used to figure out if we should override an existing attribute file with a new
- one, if relevant information will be updated, or lost.
- If the relevance is not upgraded, choose based on whether its associated file has higher
- rank (alphabetically) than the other. */
-let should_override_attr (new_attr: ProcAttributes.t) (old_attr: ProcAttributes.t) =>
- if new_attr.is_defined {
- if old_attr.is_defined {
- SourceFile.compare new_attr.loc.file old_attr.loc.file > 0
- } else {
- true /* new becomes defined, override */
- }
- } else if
- old_attr.is_defined {
- false /* old was defined, new isn't, don't override */
- } else if (
- Option.is_some new_attr.objc_accessor
- ) {
- if (Option.is_some old_attr.objc_accessor) {
- SourceFile.compare new_attr.loc.file old_attr.loc.file > 0
- } else {
- true /* new becomes objc accessor, override */
- }
- } else {
- false /* new isn't defined or objc accessor, don't overide */
- };
-
-let store_attributes (proc_attributes: ProcAttributes.t) => {
- let proc_name = proc_attributes.proc_name;
- let should_write =
- switch (load_attr defined_only::false proc_name) {
- | None => true
- | Some proc_attributes_on_disk => should_override_attr proc_attributes proc_attributes_on_disk
- };
- if should_write {
- write_and_delete proc_name proc_attributes
- }
-};
-
-let attr_tbl = Typ.Procname.Hash.create 16;
-
-let defined_attr_tbl = Typ.Procname.Hash.create 16;
-
-let load_attributes ::cache proc_name =>
- try (Typ.Procname.Hash.find attr_tbl proc_name) {
- | Not_found =>
- let proc_attributes = load_attr defined_only::false proc_name;
- switch proc_attributes {
- | Some attrs =>
- if cache {
- Typ.Procname.Hash.add attr_tbl proc_name proc_attributes;
- if attrs.is_defined {
- Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes
- }
- }
- | None => ()
- };
- proc_attributes
- };
-
-let load_defined_attributes ::cache_none proc_name =>
- try (Typ.Procname.Hash.find defined_attr_tbl proc_name) {
- | Not_found =>
- let proc_attributes = load_attr defined_only::true proc_name;
- if (proc_attributes != None) {
- /* procedure just got defined, replace attribute in attr_tbl with defined version */
- Typ.Procname.Hash.replace attr_tbl proc_name proc_attributes;
- Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes
- } else if cache_none {
- Typ.Procname.Hash.add defined_attr_tbl proc_name proc_attributes
- };
- proc_attributes
- };
-
-
-/** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
- do this by adding a method that is unique to each class, and then finding the tenv that
- corresponds to the class definition. */
-let get_correct_type_from_objc_class_name type_name =>
- /* ToDo: this function should return a type that includes a reference to the tenv computed by:
- let class_method = Typ.Procname.get_default_objc_class_method (Typ.Name.name type_name);
- switch (find_tenv_from_class_of_proc class_method) {
- | Some tenv =>
- */
- Some (Typ.mk (Tstruct type_name));
-
-type t = {
- num_bindings: int,
- num_buckets: int,
- max_bucket_length: int,
- serialized_size_kb: option int
-};
-
-let to_json at => {
- let extra_field =
- switch at.serialized_size_kb {
- | Some v => [("serialized_size_kb", `Int v)]
- | None => []
- };
- `Assoc (
- [
- ("num_bindings", `Int at.num_bindings),
- ("num_buckets", `Int at.num_buckets),
- ("max_bucket_length", `Int at.max_bucket_length)
- ] @ extra_field
- )
-};
-
-let from_json json => {
- open! Yojson.Basic.Util;
- {
- num_bindings: json |> member "num_bindings" |> to_int,
- num_buckets: json |> member "num_buckets" |> to_int,
- max_bucket_length: json |> member "max_bucket_length" |> to_int,
- serialized_size_kb: json |> member "serialized_size_kb" |> to_option to_int
- }
-};
-
-let aggregate s => {
- let all_num_bindings = List.map f::(fun stats => float_of_int stats.num_bindings) s;
- let all_num_buckets = List.map f::(fun stats => float_of_int stats.num_buckets) s;
- let all_max_bucket_length = List.map f::(fun stats => float_of_int stats.max_bucket_length) s;
- let aggr_num_bindings = StatisticsToolbox.compute_statistics all_num_bindings;
- let aggr_num_buckets = StatisticsToolbox.compute_statistics all_num_buckets;
- let aggr_max_bucket_length = StatisticsToolbox.compute_statistics all_max_bucket_length;
- `Assoc [
- ("num_bindings", StatisticsToolbox.to_json aggr_num_bindings),
- ("num_buckets", StatisticsToolbox.to_json aggr_num_buckets),
- ("max_bucket_length", StatisticsToolbox.to_json aggr_max_bucket_length)
- ]
-};
-
-let stats () => {
- let stats = Typ.Procname.Hash.stats attr_tbl;
- let {Hashtbl.num_bindings: num_bindings, num_buckets, max_bucket_length} = stats;
- let serialized_size_kb =
- Config.developer_mode ?
- Some (Marshal.data_size (Marshal.to_bytes attr_tbl []) 0 / 1024) : None;
- {num_bindings, num_buckets, max_bucket_length, serialized_size_kb}
-};
-
-/* Find the file where the procedure was captured, if a cfg for that file exists.
- Return also a boolean indicating whether the procedure is defined in an
- include file. */
-let find_file_capturing_procedure ::cache=true pname =>
- switch (load_attributes ::cache pname) {
- | None => None
- | Some proc_attributes =>
- let source_file = proc_attributes.ProcAttributes.source_file_captured;
- let source_dir = DB.source_dir_from_source_file source_file;
- let origin =
- /* Procedure coming from include files if it has different location
- than the file where it was captured. */
- SourceFile.compare source_file proc_attributes.ProcAttributes.loc.file != 0 ?
- `Include : `Source;
- let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg";
- let cfg_fname_exists = Sys.file_exists (DB.filename_to_string cfg_fname) == `Yes;
- if cfg_fname_exists {
- Some (source_file, origin)
- } else {
- None
- }
- };
diff --git a/infer/src/IR/AttributesTable.rei b/infer/src/IR/AttributesTable.rei
deleted file mode 100644
index 73fc1479e..000000000
--- a/infer/src/IR/AttributesTable.rei
+++ /dev/null
@@ -1,47 +0,0 @@
-/*
- * Copyright (c) 2015 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-
-/** Module to manage the table of attributes. */
-open! IStd;
-
-
-/** Save .attr file for the procedure into the attributes database. */
-let store_attributes: ProcAttributes.t => unit;
-
-
-/** Load the attributes for the procedure from the attributes database.
- If cache is true, add the attribute to the global cache */
-let load_attributes: cache::bool => Typ.Procname.t => option ProcAttributes.t;
-
-
-/** Load attrubutes for the procedure but only if is_defined is true */
-let load_defined_attributes: cache_none::bool => Typ.Procname.t => option ProcAttributes.t;
-
-
-/** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
- do this by adding a method that is unique to each class, and then finding the tenv that
- corresponds to the class definition. */
-let get_correct_type_from_objc_class_name: Typ.Name.t => option Typ.t;
-
-/* Find the file where the procedure was captured, if a cfg for that file exists.
- Return also a boolean indicating whether the procedure is defined in an
- include file.
- If cache is true, add the attribute to the global cache */
-let find_file_capturing_procedure:
- cache::bool? => Typ.Procname.t => option (SourceFile.t, [ | `Include | `Source]);
-
-type t;
-
-let stats: unit => t;
-
-let to_json: t => Yojson.Basic.json;
-
-let from_json: Yojson.Basic.json => t;
-
-let aggregate: list t => Yojson.Basic.json;
diff --git a/infer/src/IR/BUILTINS.mli b/infer/src/IR/BUILTINS.mli
index 85b14f298..3e2c6a29e 100644
--- a/infer/src/IR/BUILTINS.mli
+++ b/infer/src/IR/BUILTINS.mli
@@ -12,76 +12,146 @@ open! IStd
(** List of all builtins that are interpreted specially by the backend *)
module type S = sig
type t
+
val __assert_fail : t
+
val __builtin_va_arg : t
+
val __builtin_va_copy : t
+
val __builtin_va_end : t
+
val __builtin_va_start : t
- val __cast : t (** [__cast(val,typ)] implements java's [typ(val)] *)
+
+ val __cast : t
+ (** [__cast(val,typ)] implements java's [typ(val)] *)
val __check_untainted : t
+
val __cxx_typeid : t
+
val __delete : t
+
val __delete_array : t
+
val __delete_locked_attribute : t
+
val __exit : t
+
val __get_array_length : t
+
val __get_hidden_field : t
+
val __get_type_of : t
+
val __infer_assume : t
+
val __infer_fail : t
- val __instanceof : t (** [__instanceof(val,typ)] implements java's [val instanceof typ] *)
+
+ val __instanceof : t
+ (** [__instanceof(val,typ)] implements java's [val instanceof typ] *)
val __method_set_ignore_attribute : t
+
val __new : t
+
val __new_array : t
+
val __objc_alloc : t
+
val __objc_alloc_no_fail : t
+
val __objc_cast : t
+
val __objc_dictionary_literal : t
+
val __objc_release : t
+
val __objc_release_autorelease_pool : t
+
val __objc_release_cf : t
+
val __objc_retain : t
+
val __objc_retain_cf : t
+
val __placement_delete : t
+
val __placement_new : t
+
val __print_value : t
+
val __require_allocated_array : t
+
val __set_array_length : t
+
val __set_autorelease_attribute : t
+
val __set_file_attribute : t
+
val __set_hidden_field : t
+
val __set_lock_attribute : t
+
val __set_locked_attribute : t
+
val __set_mem_attribute : t
+
val __set_observer_attribute : t
+
val __set_taint_attribute : t
+
val __set_unlocked_attribute : t
+
val __set_unsubscribed_observer_attribute : t
+
val __set_untaint_attribute : t
+
val __split_get_nth : t
+
val __throw : t
+
val __unwrap_exception : t
+
val abort : t
+
val exit : t
+
val free : t
+
val fscanf : t
+
val fwscanf : t
+
val malloc : t
+
val malloc_no_fail : t
+
val nsArray_arrayWithObjects : t
+
val nsArray_arrayWithObjectsCount : t
+
val objc_cpp_throw : t
+
val pthread_create : t
+
val scanf : t
+
val sscanf : t
+
val swscanf : t
+
val vfscanf : t
+
val vfwscanf : t
+
val vscanf : t
+
val vsscanf : t
+
val vswscanf : t
+
val vwscanf : t
+
val wscanf : t
end
diff --git a/infer/src/IR/Binop.ml b/infer/src/IR/Binop.ml
new file mode 100644
index 000000000..cf66e4972
--- /dev/null
+++ b/infer/src/IR/Binop.ml
@@ -0,0 +1,134 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Binary Operators *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** Binary operations *)
+type t =
+ | PlusA (** arithmetic + *)
+ | PlusPI (** pointer + integer *)
+ | MinusA (** arithmetic - *)
+ | MinusPI (** pointer - integer *)
+ | MinusPP (** pointer - pointer *)
+ | Mult (** * *)
+ | Div (** / *)
+ | Mod (** % *)
+ | Shiftlt (** shift left *)
+ | Shiftrt (** shift right *)
+ | Lt (** < (arithmetic comparison) *)
+ | Gt (** > (arithmetic comparison) *)
+ | Le (** <= (arithmetic comparison) *)
+ | Ge (** >= (arithmetic comparison) *)
+ | Eq (** == (arithmetic comparison) *)
+ | Ne (** != (arithmetic comparison) *)
+ | BAnd (** bitwise and *)
+ | BXor (** exclusive-or *)
+ | BOr (** inclusive-or *)
+ | LAnd (** logical and. Does not always evaluate both operands. *)
+ | LOr (** logical or. Does not always evaluate both operands. *)
+ [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+(** This function returns true if the operation is injective
+ wrt. each argument: op(e,-) and op(-, e) is injective for all e.
+ The return value false means "don't know". *)
+let injective = function PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false
+
+(** This function returns true if the operation can be inverted. *)
+let invertible = function PlusA | PlusPI | MinusA | MinusPI -> true | _ -> false
+
+(** This function inverts an invertible injective binary operator.
+ 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
+
+(** 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
+ -> "||"
+
+(** Pretty print a binary operator. *)
+let str pe binop =
+ match pe.Pp.kind with
+ | HTML -> (
+ match binop with
+ | Ge
+ -> " >= "
+ | Le
+ -> " <= "
+ | Gt
+ -> " > "
+ | Lt
+ -> " < "
+ | Shiftlt
+ -> " << "
+ | Shiftrt
+ -> " >> "
+ | _
+ -> text binop )
+ | LATEX -> (
+ match binop with Ge -> " \\geq " | Le -> " \\leq " | _ -> text binop )
+ | _
+ -> text binop
diff --git a/infer/src/IR/Binop.mli b/infer/src/IR/Binop.mli
new file mode 100644
index 000000000..567e2877b
--- /dev/null
+++ b/infer/src/IR/Binop.mli
@@ -0,0 +1,66 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Binary Operators *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** Binary operations *)
+
+type t =
+ | PlusA (** arithmetic + *)
+ | PlusPI (** pointer + integer *)
+ | MinusA (** arithmetic - *)
+ | MinusPI (** pointer - integer *)
+ | MinusPP (** pointer - pointer *)
+ | Mult (** * *)
+ | Div (** / *)
+ | Mod (** % *)
+ | Shiftlt (** shift left *)
+ | Shiftrt (** shift right *)
+ | Lt (** < (arithmetic comparison) *)
+ | Gt (** > (arithmetic comparison) *)
+ | Le (** <= (arithmetic comparison) *)
+ | Ge (** >= (arithmetic comparison) *)
+ | Eq (** == (arithmetic comparison) *)
+ | Ne (** != (arithmetic comparison) *)
+ | BAnd (** bitwise and *)
+ | BXor (** exclusive-or *)
+ | BOr (** inclusive-or *)
+ | LAnd (** logical and. Does not always evaluate both operands. *)
+ | LOr (** logical or. Does not always evaluate both operands. *)
+ [@@deriving compare]
+
+val equal : t -> t -> bool
+
+(** This function returns true if the operation is injective
+ wrt. each argument: op(e,-) and op(-, e) is injective for all e.
+ The return value false means "don't know". *)
+
+val injective : t -> bool
+
+(** This function returns true if the operation can be inverted. *)
+
+val invertible : t -> bool
+
+(** This function inverts an invertible injective binary operator.
+ If the [binop] operation is not invertible, the function raises Assert_failure. *)
+
+val invert : t -> t
+
+(** This function returns true if 0 is the right unit of [binop].
+ The return value false means "don't know". *)
+
+val is_zero_runit : t -> bool
+
+(** String representation of a binary operator. *)
+
+val str : Pp.env -> t -> string
diff --git a/infer/src/IR/Binop.re b/infer/src/IR/Binop.re
deleted file mode 100644
index 897e26a73..000000000
--- a/infer/src/IR/Binop.re
+++ /dev/null
@@ -1,138 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Binary Operators */
-module L = Logging;
-
-module F = Format;
-
-
-/** Binary operations */
-type t =
- | PlusA /** arithmetic + */
- | PlusPI /** pointer + integer */
- | MinusA /** arithmetic - */
- | MinusPI /** pointer - integer */
- | MinusPP /** pointer - pointer */
- | Mult /** * */
- | Div /** / */
- | Mod /** % */
- | Shiftlt /** shift left */
- | Shiftrt /** shift right */
- | Lt /** < (arithmetic comparison) */
- | Gt /** > (arithmetic comparison) */
- | Le /** <= (arithmetic comparison) */
- | Ge /** >= (arithmetic comparison) */
- | Eq /** == (arithmetic comparison) */
- | Ne /** != (arithmetic comparison) */
- | BAnd /** bitwise and */
- | BXor /** exclusive-or */
- | BOr /** inclusive-or */
- | LAnd /** logical and. Does not always evaluate both operands. */
- | LOr /** logical or. Does not always evaluate both operands. */
-[@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-
-/** This function returns true if the operation is injective
- wrt. each argument: op(e,-) and op(-, e) is injective for all e.
- The return value false means "don't know". */
-let injective =
- fun
- | PlusA
- | PlusPI
- | MinusA
- | MinusPI
- | MinusPP => true
- | _ => false;
-
-
-/** This function returns true if the operation can be inverted. */
-let invertible =
- fun
- | PlusA
- | PlusPI
- | MinusA
- | MinusPI => true
- | _ => false;
-
-
-/** This function inverts an invertible injective binary operator.
- If the [binop] operation is not invertible, the function raises Assert_failure. */
-let invert bop =>
- switch bop {
- | 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 =
- fun
- | PlusA
- | PlusPI
- | MinusA
- | MinusPI
- | MinusPP => true
- | _ => false;
-
-let text =
- fun
- | 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 =>
- switch pe.Pp.kind {
- | HTML =>
- switch binop {
- | Ge => " >= "
- | Le => " <= "
- | Gt => " > "
- | Lt => " < "
- | Shiftlt => " << "
- | Shiftrt => " >> "
- | _ => text binop
- }
- | LATEX =>
- switch binop {
- | Ge => " \\geq "
- | Le => " \\leq "
- | _ => text binop
- }
- | _ => text binop
- };
diff --git a/infer/src/IR/Binop.rei b/infer/src/IR/Binop.rei
deleted file mode 100644
index 3b3c102e6..000000000
--- a/infer/src/IR/Binop.rei
+++ /dev/null
@@ -1,68 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Binary Operators */
-module L = Logging;
-
-module F = Format;
-
-
-/** Binary operations */
-type t =
- | PlusA /** arithmetic + */
- | PlusPI /** pointer + integer */
- | MinusA /** arithmetic - */
- | MinusPI /** pointer - integer */
- | MinusPP /** pointer - pointer */
- | Mult /** * */
- | Div /** / */
- | Mod /** % */
- | Shiftlt /** shift left */
- | Shiftrt /** shift right */
- | Lt /** < (arithmetic comparison) */
- | Gt /** > (arithmetic comparison) */
- | Le /** <= (arithmetic comparison) */
- | Ge /** >= (arithmetic comparison) */
- | Eq /** == (arithmetic comparison) */
- | Ne /** != (arithmetic comparison) */
- | BAnd /** bitwise and */
- | BXor /** exclusive-or */
- | BOr /** inclusive-or */
- | LAnd /** logical and. Does not always evaluate both operands. */
- | LOr /** logical or. Does not always evaluate both operands. */
-[@@deriving compare];
-
-let equal: t => t => bool;
-
-
-/** This function returns true if the operation is injective
- wrt. each argument: op(e,-) and op(-, e) is injective for all e.
- The return value false means "don't know". */
-let injective: t => bool;
-
-
-/** This function returns true if the operation can be inverted. */
-let invertible: t => bool;
-
-
-/** This function inverts an invertible injective binary operator.
- If the [binop] operation is not invertible, the function raises Assert_failure. */
-let invert: t => t;
-
-
-/** This function returns true if 0 is the right unit of [binop].
- The return value false means "don't know". */
-let is_zero_runit: t => bool;
-
-
-/** String representation of a binary operator. */
-let str: Pp.env => t => string;
diff --git a/infer/src/IR/BuiltinDecl.ml b/infer/src/IR/BuiltinDecl.ml
index 088465727..6502f4d85 100644
--- a/infer/src/IR/BuiltinDecl.ml
+++ b/infer/src/IR/BuiltinDecl.ml
@@ -13,92 +13,160 @@ type t = Typ.Procname.t
let builtin_decls = ref Typ.Procname.Set.empty
-let register pname =
- builtin_decls := Typ.Procname.Set.add pname !builtin_decls
+let register pname = builtin_decls := Typ.Procname.Set.add pname !builtin_decls
let create_procname name =
let pname = Typ.Procname.from_string_c_fun name in
- register pname;
- pname
+ 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
- let pname = Typ.Procname.ObjC_Cpp
- (Typ.Procname.objc_cpp tname method_name method_kind Typ.NoTemplate ~is_generic_model:false) in
- register pname;
- pname
+ let pname =
+ Typ.Procname.ObjC_Cpp
+ (Typ.Procname.objc_cpp tname method_name method_kind Typ.NoTemplate ~is_generic_model:false)
+ in
+ register pname ; pname
let is_declared pname = Typ.Procname.Set.mem pname !builtin_decls
let __assert_fail = create_procname "__assert_fail"
+
let __builtin_va_arg = create_procname "__builtin_va_arg"
+
let __builtin_va_copy = create_procname "__builtin_va_copy"
+
let __builtin_va_end = create_procname "__builtin_va_end"
+
let __builtin_va_start = create_procname "__builtin_va_start"
+
let __cast = create_procname "__cast"
+
let __check_untainted = create_procname "__check_untainted"
+
let __cxx_typeid = create_procname "__cxx_typeid"
+
let __delete = create_procname "__delete"
+
let __delete_array = create_procname "__delete_array"
+
let __delete_locked_attribute = create_procname "__delete_locked_attribute"
+
let __exit = create_procname "_exit"
+
let __get_array_length = create_procname "__get_array_length"
+
let __get_hidden_field = create_procname "__get_hidden_field"
+
let __get_type_of = create_procname "__get_type_of"
+
let __infer_assume = create_procname "__infer_assume"
+
let __infer_fail = create_procname "__infer_fail"
+
let __instanceof = create_procname "__instanceof"
+
let __method_set_ignore_attribute = create_procname "__method_set_ignore_attribute"
+
let __new = create_procname "__new"
+
let __new_array = create_procname "__new_array"
+
let __objc_alloc = create_procname "__objc_alloc"
+
let __objc_alloc_no_fail = create_procname "__objc_alloc_no_fail"
+
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"
+
let __objc_release_cf = create_procname "__objc_release_cf"
+
let __objc_retain = create_procname "__objc_retain"
+
let __objc_retain_cf = create_procname "__objc_retain_cf"
+
let __placement_delete = create_procname "__placement_delete"
+
let __placement_new = create_procname "__placement_new"
+
let __print_value = create_procname "__print_value"
+
let __require_allocated_array = create_procname "__require_allocated_array"
+
let __set_array_length = create_procname "__set_array_length"
+
let __set_autorelease_attribute = create_procname "__set_autorelease_attribute"
+
let __set_file_attribute = create_procname "__set_file_attribute"
+
let __set_hidden_field = create_procname "__set_hidden_field"
+
let __set_lock_attribute = create_procname "__set_lock_attribute"
+
let __set_locked_attribute = create_procname "__set_locked_attribute"
+
let __set_mem_attribute = create_procname "__set_mem_attribute"
+
let __set_observer_attribute = create_procname "__set_observer_attribute"
+
let __set_taint_attribute = create_procname "__set_taint_attribute"
+
let __set_unlocked_attribute = create_procname "__set_unlocked_attribute"
+
let __set_unsubscribed_observer_attribute = create_procname "__set_unsubscribed_observer_attribute"
+
let __set_untaint_attribute = create_procname "__set_untaint_attribute"
+
let __split_get_nth = create_procname "__split_get_nth"
+
let __throw = create_procname "__throw"
+
let __unwrap_exception = create_procname "__unwrap_exception"
+
let abort = create_procname "abort"
+
let exit = create_procname "exit"
+
let free = create_procname "free"
+
let fscanf = create_procname "fscanf"
+
let fwscanf = create_procname "fwscanf"
+
let malloc = create_procname "malloc"
+
let malloc_no_fail = create_procname "malloc_no_fail"
+
let nsArray_arrayWithObjects = create_objc_class_method "NSArray" "arrayWithObjects:"
+
let nsArray_arrayWithObjectsCount = create_objc_class_method "NSArray" "arrayWithObjects:count:"
+
let objc_cpp_throw = create_procname "__infer_objc_cpp_throw"
+
let pthread_create = create_procname "pthread_create"
+
let scanf = create_procname "scanf"
+
let sscanf = create_procname "sscanf"
+
let swscanf = create_procname "swscanf"
+
let vfscanf = create_procname "vfscanf"
+
let vfwscanf = create_procname "vfwscanf"
+
let vscanf = create_procname "vscanf"
+
let vsscanf = create_procname "vsscanf"
+
let vswscanf = create_procname "vswscanf"
+
let vwscanf = create_procname "vwscanf"
+
let wscanf = create_procname "wscanf"
diff --git a/infer/src/IR/CallFlags.ml b/infer/src/IR/CallFlags.ml
new file mode 100644
index 000000000..8022a20cb
--- /dev/null
+++ b/infer/src/IR/CallFlags.ml
@@ -0,0 +1,34 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Call Flags *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** Flags for a procedure call *)
+type t =
+ { cf_virtual: bool
+ ; cf_interface: bool
+ ; cf_noreturn: bool
+ ; cf_is_objc_block: bool
+ ; cf_targets: Typ.Procname.t list }
+ [@@deriving compare]
+
+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= [] }
diff --git a/infer/src/IR/CallFlags.mli b/infer/src/IR/CallFlags.mli
new file mode 100644
index 000000000..f5b1f6356
--- /dev/null
+++ b/infer/src/IR/CallFlags.mli
@@ -0,0 +1,30 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Call Flags *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** Flags for a procedure call *)
+
+type t =
+ { cf_virtual: bool
+ ; cf_interface: bool
+ ; cf_noreturn: bool
+ ; cf_is_objc_block: bool
+ ; cf_targets: Typ.Procname.t list }
+ [@@deriving compare]
+
+val pp : F.formatter -> t -> unit
+
+(** Default value where all fields are set to false *)
+
+val default : t
diff --git a/infer/src/IR/CallFlags.re b/infer/src/IR/CallFlags.re
deleted file mode 100644
index c5cd07d32..000000000
--- a/infer/src/IR/CallFlags.re
+++ /dev/null
@@ -1,44 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Call Flags */
-module L = Logging;
-
-module F = Format;
-
-
-/** Flags for a procedure call */
-type t = {
- cf_virtual: bool,
- cf_interface: bool,
- cf_noreturn: bool,
- cf_is_objc_block: bool,
- cf_targets: list Typ.Procname.t
-}
-[@@deriving compare];
-
-let pp f cf => {
- if cf.cf_virtual {
- F.fprintf f " virtual"
- };
- if cf.cf_noreturn {
- F.fprintf f " noreturn"
- }
-};
-
-let default = {
- cf_virtual: false,
- cf_interface: false,
- cf_noreturn: false,
- cf_is_objc_block: false,
- cf_targets: []
-};
diff --git a/infer/src/IR/CallFlags.rei b/infer/src/IR/CallFlags.rei
deleted file mode 100644
index 68280e23b..000000000
--- a/infer/src/IR/CallFlags.rei
+++ /dev/null
@@ -1,33 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Call Flags */
-module L = Logging;
-
-module F = Format;
-
-
-/** Flags for a procedure call */
-type t = {
- cf_virtual: bool,
- cf_interface: bool,
- cf_noreturn: bool,
- cf_is_objc_block: bool,
- cf_targets: list Typ.Procname.t
-}
-[@@deriving compare];
-
-let pp: F.formatter => t => unit;
-
-
-/** Default value where all fields are set to false */
-let default: t;
diff --git a/infer/src/IR/CallSite.ml b/infer/src/IR/CallSite.ml
index 9598b85a4..c44785219 100644
--- a/infer/src/IR/CallSite.ml
+++ b/infer/src/IR/CallSite.ml
@@ -8,35 +8,26 @@
*)
open! IStd
-
module F = Format
-type t =
- {
- pname : Typ.Procname.t;
- loc : Location.t;
- }
-[@@deriving compare]
+type t = {pname: Typ.Procname.t; loc: Location.t} [@@deriving compare]
let equal = [%compare.equal : t]
-let pname t =
- t.pname
+let pname t = t.pname
+
+let loc t = t.loc
+
+let make pname loc = {pname; loc}
-let loc t =
- t.loc
+let dummy = make Typ.Procname.empty_block Location.dummy
-let make pname loc =
- { pname; loc; }
+let pp fmt t = F.fprintf fmt "%a at %a" Typ.Procname.pp t.pname Location.pp t.loc
-let dummy =
- make Typ.Procname.empty_block Location.dummy
+module Set = PrettyPrintable.MakePPSet (struct
+ type nonrec t = t
-let pp fmt t =
- F.fprintf fmt "%a at %a" Typ.Procname.pp t.pname Location.pp t.loc
+ let compare = compare
-module Set = PrettyPrintable.MakePPSet(struct
- type nonrec t = t
- let compare = compare
- let pp = pp
- end)
+ let pp = pp
+end)
diff --git a/infer/src/IR/CallSite.mli b/infer/src/IR/CallSite.mli
index 0bdb69eab..db5f48a69 100644
--- a/infer/src/IR/CallSite.mli
+++ b/infer/src/IR/CallSite.mli
@@ -8,7 +8,6 @@
*)
open! IStd
-
module F = Format
type t [@@deriving compare]
diff --git a/infer/src/IR/Cfg.ml b/infer/src/IR/Cfg.ml
new file mode 100644
index 000000000..79ba477b2
--- /dev/null
+++ b/infer/src/IR/Cfg.ml
@@ -0,0 +1,430 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** data type for the control flow graph *)
+type cfg = {proc_desc_table: (** Map proc name to procdesc *) Procdesc.t Typ.Procname.Hash.t}
+
+(** create a new empty cfg *)
+let create_cfg () = {proc_desc_table= Typ.Procname.Hash.create 16}
+
+let add_proc_desc cfg pname pdesc = Typ.Procname.Hash.add cfg.proc_desc_table pname pdesc
+
+let remove_proc_desc cfg pname = Typ.Procname.Hash.remove cfg.proc_desc_table pname
+
+let iter_proc_desc cfg f = Typ.Procname.Hash.iter f cfg.proc_desc_table
+
+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
+
+(** Iterate over all the nodes in the cfg *)
+let iter_all_nodes ?(sorted= false) f cfg =
+ let do_proc_desc _ (pdesc: Procdesc.t) =
+ List.iter ~f:(fun node -> f pdesc node) (Procdesc.get_nodes pdesc)
+ in
+ if not sorted then iter_proc_desc cfg do_proc_desc
+ else
+ Typ.Procname.Hash.fold
+ (fun _ pdesc desc_nodes ->
+ List.fold
+ ~f:(fun desc_nodes node -> (pdesc, node) :: desc_nodes)
+ ~init:desc_nodes (Procdesc.get_nodes pdesc))
+ cfg.proc_desc_table []
+ |> 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)
+
+(** checks whether a cfg is connected or not *)
+let check_cfg_connectedness cfg =
+ let is_exit_node n =
+ match Procdesc.Node.get_kind n with Procdesc.Node.Exit_node _ -> true | _ -> false
+ in
+ let broken_node n =
+ 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.Join_node ->
+ (* Join node has the exception that it may be without predecessors
+ and pointing to an exit node *)
+ (* if the if brances end with a return *)
+ match succs with [n'] when is_exit_node n' -> false | _ -> Int.equal (List.length preds) 0
+ in
+ let do_pdesc pd =
+ let pname = Typ.Procname.to_string (Procdesc.get_proc_name pd) in
+ let nodes = Procdesc.get_nodes pd in
+ let broken = List.exists ~f:broken_node nodes in
+ if broken then L.internal_error "@\n ***BROKEN CFG: '%s'@\n" pname
+ in
+ 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 =
+ let attributes = Procdesc.get_attributes pdesc in
+ let loc = attributes.loc in
+ let attributes' =
+ let loc' = if Location.equal loc Location.dummy then {loc with file= source_file} else loc in
+ {attributes with loc= loc'; source_file_captured= source_file}
+ in
+ AttributesTable.store_attributes attributes'
+ 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
+ let found instr instr' =
+ modified := Some instr' ;
+ L.(debug Analysis Verbose)
+ "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr Pp.text) instr ;
+ L.(debug Analysis Verbose)
+ "XX inline_synthetic_method instr': %a@." (Sil.pp_instr Pp.text) instr'
+ in
+ let do_instr _ instr =
+ 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
+ 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 *)
+ 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
+ found instr instr'
+ | Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _, _), _, [(e1, _)]
+ 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
+ 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 =
+ match List.rev etl with
+ (* remove last element *)
+ | _ :: 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
+
+(** 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
+ 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
+ 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 ;
+ instr'
+ in
+ let instrs = Procdesc.Node.get_instrs node in
+ let instrs' = List.map ~f:do_instr instrs in
+ if !modified then Procdesc.Node.replace_instrs node instrs'
+ 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) =
+ (* map of exp names in pd1 -> exp names in pd2 *)
+ let exp_map = ref Exp.Map.empty in
+ (* map of node id's in pd1 -> node id's in pd2 *)
+ let node_map = ref Procdesc.NodeMap.empty in
+ (* formals are the same if their types are the same *)
+ let formals_eq formals1 formals2 =
+ List.equal ~equal:(fun (_, typ1) (_, typ2) -> Typ.equal typ1 typ2) formals1 formals2
+ in
+ let nodes_eq n1s n2s =
+ (* nodes are the same if they have the same id, instructions, and succs/preds up to renaming
+ with [exp_map] and [id_map] *)
+ let node_eq (n1: Procdesc.Node.t) (n2: Procdesc.Node.t) =
+ let compare_id (n1: Procdesc.Node.t) (n2: Procdesc.Node.t) =
+ try
+ let n1_mapping = Procdesc.NodeMap.find n1 !node_map in
+ Procdesc.Node.compare n1_mapping n2
+ with Not_found ->
+ (* assume id's are equal and enforce by adding to [id_map] *)
+ node_map := Procdesc.NodeMap.add n1 n2 !node_map ;
+ 0
+ in
+ let instrs_eq instrs1 instrs2 =
+ List.equal
+ ~equal:(fun i1 i2 ->
+ let n, exp_map' = Sil.compare_structural_instr i1 i2 !exp_map in
+ exp_map := exp_map' ;
+ Int.equal n 0)
+ instrs1 instrs2
+ in
+ Int.equal (compare_id n1 n2) 0
+ && List.equal ~equal:Procdesc.Node.equal (Procdesc.Node.get_succs n1)
+ (Procdesc.Node.get_succs n2)
+ && List.equal ~equal:Procdesc.Node.equal (Procdesc.Node.get_preds n1)
+ (Procdesc.Node.get_preds n2)
+ && instrs_eq (Procdesc.Node.get_instrs n1) (Procdesc.Node.get_instrs n2)
+ in
+ try List.for_all2_exn ~f:node_eq n1s n2s
+ with Invalid_argument _ -> false
+ in
+ let att1 = Procdesc.get_attributes pd1 and att2 = Procdesc.get_attributes pd2 in
+ Bool.equal att1.is_defined att2.is_defined && Typ.equal att1.ret_type att2.ret_type
+ && formals_eq att1.formals att2.formals
+ && nodes_eq (Procdesc.get_nodes pd1) (Procdesc.get_nodes pd2)
+ in
+ let old_procs = cfg_old.proc_desc_table in
+ let new_procs = cfg_new.proc_desc_table in
+ let mark_pdesc_if_unchanged pname (new_pdesc: Procdesc.t) =
+ try
+ let old_pdesc = Typ.Procname.Hash.find old_procs pname in
+ let changed =
+ (* in continue_capture mode keep the old changed bit *)
+ Config.continue_capture && (Procdesc.get_attributes old_pdesc).changed
+ || not (pdescs_eq old_pdesc new_pdesc)
+ in
+ (Procdesc.get_attributes new_pdesc).changed <- changed
+ with Not_found -> ()
+ 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
+ -> () ) ;
+ (* 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
+
+(** clone a procedure description and apply the type substitutions where
+ the parameters are used *)
+let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
+ let resolved_pname = Procdesc.get_proc_name resolved_pdesc
+ and callee_start_node = Procdesc.get_start_node callee_pdesc
+ and callee_exit_node = Procdesc.get_exit_node callee_pdesc in
+ let convert_pvar pvar = Pvar.mk (Pvar.get_name pvar) resolved_pname in
+ let mk_ptr_typ typename =
+ (* Only consider pointers from Java objects for now *)
+ 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
+ in
+ let subst_map = ref Ident.IdentMap.empty in
+ let redirect_typename origin_id =
+ try Some (Ident.IdentMap.find origin_id !subst_map)
+ with Not_found -> None
+ in
+ let convert_instr instrs = function
+ | Sil.Load
+ ( id
+ , (Exp.Lvar origin_pvar as origin_exp)
+ , {Typ.desc= Tptr ({desc= Tstruct origin_typename}, Pk_pointer)}
+ , 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 =
+ 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.Store (convert_exp assignee_exp, origin_typ, convert_exp origin_exp, loc)
+ in
+ set_instr :: instrs
+ | Sil.Call
+ ( return_ids
+ , Exp.Const Const.Cfun Typ.Procname.Java callee_pname_java
+ , (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
+ let redirected_typ = mk_ptr_typ redirected_typename in
+ let redirected_pname =
+ Typ.Procname.replace_class (Typ.Procname.Java callee_pname_java) redirected_typename
+ in
+ let args =
+ let other_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in
+ (Exp.Var id, redirected_typ) :: other_args
+ in
+ let call_instr =
+ 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
+ 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 =
+ 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 *)
+ 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
+ in
+ let node_map = ref Procdesc.NodeMap.empty in
+ let rec convert_node node =
+ let loc = Procdesc.Node.get_loc node
+ and kind = convert_node_kind (Procdesc.Node.get_kind node)
+ and instrs = List.fold ~f:convert_instr ~init:[] (Procdesc.Node.get_instrs node) |> List.rev in
+ Procdesc.create_node resolved_pdesc loc kind instrs
+ and loop callee_nodes =
+ match callee_nodes with
+ | []
+ -> []
+ | node :: other_node
+ -> let converted_node =
+ try Procdesc.NodeMap.find node !node_map
+ with Not_found ->
+ let new_node = convert_node node
+ and successors = Procdesc.Node.get_succs node
+ and exn_nodes = Procdesc.Node.get_exn node in
+ node_map := Procdesc.NodeMap.add node new_node !node_map ;
+ if Procdesc.Node.equal node callee_start_node then
+ Procdesc.set_start_node resolved_pdesc new_node ;
+ if Procdesc.Node.equal node callee_exit_node then
+ Procdesc.set_exit_node resolved_pdesc new_node ;
+ Procdesc.node_set_succs_exn callee_pdesc new_node (loop successors) (loop exn_nodes) ;
+ new_node
+ in
+ converted_node :: loop other_node
+ in
+ 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.
+ The virtual calls are also replaced to match the parameter types *)
+let specialize_types callee_pdesc resolved_pname args =
+ let callee_attributes = Procdesc.get_attributes callee_pdesc in
+ let resolved_params, substitutions =
+ 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 *)
+ ((param_name, arg_typ) :: params, Mangled.Map.add param_name typename subts)
+ | _
+ -> ((param_name, param_typ) :: params, subts))
+ ~init:([], Mangled.Map.empty) callee_attributes.formals args
+ in
+ let resolved_attributes =
+ {callee_attributes with formals= List.rev resolved_params; proc_name= resolved_pname}
+ in
+ AttributesTable.store_attributes resolved_attributes ;
+ let resolved_pdesc =
+ let tmp_cfg = create_cfg () in
+ create_proc_desc tmp_cfg resolved_attributes
+ 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
diff --git a/infer/src/IR/Cfg.mli b/infer/src/IR/Cfg.mli
new file mode 100644
index 000000000..c1c451337
--- /dev/null
+++ b/infer/src/IR/Cfg.mli
@@ -0,0 +1,72 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+open! IStd
+
+(** Control Flow Graph for Interprocedural Analysis *)
+
+(** A control-flow graph *)
+
+type cfg
+
+(** Load a cfg from a file *)
+
+val load_cfg_from_file : DB.filename -> cfg option
+
+(** Save a cfg into a file, and save a copy of the source files if the boolean is true *)
+
+val store_cfg_to_file : source_file:SourceFile.t -> DB.filename -> cfg -> unit
+
+(** {2 Functions for manipulating an interprocedural CFG} *)
+
+(** create a new empty cfg *)
+
+val create_cfg : unit -> cfg
+
+(** Create a new procdesc *)
+
+val create_proc_desc : cfg -> ProcAttributes.t -> Procdesc.t
+
+(** Iterate over all the procdesc's *)
+
+val iter_proc_desc : cfg -> (Typ.Procname.t -> Procdesc.t -> unit) -> unit
+
+(** Find the procdesc given the proc name. Return None if not found. *)
+
+val find_proc_desc_from_name : cfg -> Typ.Procname.t -> Procdesc.t option
+
+(** Get all the procedures (defined and declared) *)
+
+val get_all_procs : cfg -> Procdesc.t list
+
+(** Get the procedures whose body is defined in this cfg *)
+
+val get_defined_procs : cfg -> Procdesc.t list
+
+(** Iterate over all the nodes in the cfg *)
+
+val iter_all_nodes : ?sorted:bool -> (Procdesc.t -> Procdesc.Node.t -> unit) -> cfg -> unit
+
+(** checks whether a cfg is connected or not *)
+
+val check_cfg_connectedness : cfg -> unit
+
+(** Remove the procdesc from the control flow graph. *)
+
+val remove_proc_desc : cfg -> Typ.Procname.t -> unit
+
+(** 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 procdesc is isomorphic but
+ all the type of the parameters are replaced in the instructions according to the list.
+ The virtual calls are also replaced to match the parameter types *)
+
+val specialize_types : Procdesc.t -> Typ.Procname.t -> (Exp.t * Typ.t) list -> Procdesc.t
+
+val pp_proc_signatures : Format.formatter -> cfg -> unit
diff --git a/infer/src/IR/Cfg.re b/infer/src/IR/Cfg.re
deleted file mode 100644
index b8ba58b0b..000000000
--- a/infer/src/IR/Cfg.re
+++ /dev/null
@@ -1,504 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module L = Logging;
-
-module F = Format;
-
-
-/** data type for the control flow graph */
-type cfg = {proc_desc_table: Typ.Procname.Hash.t Procdesc.t /** Map proc name to procdesc */};
-
-
-/** create a new empty cfg */
-let create_cfg () => {proc_desc_table: Typ.Procname.Hash.create 16};
-
-let add_proc_desc cfg pname pdesc => Typ.Procname.Hash.add cfg.proc_desc_table pname pdesc;
-
-let remove_proc_desc cfg pname => Typ.Procname.Hash.remove cfg.proc_desc_table pname;
-
-let iter_proc_desc cfg f => Typ.Procname.Hash.iter f cfg.proc_desc_table;
-
-let find_proc_desc_from_name cfg pname =>
- try (Some (Typ.Procname.Hash.find cfg.proc_desc_table pname)) {
- | 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;
- 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 => {
- let do_proc_desc _ (pdesc: Procdesc.t) =>
- List.iter f::(fun node => f pdesc node) (Procdesc.get_nodes pdesc);
- if (not sorted) {
- iter_proc_desc cfg do_proc_desc
- } else {
- Typ.Procname.Hash.fold
- (
- fun _ pdesc desc_nodes =>
- List.fold
- f::(fun desc_nodes node => [(pdesc, node), ...desc_nodes])
- init::desc_nodes
- (Procdesc.get_nodes pdesc)
- )
- cfg.proc_desc_table
- [] |>
- 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 [];
- let f _ pdesc => procs := [pdesc, ...!procs];
- 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);
-
-
-/** checks whether a cfg is connected or not */
-let check_cfg_connectedness cfg => {
- let is_exit_node n =>
- switch (Procdesc.Node.get_kind n) {
- | Procdesc.Node.Exit_node _ => true
- | _ => false
- };
- let broken_node n => {
- let succs = Procdesc.Node.get_succs n;
- let preds = Procdesc.Node.get_preds n;
- switch (Procdesc.Node.get_kind n) {
- | 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 */
- /* if the if brances end with a return */
- switch succs {
- | [n'] when is_exit_node n' => false
- | _ => Int.equal (List.length preds) 0
- }
- }
- };
- let do_pdesc pd => {
- let pname = Typ.Procname.to_string (Procdesc.get_proc_name pd);
- let nodes = Procdesc.get_nodes pd;
- let broken = List.exists f::broken_node nodes;
- if broken {
- L.internal_error "@\n ***BROKEN CFG: '%s'@\n" pname
- }
- };
- let pdescs = get_all_procs cfg;
- List.iter f::do_pdesc pdescs
-};
-
-
-/** Serializer for control flow graphs */
-let cfg_serializer: Serialization.serializer cfg =
- Serialization.create_serializer Serialization.Key.cfg;
-
-
-/** Load a cfg from a file */
-let load_cfg_from_file (filename: DB.filename) :option cfg =>
- 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 => {
- let attributes = Procdesc.get_attributes pdesc;
- let loc = attributes.loc;
- let attributes' = {
- let loc' =
- if (Location.equal loc Location.dummy) {
- {...loc, file: source_file}
- } else {
- loc
- };
- {...attributes, loc: loc', source_file_captured: source_file}
- };
- AttributesTable.store_attributes attributes'
- };
- 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 :option Sil.instr => {
- let modified = ref None;
- let found instr instr' => {
- modified := Some instr';
- L.(debug Analysis Verbose)
- "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr Pp.text) instr;
- L.(debug Analysis Verbose)
- "XX inline_synthetic_method instr': %a@." (Sil.pp_instr Pp.text) instr'
- };
- let do_instr _ instr =>
- switch (instr, ret_id, etl) {
- | (
- Sil.Load _ (Exp.Lfield (Exp.Var _) fn ft) bt _,
- Some (ret_id, _),
- [(e1, _)] /* getter for fields */
- ) =>
- let instr' = Sil.Load ret_id (Exp.Lfield e1 fn ft) bt loc_call;
- 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 */
- let instr' = Sil.Load ret_id (Exp.Lfield (Exp.Lvar pvar) fn ft) bt loc_call;
- found instr instr'
- | (Sil.Store (Exp.Lfield _ fn ft) bt _ _, _, [(e1, _), (e2, _)] /* setter for fields */) =>
- let instr' = Sil.Store (Exp.Lfield e1 fn ft) bt e2 loc_call;
- found instr instr'
- | (Sil.Store (Exp.Lfield (Exp.Lvar pvar) fn ft) bt _ _, _, [(e1, _)]) when Pvar.is_global pvar =>
- /* setter for static fields */
- let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar) fn ft) bt e1 loc_call;
- 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;
- 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 =
- switch (List.rev etl) {
- /* remove last element */
- | [_, ...l] => List.rev l
- | [] => assert false
- };
- let instr' = Sil.Call ret_id (Exp.Const (Const.Cfun pn)) etl1 loc_call cf;
- found instr instr'
- | _ => ()
- };
- 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 =
- fun
- | Sil.Call ret_id (Exp.Const (Const.Cfun pn)) etl loc _ =>
- switch (find_proc_desc_from_name cfg pn) {
- | Some pd =>
- let is_access = Typ.Procname.java_is_access_method pn;
- let attributes = Procdesc.get_attributes pd;
- let is_synthetic = attributes.is_synthetic_method;
- let is_bridge = attributes.is_bridge_method;
- if (is_access || is_bridge || is_synthetic) {
- inline_synthetic_method ret_id etl pd loc
- } else {
- None
- }
- | None => None
- }
- | _ => None;
- let node_inline_synthetic_methods node => {
- let modified = ref false;
- let do_instr instr =>
- switch (instr_inline_synthetic_method instr) {
- | None => instr
- | Some instr' =>
- modified := true;
- instr'
- };
- let instrs = Procdesc.Node.get_instrs node;
- let instrs' = List.map f::do_instr instrs;
- if !modified {
- Procdesc.Node.replace_instrs node instrs'
- }
- };
- 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) {
- proc_inline_synthetic_methods cfg pdesc
- };
- 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) => {
- /* map of exp names in pd1 -> exp names in pd2 */
- let exp_map = ref Exp.Map.empty;
- /* map of node id's in pd1 -> node id's in pd2 */
- let node_map = ref Procdesc.NodeMap.empty;
- /* formals are the same if their types are the same */
- let formals_eq formals1 formals2 =>
- List.equal equal::(fun (_, typ1) (_, typ2) => Typ.equal typ1 typ2) formals1 formals2;
- let nodes_eq n1s n2s => {
- /* nodes are the same if they have the same id, instructions, and succs/preds up to renaming
- with [exp_map] and [id_map] */
- let node_eq (n1: Procdesc.Node.t) (n2: Procdesc.Node.t) => {
- let compare_id (n1: Procdesc.Node.t) (n2: Procdesc.Node.t) =>
- try {
- let n1_mapping = Procdesc.NodeMap.find n1 !node_map;
- Procdesc.Node.compare n1_mapping n2
- } {
- | Not_found =>
- /* assume id's are equal and enforce by adding to [id_map] */
- node_map := Procdesc.NodeMap.add n1 n2 !node_map;
- 0
- };
- let instrs_eq instrs1 instrs2 =>
- List.equal
- equal::(
- fun i1 i2 => {
- let (n, exp_map') = Sil.compare_structural_instr i1 i2 !exp_map;
- exp_map := exp_map';
- Int.equal n 0
- }
- )
- instrs1
- instrs2;
- Int.equal (compare_id n1 n2) 0 &&
- List.equal
- equal::Procdesc.Node.equal (Procdesc.Node.get_succs n1) (Procdesc.Node.get_succs n2) &&
- List.equal
- equal::Procdesc.Node.equal (Procdesc.Node.get_preds n1) (Procdesc.Node.get_preds n2) &&
- instrs_eq (Procdesc.Node.get_instrs n1) (Procdesc.Node.get_instrs n2)
- };
- try (List.for_all2_exn f::node_eq n1s n2s) {
- | Invalid_argument _ => false
- }
- };
- let att1 = Procdesc.get_attributes pd1
- and att2 = Procdesc.get_attributes pd2;
- Bool.equal att1.is_defined att2.is_defined &&
- Typ.equal att1.ret_type att2.ret_type &&
- formals_eq att1.formals att2.formals &&
- nodes_eq (Procdesc.get_nodes pd1) (Procdesc.get_nodes pd2)
- };
- let old_procs = cfg_old.proc_desc_table;
- let new_procs = cfg_new.proc_desc_table;
- let mark_pdesc_if_unchanged pname (new_pdesc: Procdesc.t) =>
- try {
- let old_pdesc = Typ.Procname.Hash.find old_procs pname;
- let changed =
- /* in continue_capture mode keep the old changed bit */
- Config.continue_capture && (Procdesc.get_attributes old_pdesc).changed ||
- not (pdescs_eq old_pdesc new_pdesc);
- (Procdesc.get_attributes new_pdesc).changed = changed
- } {
- | Not_found => ()
- };
- 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 {
- switch (load_cfg_from_file filename) {
- | 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
-};
-
-
-/** clone a procedure description and apply the type substitutions where
- the parameters are used */
-let specialize_types_proc callee_pdesc resolved_pdesc substitutions => {
- let resolved_pname = Procdesc.get_proc_name resolved_pdesc
- and callee_start_node = Procdesc.get_start_node callee_pdesc
- and callee_exit_node = Procdesc.get_exit_node callee_pdesc;
- let convert_pvar pvar => Pvar.mk (Pvar.get_name pvar) resolved_pname;
- let mk_ptr_typ typename =>
- /* Only consider pointers from Java objects for now */
- Typ.mk (Tptr (Typ.mk (Tstruct typename)) Typ.Pk_pointer);
- let convert_exp =
- fun
- | Exp.Lvar origin_pvar => Exp.Lvar (convert_pvar origin_pvar)
- | exp => exp;
- let subst_map = ref Ident.IdentMap.empty;
- let redirect_typename origin_id =>
- try (Some (Ident.IdentMap.find origin_id !subst_map)) {
- | Not_found => None
- };
- let convert_instr instrs =>
- fun
- | Sil.Load
- id
- (Exp.Lvar origin_pvar as origin_exp)
- {Typ.desc: Tptr {desc: Tstruct origin_typename} Pk_pointer}
- loc => {
- let specialized_typname =
- try (Mangled.Map.find (Pvar.get_name origin_pvar) substitutions) {
- | Not_found => origin_typename
- };
- 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 =
- try (Typ.mk default::origin_typ (Tstruct (Ident.IdentMap.find origin_id !subst_map))) {
- | Not_found => origin_typ
- };
- [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.Store (convert_exp assignee_exp) origin_typ (convert_exp origin_exp) loc;
- [set_instr, ...instrs]
- }
- | Sil.Call
- return_ids
- (Exp.Const (Const.Cfun (Typ.Procname.Java callee_pname_java)))
- [(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);
- let redirected_typ = mk_ptr_typ redirected_typename;
- let redirected_pname =
- Typ.Procname.replace_class (Typ.Procname.Java callee_pname_java) redirected_typename;
- let args = {
- let other_args = List.map f::(fun (exp, typ) => (convert_exp exp, typ)) origin_args;
- [(Exp.Var id, redirected_typ), ...other_args]
- };
- let call_instr =
- Sil.Call return_ids (Exp.Const (Const.Cfun redirected_pname)) args loc call_flags;
- [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;
- let call_instr =
- Sil.Call return_ids (convert_exp origin_call_exp) converted_args loc call_flags;
- [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 = List.map f::(fun (pvar, typ) => (convert_pvar pvar, typ)) typed_vars;
- [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 */
- instrs;
- let convert_node_kind =
- fun
- | Procdesc.Node.Start_node _ => Procdesc.Node.Start_node resolved_pname
- | Procdesc.Node.Exit_node _ => Procdesc.Node.Exit_node resolved_pname
- | node_kind => node_kind;
- let node_map = ref Procdesc.NodeMap.empty;
- let rec convert_node node => {
- let loc = Procdesc.Node.get_loc node
- and kind = convert_node_kind (Procdesc.Node.get_kind node)
- and instrs = List.fold f::convert_instr init::[] (Procdesc.Node.get_instrs node) |> List.rev;
- Procdesc.create_node resolved_pdesc loc kind instrs
- }
- and loop callee_nodes =>
- switch callee_nodes {
- | [] => []
- | [node, ...other_node] =>
- let converted_node =
- try (Procdesc.NodeMap.find node !node_map) {
- | Not_found =>
- let new_node = convert_node node
- and successors = Procdesc.Node.get_succs node
- and exn_nodes = Procdesc.Node.get_exn node;
- node_map := Procdesc.NodeMap.add node new_node !node_map;
- if (Procdesc.Node.equal node callee_start_node) {
- Procdesc.set_start_node resolved_pdesc new_node
- };
- if (Procdesc.Node.equal node callee_exit_node) {
- Procdesc.set_exit_node resolved_pdesc new_node
- };
- Procdesc.node_set_succs_exn callee_pdesc new_node (loop successors) (loop exn_nodes);
- new_node
- };
- [converted_node, ...loop other_node]
- };
- 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.
- The virtual calls are also replaced to match the parameter types */
-let specialize_types callee_pdesc resolved_pname args => {
- let callee_attributes = Procdesc.get_attributes callee_pdesc;
- let (resolved_params, substitutions) =
- List.fold2_exn
- f::(
- fun (params, subts) (param_name, param_typ) (_, arg_typ) =>
- switch arg_typ.Typ.desc {
- | 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)
- }
- )
- init::([], Mangled.Map.empty)
- callee_attributes.formals
- args;
- let resolved_attributes = {
- ...callee_attributes,
- formals: List.rev resolved_params,
- proc_name: resolved_pname
- };
- AttributesTable.store_attributes resolved_attributes;
- let resolved_pdesc = {
- let tmp_cfg = create_cfg ();
- create_proc_desc tmp_cfg resolved_attributes
- };
- 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);
- List.iter f::(fun pdesc => F.fprintf fmt "%a@." Procdesc.pp_signature pdesc) sorted_procs
-};
diff --git a/infer/src/IR/Cfg.rei b/infer/src/IR/Cfg.rei
deleted file mode 100644
index 5fdfa5f9c..000000000
--- a/infer/src/IR/Cfg.rei
+++ /dev/null
@@ -1,71 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** Control Flow Graph for Interprocedural Analysis */
-
-/** A control-flow graph */
-type cfg;
-
-
-/** Load a cfg from a file */
-let load_cfg_from_file: DB.filename => option cfg;
-
-
-/** Save a cfg into a file, and save a copy of the source files if the boolean is true */
-let store_cfg_to_file: source_file::SourceFile.t => DB.filename => cfg => unit;
-
-
-/** {2 Functions for manipulating an interprocedural CFG} */
-
-/** create a new empty cfg */
-let create_cfg: unit => cfg;
-
-
-/** Create a new procdesc */
-let create_proc_desc: cfg => ProcAttributes.t => Procdesc.t;
-
-
-/** Iterate over all the procdesc's */
-let iter_proc_desc: cfg => (Typ.Procname.t => Procdesc.t => unit) => unit;
-
-
-/** Find the procdesc given the proc name. Return None if not found. */
-let find_proc_desc_from_name: cfg => Typ.Procname.t => option Procdesc.t;
-
-
-/** Get all the procedures (defined and declared) */
-let get_all_procs: cfg => list Procdesc.t;
-
-
-/** Get the procedures whose body is defined in this cfg */
-let get_defined_procs: cfg => list Procdesc.t;
-
-
-/** Iterate over all the nodes in the cfg */
-let iter_all_nodes: sorted::bool? => (Procdesc.t => Procdesc.Node.t => unit) => cfg => unit;
-
-
-/** checks whether a cfg is connected or not */
-let check_cfg_connectedness: cfg => unit;
-
-
-/** Remove the procdesc from the control flow graph. */
-let remove_proc_desc: cfg => Typ.Procname.t => unit;
-
-
-/** 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 procdesc is isomorphic but
- all the type of the parameters are replaced in the instructions according to the list.
- The virtual calls are also replaced to match the parameter types */
-let specialize_types: Procdesc.t => Typ.Procname.t => list (Exp.t, Typ.t) => Procdesc.t;
-
-let pp_proc_signatures: Format.formatter => cfg => unit;
diff --git a/infer/src/IR/Cg.ml b/infer/src/IR/Cg.ml
new file mode 100644
index 000000000..3eead6706
--- /dev/null
+++ b/infer/src/IR/Cg.ml
@@ -0,0 +1,312 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** Module for call graphs *)
+open! IStd
+module Hashtbl = Caml.Hashtbl
+module L = Logging
+module F = Format
+
+type node = Typ.Procname.t
+
+type in_out_calls =
+ { in_calls: int (** total number of in calls transitively *)
+ ; out_calls: int (** total number of out calls transitively *) }
+
+type node_info =
+ { (** defined procedure as opposed to just declared *)
+ mutable defined: bool
+ ; mutable parents: Typ.Procname.Set.t
+ ; mutable children: Typ.Procname.Set.t (** ancestors are computed lazily *)
+ ; mutable ancestors: Typ.Procname.Set.t option (** heirs are computed lazily *)
+ ; mutable heirs: Typ.Procname.Set.t option (** recursive dependents are computed lazily *)
+ ; mutable recursive_dependents: Typ.Procname.Set.t option (** calls are computed lazily *)
+ ; mutable in_out_calls: in_out_calls option }
+
+(** Type for call graph *)
+type t =
+ { source: SourceFile.t (** path for the source file *)
+ ; node_map: (** map from node to node_info *) node_info Typ.Procname.Hash.t }
+
+let create source = {source; node_map= Typ.Procname.Hash.create 3}
+
+let add_node g n ~defined =
+ try
+ let info = Typ.Procname.Hash.find g.node_map n in
+ (* defined and disabled only go from false to true
+ to avoid accidental overwrite to false by calling add_edge *)
+ if defined then info.defined <- true
+ with Not_found ->
+ let info =
+ { defined
+ ; parents= Typ.Procname.Set.empty
+ ; children= Typ.Procname.Set.empty
+ ; ancestors= None
+ ; heirs= None
+ ; recursive_dependents= None
+ ; in_out_calls= None }
+ 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 *)
+let compute_ancestors g node =
+ let todo = ref (Typ.Procname.Set.singleton node) in
+ let seen = ref Typ.Procname.Set.empty in
+ let result = ref Typ.Procname.Set.empty in
+ while not (Typ.Procname.Set.is_empty !todo) do
+ let current = Typ.Procname.Set.choose !todo in
+ todo := Typ.Procname.Set.remove current !todo ;
+ if not (Typ.Procname.Set.mem current !seen) then (
+ 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 ;
+ 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
+ let seen = ref Typ.Procname.Set.empty in
+ let result = ref Typ.Procname.Set.empty in
+ while not (Typ.Procname.Set.is_empty !todo) do
+ let current = Typ.Procname.Set.choose !todo in
+ todo := Typ.Procname.Set.remove current !todo ;
+ if not (Typ.Procname.Set.mem current !seen) then (
+ 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 ;
+ 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
+ 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
+
+(** 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
+ 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
+
+let node_defined (g: t) n =
+ try
+ let info = Typ.Procname.Hash.find g.node_map n in
+ info.defined
+ with Not_found -> false
+
+let add_edge g nfrom nto =
+ add_node g nfrom ~defined:false ;
+ add_node g nto ~defined:false ;
+ let info_from = Typ.Procname.Hash.find g.node_map nfrom in
+ let info_to = Typ.Procname.Hash.find g.node_map nto in
+ 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
+ Typ.Procname.Hash.iter (fun node info -> table := (node, info) :: !table) g.node_map ;
+ 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
+ info.in_out_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))
+
+let get_edges (g: t) : ((node * int) * (node * int)) list =
+ let edges = ref [] in
+ let f node info =
+ Typ.Procname.Set.iter
+ (fun nto -> edges := (node_get_num_ancestors g node, node_get_num_ancestors g nto) :: !edges)
+ info.children
+ 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
+
+(** Return the children of [n] which are defined *)
+let get_defined_children (g: t) n = Typ.Procname.Set.filter (node_defined g) (get_all_children g n)
+
+(** Return the parents of [n] *)
+let get_parents (g: t) n = (Typ.Procname.Hash.find g.node_map n).parents
+
+(** Check if [source] recursively calls [dest] *)
+let calls_recursively (g: t) source dest = Typ.Procname.Set.mem source (get_ancestors g dest)
+
+(** Return the children of [n] which are not heirs of [n] *)
+let get_nonrecursive_dependents (g: t) n =
+ let is_not_recursive pn = not (Typ.Procname.Set.mem pn (get_ancestors g n)) in
+ let res0 = Typ.Procname.Set.filter is_not_recursive (get_all_children g n) in
+ 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
+ let res0 = Typ.Procname.Set.filter reached_from_n (get_ancestors g n) in
+ 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
+ info.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
+ node_map_iter (fun n info -> if info.defined then nodes := Typ.Procname.Set.add n !nodes) g ;
+ 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
+
+(** Return the list of nodes, with defined+disabled flags, and the list of edges *)
+let get_nodes_and_edges (g: t) : nodes_and_edges =
+ let nodes = ref [] in
+ let edges = ref [] in
+ let do_children node nto = edges := (node, nto) :: !edges in
+ let f node info =
+ nodes := (node, info.defined) :: !nodes ;
+ Typ.Procname.Set.iter (do_children node) info.children
+ 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
+
+(** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2];
+ undefined nodes become defined if at least one side is. *)
+let extend cg_old cg_new =
+ let nodes, edges = get_nodes_and_edges cg_new in
+ 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
+ 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
+ let pp_node fmt (n, _) = F.fprintf fmt "\"%s\"" (Typ.Procname.to_filename n) in
+ let pp_node_label fmt (n, calls) =
+ F.fprintf fmt "\"%a | calls=%d %d)\"" Typ.Procname.pp n calls.in_calls calls.out_calls
+ in
+ F.fprintf fmt "digraph {@\n" ;
+ List.iter
+ ~f:(fun nc ->
+ F.fprintf fmt "%a [shape=box,label=%a,color=%s,shape=%s]@\n" pp_node nc pp_node_label nc
+ "red" (get_shape nc))
+ nodes_with_calls ;
+ 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 =
+ DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) ["call_graph.dot"]
+ in
+ 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
diff --git a/infer/src/IR/Cg.mli b/infer/src/IR/Cg.mli
new file mode 100644
index 000000000..86ee4e2d2
--- /dev/null
+++ b/infer/src/IR/Cg.mli
@@ -0,0 +1,127 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+open! IStd
+
+(** Module for call graphs *)
+
+type in_out_calls =
+ { in_calls: int (** total number of in calls transitively *)
+ ; out_calls: int (** total number of out calls transitively *) }
+
+type t
+
+(** the type of a call graph *)
+
+(** A call graph consists of a set of nodes (Typ.Procname.t), and edges between them.
+ A node can be defined or undefined (to represent whether we have code for it).
+ In an edge from [n1] to [n2], indicating that [n1] calls [n2],
+ [n1] is the parent and [n2] is the child.
+ Node [n1] is dependent on [n2] if there is a path from [n1] to [n2]
+ using the child relationship. *)
+
+(** [add_edge cg f t] adds an edge from [f] to [t] in the call graph [cg].
+ The nodes are also added as undefined, unless already present. *)
+
+val add_edge : t -> Typ.Procname.t -> Typ.Procname.t -> unit
+
+(** Add a node to the call graph as defined *)
+
+val add_defined_node : t -> Typ.Procname.t -> unit
+
+(** Check if [source] recursively calls [dest] *)
+
+val calls_recursively : t -> Typ.Procname.t -> Typ.Procname.t -> bool
+
+(** Create an empty call graph *)
+
+val create : SourceFile.t -> t
+
+(** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2];
+ undefined nodes become defined if at least one side is. *)
+
+val extend : t -> t -> unit
+
+(** Return all the children of [n], whether defined or not *)
+
+val get_all_children : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Compute the ancestors of the node, if not pre-computed already *)
+
+val get_ancestors : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Compute the heirs of the node, if not pre-computed already *)
+
+val get_heirs : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the in/out calls of the node *)
+
+val get_calls : t -> Typ.Procname.t -> in_out_calls
+
+(** Return the list of nodes which are defined *)
+
+val get_defined_nodes : t -> Typ.Procname.t list
+
+(** Return the children of [n] which are defined *)
+
+val get_defined_children : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the nodes dependent on [n] *)
+
+val get_dependents : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the list of nodes with calls *)
+
+val get_nodes_and_calls : t -> (Typ.Procname.t * in_out_calls) list
+
+(** Return all the nodes with their defined children *)
+
+val get_nodes_and_defined_children : t -> (Typ.Procname.t * Typ.Procname.Set.t) list
+
+(** Return the list of nodes, with defined flag, and the list of edges *)
+
+val get_nodes_and_edges :
+ t -> (Typ.Procname.t * bool) list * (Typ.Procname.t * Typ.Procname.t) list
+
+(** Return the children of [n] which are not heirs of [n] and are defined *)
+
+val get_nonrecursive_dependents : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the parents of [n] *)
+
+val get_parents : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the ancestors of [n] which are also heirs of [n] *)
+
+val get_recursive_dependents : t -> Typ.Procname.t -> Typ.Procname.Set.t
+
+(** Return the path of the source file *)
+
+val get_source : t -> SourceFile.t
+
+(** Load a call graph from a file *)
+
+val load_from_file : DB.filename -> t option
+
+(** Returns true if the node is defined *)
+
+val node_defined : t -> Typ.Procname.t -> bool
+
+(** Remove the defined flag from a node, if it exists. *)
+
+val remove_node_defined : t -> Typ.Procname.t -> unit
+
+(** Print the call graph as a dotty file. *)
+
+val save_call_graph_dotty : SourceFile.t -> t -> unit
+
+(** Save a call graph into a file *)
+
+val store_to_file : DB.filename -> t -> unit
diff --git a/infer/src/IR/Cg.re b/infer/src/IR/Cg.re
deleted file mode 100644
index e2185bf61..000000000
--- a/infer/src/IR/Cg.re
+++ /dev/null
@@ -1,414 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module Hashtbl = Caml.Hashtbl;
-
-
-/** Module for call graphs */
-module L = Logging;
-
-module F = Format;
-
-type node = Typ.Procname.t;
-
-type in_out_calls = {
- in_calls: int, /** total number of in calls transitively */
- out_calls: int /** total number of out calls transitively */
-};
-
-type node_info = {
- /** defined procedure as opposed to just declared */
- mutable defined: bool,
- mutable parents: Typ.Procname.Set.t,
- mutable children: Typ.Procname.Set.t,
- /** ancestors are computed lazily */
- mutable ancestors: option Typ.Procname.Set.t,
- /** heirs are computed lazily */
- mutable heirs: option Typ.Procname.Set.t,
- /** recursive dependents are computed lazily */
- mutable recursive_dependents: option Typ.Procname.Set.t,
- /** calls are computed lazily */
- mutable in_out_calls: option in_out_calls
-};
-
-
-/** Type for call graph */
-type t = {
- source: SourceFile.t, /** path for the source file */
- node_map: Typ.Procname.Hash.t node_info /** map from node to node_info */
-};
-
-let create source => {source, node_map: Typ.Procname.Hash.create 3};
-
-let add_node g n ::defined =>
- try {
- let info = Typ.Procname.Hash.find g.node_map n;
- /* defined and disabled only go from false to true
- to avoid accidental overwrite to false by calling add_edge */
- if defined {
- info.defined = true
- }
- } {
- | Not_found =>
- let info = {
- defined,
- parents: Typ.Procname.Set.empty,
- children: Typ.Procname.Set.empty,
- ancestors: None,
- heirs: None,
- recursive_dependents: None,
- in_out_calls: None
- };
- 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;
- info.defined = false
- } {
- | Not_found => ()
- };
-
-let add_defined_node g n => add_node g n defined::true;
-
-
-/** Compute the ancestors of the node, if not already computed */
-let compute_ancestors g node => {
- let todo = ref (Typ.Procname.Set.singleton node);
- let seen = ref Typ.Procname.Set.empty;
- let result = ref Typ.Procname.Set.empty;
- while (not (Typ.Procname.Set.is_empty !todo)) {
- let current = Typ.Procname.Set.choose !todo;
- todo := Typ.Procname.Set.remove current !todo;
- if (not (Typ.Procname.Set.mem current !seen)) {
- seen := Typ.Procname.Set.add current !seen;
- let info = Typ.Procname.Hash.find g current;
- switch info.ancestors {
- | 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
- }
- }
- };
- !result
-};
-
-
-/** Compute the heirs of the node, if not already computed */
-let compute_heirs g node => {
- let todo = ref (Typ.Procname.Set.singleton node);
- let seen = ref Typ.Procname.Set.empty;
- let result = ref Typ.Procname.Set.empty;
- while (not (Typ.Procname.Set.is_empty !todo)) {
- let current = Typ.Procname.Set.choose !todo;
- todo := Typ.Procname.Set.remove current !todo;
- if (not (Typ.Procname.Set.mem current !seen)) {
- seen := Typ.Procname.Set.add current !seen;
- let info = Typ.Procname.Hash.find g current;
- switch info.heirs {
- | 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
- }
- }
- };
- !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;
- switch info.ancestors {
- | None =>
- let ancestors = compute_ancestors g.node_map node;
- info.ancestors = Some ancestors;
- let size = Typ.Procname.Set.cardinal ancestors;
- if (size > 1000) {
- L.(debug Analysis Medium) "%a has %d ancestors@." Typ.Procname.pp node size
- };
- 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;
- switch info.heirs {
- | None =>
- let heirs = compute_heirs g.node_map node;
- info.heirs = Some heirs;
- let size = Typ.Procname.Set.cardinal heirs;
- if (size > 1000) {
- L.(debug Analysis Medium) "%a has %d heirs@." Typ.Procname.pp node size
- };
- heirs
- | Some heirs => heirs
- }
-};
-
-let node_defined (g: t) n =>
- try {
- let info = Typ.Procname.Hash.find g.node_map n;
- info.defined
- } {
- | Not_found => false
- };
-
-let add_edge g nfrom nto => {
- add_node g nfrom defined::false;
- add_node g nto defined::false;
- let info_from = Typ.Procname.Hash.find g.node_map nfrom;
- let info_to = Typ.Procname.Hash.find g.node_map 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 [];
- Typ.Procname.Hash.iter (fun node info => table := [(node, info), ...!table]) g.node_map;
- let cmp (n1: Typ.Procname.t, _) (n2: Typ.Procname.t, _) => Typ.Procname.compare n1 n2;
- 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;
- let f node _ => nodes := Typ.Procname.Set.add node !nodes;
- 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;
- switch info.in_out_calls {
- | None =>
- let calls = compute_calls g node;
- info.in_out_calls = Some calls;
- calls
- | Some calls => calls
- }
-};
-
-let get_all_nodes (g: t) => {
- let nodes = Typ.Procname.Set.elements (get_nodes g);
- 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));
-
-let get_edges (g: t) :list ((node, int), (node, int)) => {
- let edges = ref [];
- let f node info =>
- Typ.Procname.Set.iter
- (
- fun nto =>
- edges := [(node_get_num_ancestors g node, node_get_num_ancestors g nto), ...!edges]
- )
- info.children;
- 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;
-
-
-/** Return the children of [n] which are defined */
-let get_defined_children (g: t) n =>
- Typ.Procname.Set.filter (node_defined g) (get_all_children g n);
-
-
-/** Return the parents of [n] */
-let get_parents (g: t) n => (Typ.Procname.Hash.find g.node_map n).parents;
-
-
-/** Check if [source] recursively calls [dest] */
-let calls_recursively (g: t) source dest => Typ.Procname.Set.mem source (get_ancestors g dest);
-
-
-/** Return the children of [n] which are not heirs of [n] */
-let get_nonrecursive_dependents (g: t) n => {
- let is_not_recursive pn => not (Typ.Procname.Set.mem pn (get_ancestors g n));
- let res0 = Typ.Procname.Set.filter is_not_recursive (get_all_children g n);
- let res = Typ.Procname.Set.filter (node_defined g) res0;
- 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);
- let res0 = Typ.Procname.Set.filter reached_from_n (get_ancestors g n);
- let res = Typ.Procname.Set.filter (node_defined g) res0;
- 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;
- switch info.recursive_dependents {
- | None =>
- let recursive_dependents = compute_recursive_dependents g n;
- info.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;
- node_map_iter
- (
- fun n info =>
- if info.defined {
- nodes := Typ.Procname.Set.add n !nodes
- }
- )
- g;
- let nodes_list = Typ.Procname.Set.elements !nodes;
- List.map f::(fun n => (n, get_defined_children g n)) nodes_list
-};
-
-
-/** nodes with defined flag, and edges */
-type nodes_and_edges = (list (node, bool), list (node, node));
-
-
-/** Return the list of nodes, with defined+disabled flags, and the list of edges */
-let get_nodes_and_edges (g: t) :nodes_and_edges => {
- let nodes = ref [];
- let edges = ref [];
- let do_children node nto => edges := [(node, nto), ...!edges];
- let f node info => {
- nodes := [(node, info.defined), ...!nodes];
- Typ.Procname.Set.iter (do_children node) info.children
- };
- 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;
- let get_node (node, _) => node;
- 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;
-
-
-/** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2];
- undefined nodes become defined if at least one side is. */
-let extend cg_old cg_new => {
- let (nodes, edges) = get_nodes_and_edges 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: Serialization.serializer (SourceFile.t, nodes_and_edges) =
- Serialization.create_serializer Serialization.Key.cg;
-
-
-/** Load a call graph from a file */
-let load_from_file (filename: DB.filename) :option t =>
- switch (Serialization.read_from_file callgraph_serializer filename) {
- | None => None
- | Some (source, (nodes, edges)) =>
- let g = create source;
- List.iter
- f::(
- fun (node, defined) =>
- if defined {
- 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;
- let get_shape (n, _) =>
- if (node_defined g n) {
- "box"
- } else {
- "diamond"
- };
- let pp_node fmt (n, _) => F.fprintf fmt "\"%s\"" (Typ.Procname.to_filename n);
- let pp_node_label fmt (n, calls) =>
- F.fprintf fmt "\"%a | calls=%d %d)\"" Typ.Procname.pp n calls.in_calls calls.out_calls;
- F.fprintf fmt "digraph {@\n";
- List.iter
- f::(
- fun nc =>
- F.fprintf
- fmt
- "%a [shape=box,label=%a,color=%s,shape=%s]@\n"
- pp_node
- nc
- pp_node_label
- nc
- "red"
- (get_shape nc)
- )
- nodes_with_calls;
- 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 =
- DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) ["call_graph.dot"];
- let outc = Out_channel.create (DB.filename_to_string fname_dot);
- let fmt = F.formatter_of_out_channel outc;
- pp_graph_dotty g fmt;
- Out_channel.close outc
-};
diff --git a/infer/src/IR/Cg.rei b/infer/src/IR/Cg.rei
deleted file mode 100644
index 4f55b3ec4..000000000
--- a/infer/src/IR/Cg.rei
+++ /dev/null
@@ -1,124 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** Module for call graphs */
-type in_out_calls = {
- in_calls: int, /** total number of in calls transitively */
- out_calls: int /** total number of out calls transitively */
-};
-
-type t; /** the type of a call graph */
-
-
-/** A call graph consists of a set of nodes (Typ.Procname.t), and edges between them.
- A node can be defined or undefined (to represent whether we have code for it).
- In an edge from [n1] to [n2], indicating that [n1] calls [n2],
- [n1] is the parent and [n2] is the child.
- Node [n1] is dependent on [n2] if there is a path from [n1] to [n2]
- using the child relationship. */
-
-/** [add_edge cg f t] adds an edge from [f] to [t] in the call graph [cg].
- The nodes are also added as undefined, unless already present. */
-let add_edge: t => Typ.Procname.t => Typ.Procname.t => unit;
-
-
-/** Add a node to the call graph as defined */
-let add_defined_node: t => Typ.Procname.t => unit;
-
-
-/** Check if [source] recursively calls [dest] */
-let calls_recursively: t => Typ.Procname.t => Typ.Procname.t => bool;
-
-
-/** Create an empty call graph */
-let create: SourceFile.t => t;
-
-
-/** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2];
- undefined nodes become defined if at least one side is. */
-let extend: t => t => unit;
-
-
-/** Return all the children of [n], whether defined or not */
-let get_all_children: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Compute the ancestors of the node, if not pre-computed already */
-let get_ancestors: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Compute the heirs of the node, if not pre-computed already */
-let get_heirs: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the in/out calls of the node */
-let get_calls: t => Typ.Procname.t => in_out_calls;
-
-
-/** Return the list of nodes which are defined */
-let get_defined_nodes: t => list Typ.Procname.t;
-
-
-/** Return the children of [n] which are defined */
-let get_defined_children: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the nodes dependent on [n] */
-let get_dependents: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the list of nodes with calls */
-let get_nodes_and_calls: t => list (Typ.Procname.t, in_out_calls);
-
-
-/** Return all the nodes with their defined children */
-let get_nodes_and_defined_children: t => list (Typ.Procname.t, Typ.Procname.Set.t);
-
-
-/** Return the list of nodes, with defined flag, and the list of edges */
-let get_nodes_and_edges: t => (list (Typ.Procname.t, bool), list (Typ.Procname.t, Typ.Procname.t));
-
-
-/** Return the children of [n] which are not heirs of [n] and are defined */
-let get_nonrecursive_dependents: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the parents of [n] */
-let get_parents: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the ancestors of [n] which are also heirs of [n] */
-let get_recursive_dependents: t => Typ.Procname.t => Typ.Procname.Set.t;
-
-
-/** Return the path of the source file */
-let get_source: t => SourceFile.t;
-
-
-/** Load a call graph from a file */
-let load_from_file: DB.filename => option t;
-
-
-/** Returns true if the node is defined */
-let node_defined: t => Typ.Procname.t => bool;
-
-
-/** Remove the defined flag from a node, if it exists. */
-let remove_node_defined: t => Typ.Procname.t => unit;
-
-
-/** Print the call graph as a dotty file. */
-let save_call_graph_dotty: SourceFile.t => t => unit;
-
-
-/** Save a call graph into a file */
-let store_to_file: DB.filename => t => unit;
diff --git a/infer/src/IR/Const.ml b/infer/src/IR/Const.ml
new file mode 100644
index 000000000..90b177f5b
--- /dev/null
+++ b/infer/src/IR/Const.ml
@@ -0,0 +1,69 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Constants *)
+open! IStd
+module L = Logging
+module F = Format
+
+type t =
+ | Cint of IntLit.t (** integer constants *)
+ | Cfun of Typ.Procname.t (** function names *)
+ | Cstr of string (** string constants *)
+ | Cfloat of float (** float constants *)
+ | Cclass of Ident.name (** class constant *)
+ [@@deriving compare]
+
+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
+ in
+ Int.equal (const_kind_number c1) (const_kind_number c2)
+
+let pp pe f = function
+ | 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
+
+let to_string c = F.asprintf "%a" (pp Pp.text) c
+
+let iszero_int_float = function Cint i -> IntLit.iszero i | Cfloat 0.0 -> true | _ -> false
+
+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
diff --git a/infer/src/IR/Const.mli b/infer/src/IR/Const.mli
new file mode 100644
index 000000000..1b53b8b33
--- /dev/null
+++ b/infer/src/IR/Const.mli
@@ -0,0 +1,42 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Constants *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** Constants *)
+
+type t =
+ | Cint of IntLit.t (** integer constants *)
+ | Cfun of Typ.Procname.t (** function names *)
+ | Cstr of string (** string constants *)
+ | Cfloat of float (** float constants *)
+ | Cclass of Ident.name (** class constant *)
+ [@@deriving compare]
+
+val equal : t -> t -> bool
+
+(** Return true if the constants have the same kind (both integers, ...) *)
+
+val kind_equal : t -> t -> bool
+
+(** Pretty print a const *)
+
+val pp : Pp.env -> F.formatter -> t -> unit
+
+val to_string : t -> string
+
+val iszero_int_float : t -> bool
+
+val isone_int_float : t -> bool
+
+val isminusone_int_float : t -> bool
diff --git a/infer/src/IR/Const.re b/infer/src/IR/Const.re
deleted file mode 100644
index 172983aca..000000000
--- a/infer/src/IR/Const.re
+++ /dev/null
@@ -1,69 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Constants */
-module L = Logging;
-
-module F = Format;
-
-type t =
- | Cint IntLit.t /** integer constants */
- | Cfun Typ.Procname.t /** function names */
- | Cstr string /** string constants */
- | Cfloat float /** float constants */
- | Cclass Ident.name /** class constant */
-[@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-let kind_equal c1 c2 => {
- let const_kind_number =
- fun
- | Cint _ => 1
- | Cfun _ => 2
- | Cstr _ => 3
- | Cfloat _ => 4
- | Cclass _ => 5;
- Int.equal (const_kind_number c1) (const_kind_number c2)
-};
-
-let pp pe f =>
- fun
- | Cint i => IntLit.pp f i
- | Cfun fn =>
- switch pe.Pp.kind {
- | 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;
-
-let iszero_int_float =
- fun
- | Cint i => IntLit.iszero i
- | Cfloat 0.0 => true
- | _ => false;
-
-let isone_int_float =
- fun
- | Cint i => IntLit.isone i
- | Cfloat 1.0 => true
- | _ => false;
-
-let isminusone_int_float =
- fun
- | Cint i => IntLit.isminusone i
- | Cfloat (-1.0) => true
- | _ => false;
diff --git a/infer/src/IR/Const.rei b/infer/src/IR/Const.rei
deleted file mode 100644
index 5cafaf5a9..000000000
--- a/infer/src/IR/Const.rei
+++ /dev/null
@@ -1,44 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Constants */
-module L = Logging;
-
-module F = Format;
-
-
-/** Constants */
-type t =
- | Cint IntLit.t /** integer constants */
- | Cfun Typ.Procname.t /** function names */
- | Cstr string /** string constants */
- | Cfloat float /** float constants */
- | Cclass Ident.name /** class constant */
-[@@deriving compare];
-
-let equal: t => t => bool;
-
-
-/** Return true if the constants have the same kind (both integers, ...) */
-let kind_equal: t => t => bool;
-
-
-/** Pretty print a const */
-let pp: Pp.env => F.formatter => t => unit;
-
-let to_string: t => string;
-
-let iszero_int_float: t => bool;
-
-let isone_int_float: t => bool;
-
-let isminusone_int_float: t => bool;
diff --git a/infer/src/IR/DecompiledExp.ml b/infer/src/IR/DecompiledExp.ml
new file mode 100644
index 000000000..4c3a8807f
--- /dev/null
+++ b/infer/src/IR/DecompiledExp.ml
@@ -0,0 +1,138 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Decompiled Expressions *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** expression representing the result of decompilation *)
+type t =
+ | Darray of t * t
+ | Dbinop of Binop.t * t * t
+ | Dconst of Const.t
+ | Dsizeof of Typ.t * t option * Subtype.t
+ | Dderef of t
+ | Dfcall of t * t list * Location.t * CallFlags.t
+ | Darrow of t * Typ.Fieldname.t
+ | Ddot of t * Typ.Fieldname.t
+ | Dpvar of Pvar.t
+ | Dpvaraddr of Pvar.t
+ | Dunop of Unop.t * t
+ | Dunknown
+ | Dretcall of t * t list * Location.t * CallFlags.t
+
+(** Value paths: identify an occurrence of a value in a symbolic heap
+ each expression represents a path, with Dpvar being the simplest one *)
+type vpath = t option
+
+let java () = Config.equal_language !Config.curr_language Config.Java
+
+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
+ 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 =
+ match pname with
+ | 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)
+ 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)
+ 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 *)
+ Typ.Fieldname.to_simplified_string f
+ | 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 *)
+ Typ.Fieldname.to_simplified_string fe
+ | 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 =
+ 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
+
+(** Pretty print a dexp. *)
+let pp fmt de = F.fprintf fmt "%s" (to_string de)
+
+(** Pretty print a value path *)
+let pp_vpath pe fmt vpath =
+ let pp fmt = function Some de -> pp fmt de | None -> () in
+ if Pp.equal_print_kind pe.Pp.kind Pp.HTML then
+ F.fprintf fmt " %a{vpath: %a}%a" Io_infer.Html.pp_start_color Pp.Orange pp 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
diff --git a/infer/src/IR/DecompiledExp.mli b/infer/src/IR/DecompiledExp.mli
new file mode 100644
index 000000000..92da9c869
--- /dev/null
+++ b/infer/src/IR/DecompiledExp.mli
@@ -0,0 +1,52 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Decompiled Expressions *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** expression representing the result of decompilation *)
+
+type t =
+ | Darray of t * t
+ | Dbinop of Binop.t * t * t
+ | Dconst of Const.t
+ | Dsizeof of Typ.t * t option * Subtype.t
+ | Dderef of t
+ | Dfcall of t * t list * Location.t * CallFlags.t
+ | Darrow of t * Typ.Fieldname.t
+ | Ddot of t * Typ.Fieldname.t
+ | Dpvar of Pvar.t
+ | Dpvaraddr of Pvar.t
+ | Dunop of Unop.t * t
+ | Dunknown
+ | Dretcall of t * t list * Location.t * CallFlags.t
+
+(** Value paths: identify an occurrence of a value in a symbolic heap
+ each expression represents a path, with Dpvar being the simplest one *)
+
+type vpath = t option
+
+(** convert to a string *)
+
+val to_string : t -> string
+
+(** pretty print *)
+
+val pp : F.formatter -> t -> unit
+
+(** Pretty print a value path *)
+
+val pp_vpath : Pp.env -> F.formatter -> vpath -> unit
+
+(** return true if [dexp] contains a temporary pvar *)
+
+val has_tmp_var : t -> bool
diff --git a/infer/src/IR/DecompiledExp.re b/infer/src/IR/DecompiledExp.re
deleted file mode 100644
index b74de34f3..000000000
--- a/infer/src/IR/DecompiledExp.re
+++ /dev/null
@@ -1,175 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Decompiled Expressions */
-module L = Logging;
-
-module F = Format;
-
-
-/** expression representing the result of decompilation */
-type t =
- | Darray t t
- | Dbinop Binop.t t t
- | Dconst Const.t
- | Dsizeof Typ.t (option t) Subtype.t
- | Dderef t
- | Dfcall t (list t) Location.t CallFlags.t
- | Darrow t Typ.Fieldname.t
- | Ddot t Typ.Fieldname.t
- | Dpvar Pvar.t
- | Dpvaraddr Pvar.t
- | Dunop Unop.t t
- | Dunknown
- | Dretcall t (list t) Location.t CallFlags.t;
-
-
-/** Value paths: identify an occurrence of a value in a symbolic heap
- each expression represents a path, with Dpvar being the simplest one */
-type vpath = option t;
-
-let java () => Config.equal_language !Config.curr_language Config.Java;
-
-let eradicate_java () => Config.eradicate && java ();
-
-
-/** convert a dexp to a string */
-let rec to_string =
- fun
- | 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);
- let pp_args fmt des =>
- if (eradicate_java ()) {
- if (des != []) {
- F.fprintf fmt "..."
- }
- } else {
- Pp.comma_seq pp_arg fmt des
- };
- let pp_fun fmt => (
- fun
- | Dconst (Cfun pname) => {
- let s =
- switch pname {
- | Typ.Procname.Java pname_java => Typ.Procname.java_get_method pname_java
- | _ => Typ.Procname.to_string pname
- };
- F.fprintf fmt "%s" s
- }
- | de => F.fprintf fmt "%s" (to_string de)
- );
- let (receiver, args') =
- switch args {
- | [Dpvar pv, ...args'] when isvirtual && Pvar.is_this pv => (None, args')
- | [a, ...args'] when isvirtual => (Some a, args')
- | _ => (None, args)
- };
- let pp fmt => {
- let pp_receiver fmt => (
- fun
- | None => ()
- | Some arg => F.fprintf fmt "%a." pp_arg arg
- );
- F.fprintf fmt "%a%a(%a)" pp_receiver receiver pp_fun fun_dexp pp_args args'
- };
- F.asprintf "%t" pp
- }
- | 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) {
- to_string de
- } else if (java ()) {
- 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 */
- Typ.Fieldname.to_simplified_string fe
- | Ddot de f =>
- if (Typ.Fieldname.is_hidden f) {
- "&" ^ to_string de
- } else if (java ()) {
- 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 =
- if (eradicate_java ()) {
- Pvar.get_simplified_name pv
- } else {
- Mangled.to_string (Pvar.get_name pv)
- };
- let ampersand =
- if (eradicate_java ()) {
- ""
- } else {
- "&"
- };
- 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;
-
-
-/** Pretty print a dexp. */
-let pp fmt de => F.fprintf fmt "%s" (to_string de);
-
-
-/** Pretty print a value path */
-let pp_vpath pe fmt vpath => {
- let pp fmt =>
- fun
- | Some de => pp fmt de
- | None => ();
- if (Pp.equal_print_kind pe.Pp.kind Pp.HTML) {
- F.fprintf
- fmt
- " %a{vpath: %a}%a"
- Io_infer.Html.pp_start_color
- Pp.Orange
- pp
- vpath
- Io_infer.Html.pp_end_color
- ()
- } else {
- F.fprintf fmt "%a" pp vpath
- }
-};
-
-let rec has_tmp_var =
- fun
- | 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;
diff --git a/infer/src/IR/DecompiledExp.rei b/infer/src/IR/DecompiledExp.rei
deleted file mode 100644
index d3470db90..000000000
--- a/infer/src/IR/DecompiledExp.rei
+++ /dev/null
@@ -1,54 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Decompiled Expressions */
-module L = Logging;
-
-module F = Format;
-
-
-/** expression representing the result of decompilation */
-type t =
- | Darray t t
- | Dbinop Binop.t t t
- | Dconst Const.t
- | Dsizeof Typ.t (option t) Subtype.t
- | Dderef t
- | Dfcall t (list t) Location.t CallFlags.t
- | Darrow t Typ.Fieldname.t
- | Ddot t Typ.Fieldname.t
- | Dpvar Pvar.t
- | Dpvaraddr Pvar.t
- | Dunop Unop.t t
- | Dunknown
- | Dretcall t (list t) Location.t CallFlags.t;
-
-
-/** Value paths: identify an occurrence of a value in a symbolic heap
- each expression represents a path, with Dpvar being the simplest one */
-type vpath = option t;
-
-
-/** convert to a string */
-let to_string: t => string;
-
-
-/** pretty print */
-let pp: F.formatter => t => unit;
-
-
-/** Pretty print a value path */
-let pp_vpath: Pp.env => F.formatter => vpath => unit;
-
-
-/** return true if [dexp] contains a temporary pvar */
-let has_tmp_var: t => bool;
diff --git a/infer/src/IR/Errlog.ml b/infer/src/IR/Errlog.ml
index b21436ad3..ce3b8ceee 100644
--- a/infer/src/IR/Errlog.ml
+++ b/infer/src/IR/Errlog.ml
@@ -9,7 +9,6 @@
open! IStd
module Hashtbl = Caml.Hashtbl
-
module L = Logging
module F = Format
@@ -20,28 +19,28 @@ type node_tag =
| Procedure_end of Typ.Procname.t
(** Element of a loc trace *)
-type loc_trace_elem = {
- lt_level : int; (** nesting level of procedure calls *)
- lt_loc : Location.t; (** source location at the current step in the trace *)
- lt_description : string; (** description of the current step in the trace *)
- lt_node_tags : node_tag list (** tags describing the node at the current location *)
-}
+type loc_trace_elem =
+ { lt_level: int (** nesting level of procedure calls *)
+ ; lt_loc: Location.t (** source location at the current step in the trace *)
+ ; lt_description: string (** description of the current step in the trace *)
+ ; lt_node_tags: node_tag list (** tags describing the node at the current location *) }
-let pp_loc_trace_elem fmt { lt_level; lt_loc; } =
- F.fprintf fmt "%d %a" lt_level Location.pp lt_loc
+let pp_loc_trace_elem fmt {lt_level; lt_loc} = F.fprintf fmt "%d %a" lt_level Location.pp lt_loc
-let pp_loc_trace fmt l =
- PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_elem fmt l
+let pp_loc_trace fmt l = PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_elem fmt l
let contains_exception loc_trace_elem =
let pred nt =
match nt with
- | Exception _ -> true
- | Condition _ | Procedure_start _ | Procedure_end _ -> false in
+ | 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 }
+ {lt_level; lt_loc; lt_description; lt_node_tags}
(** Trace of locations *)
type loc_trace = loc_trace_elem list
@@ -49,56 +48,55 @@ 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' =
- if Int.equal step.lt_level 0 then Some step
- else last_known_step_at_level_zero_opt in
+ | `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) in
+ | 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 node_id_key = {node_id: int; node_key: int}
-type err_key = {
- err_kind : Exceptions.err_kind;
- in_footprint : bool;
- err_name : Localise.t;
- err_desc : Localise.error_desc;
- severity : string
-}[@@deriving compare]
+type err_key =
+ { err_kind: Exceptions.err_kind
+ ; in_footprint: bool
+ ; err_name: Localise.t
+ ; err_desc: Localise.error_desc
+ ; severity: string }
+ [@@deriving compare]
(** Data associated to a specific error *)
-type err_data = {
- node_id_key : node_id_key;
- session : int;
- loc : Location.t;
- loc_in_ml_source : L.ml_loc option;
- loc_trace : loc_trace;
- err_class : Exceptions.err_class;
- visibility : Exceptions.visibility;
- linters_def_file : string option;
- doc_url : string option;
-}
-
-let compare_err_data err_data1 err_data2 =
- Location.compare err_data1.loc err_data2.loc
+type err_data =
+ { node_id_key: node_id_key
+ ; session: int
+ ; loc: Location.t
+ ; loc_in_ml_source: L.ml_loc option
+ ; loc_trace: loc_trace
+ ; err_class: Exceptions.err_class
+ ; visibility: Exceptions.visibility
+ ; linters_def_file: string option
+ ; doc_url: string option }
+
+let compare_err_data err_data1 err_data2 = Location.compare err_data1.loc err_data2.loc
module ErrDataSet = (* set err_data with no repeated loc *)
- Caml.Set.Make(struct
- type t = err_data
- let compare = compare_err_data
- end)
+Caml.Set.Make (struct
+ type t = err_data
+
+ let compare = compare_err_data
+end)
(** Hash table to implement error logs *)
module ErrLogHash = struct
module Key = struct
- type t = err_key[@@deriving compare]
+ type t = err_key [@@deriving compare]
(* NOTE: changing the hash function can change the order in which issues are reported. *)
let hash key =
@@ -108,10 +106,10 @@ module ErrLogHash = struct
let equal key1 key2 =
[%compare.equal : Exceptions.err_kind * bool * Localise.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
-
+ (key2.err_kind, key2.in_footprint, key2.err_name)
+ && Localise.error_desc_equal key1.err_desc key2.err_desc
end
+
include Hashtbl.Make (Key)
end
@@ -122,7 +120,7 @@ type t = ErrDataSet.t ErrLogHash.t
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)
+ [%compare : (ErrLogHash.Key.t * ErrDataSet.t) list] (bindings x) (bindings y)
(** Empty error log *)
let empty () = ErrLogHash.create 13
@@ -132,67 +130,71 @@ type iter_fun = err_key -> err_data -> unit
(** Apply f to nodes and error names *)
let iter (f: iter_fun) (err_log: t) =
- ErrLogHash.iter (fun err_key set ->
- ErrDataSet.iter (fun err_data -> f err_key err_data) set)
+ ErrLogHash.iter
+ (fun err_key set -> ErrDataSet.iter (fun err_data -> f err_key err_data) set)
err_log
(** Return the number of elements in the error log which satisfy [filter] *)
let size filter (err_log: t) =
let count = ref 0 in
- ErrLogHash.iter (fun key err_datas ->
- if filter key.err_kind key.in_footprint
- then count := !count + (ErrDataSet.cardinal err_datas)) err_log;
+ ErrLogHash.iter
+ (fun key err_datas ->
+ if filter key.err_kind key.in_footprint then count := !count + ErrDataSet.cardinal err_datas)
+ err_log ;
!count
(** Print errors from error log *)
-let pp_errors fmt (errlog : t) =
+let pp_errors fmt (errlog: t) =
let f key _ =
if Exceptions.equal_err_kind key.err_kind Exceptions.Kerror then
- F.fprintf fmt "%a@ " Localise.pp key.err_name in
+ F.fprintf fmt "%a@ " Localise.pp key.err_name
+ in
ErrLogHash.iter f errlog
(** Print warnings from error log *)
-let pp_warnings fmt (errlog : t) =
+let pp_warnings fmt (errlog: t) =
let f key _ =
if Exceptions.equal_err_kind key.err_kind Exceptions.Kwarning then
- F.fprintf fmt "%a %a@ " Localise.pp key.err_name Localise.pp_error_desc key.err_desc in
+ F.fprintf fmt "%a %a@ " Localise.pp key.err_name Localise.pp_error_desc key.err_desc
+ 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 =
- let pp_nodeid_session_loc
- fmt err_data =
- Io_infer.Html.pp_session_link
- source path_to_root fmt
- (err_data.node_id_key.node_id, err_data.session, err_data.loc.Location.line) in
- ErrDataSet.iter (pp_nodeid_session_loc fmt) err_datas in
+ let pp_nodeid_session_loc fmt err_data =
+ Io_infer.Html.pp_session_link source path_to_root fmt
+ (err_data.node_id_key.node_id, err_data.session, err_data.loc.Location.line)
+ in
+ ErrDataSet.iter (pp_nodeid_session_loc fmt) err_datas
+ in
let pp_err_log do_fp ek key err_datas =
- if Exceptions.equal_err_kind key.err_kind ek && Bool.equal do_fp key.in_footprint
- then
- F.fprintf fmt "
%a %a %a"
- Localise.pp key.err_name
- Localise.pp_error_desc key.err_desc
- pp_eds err_datas in
- F.fprintf fmt "%aERRORS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
- ErrLogHash.iter (pp_err_log true Exceptions.Kerror) errlog;
- F.fprintf fmt "%aERRORS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
- ErrLogHash.iter (pp_err_log false Exceptions.Kerror) errlog;
- F.fprintf fmt "%aWARNINGS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
- ErrLogHash.iter (pp_err_log true Exceptions.Kwarning) errlog;
- F.fprintf fmt "%aWARNINGS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
- ErrLogHash.iter (pp_err_log false Exceptions.Kwarning) errlog;
- F.fprintf fmt "%aINFOS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
- ErrLogHash.iter (pp_err_log true Exceptions.Kinfo) errlog;
- F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
+ if Exceptions.equal_err_kind key.err_kind ek && Bool.equal do_fp key.in_footprint then
+ F.fprintf fmt "
%a %a %a" Localise.pp key.err_name Localise.pp_error_desc key.err_desc
+ pp_eds err_datas
+ in
+ F.fprintf fmt "%aERRORS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline () ;
+ ErrLogHash.iter (pp_err_log true Exceptions.Kerror) errlog ;
+ F.fprintf fmt "%aERRORS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline () ;
+ ErrLogHash.iter (pp_err_log false Exceptions.Kerror) errlog ;
+ F.fprintf fmt "%aWARNINGS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline () ;
+ ErrLogHash.iter (pp_err_log true Exceptions.Kwarning) errlog ;
+ F.fprintf fmt "%aWARNINGS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline () ;
+ ErrLogHash.iter (pp_err_log false Exceptions.Kwarning) errlog ;
+ F.fprintf fmt "%aINFOS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline () ;
+ ErrLogHash.iter (pp_err_log true Exceptions.Kinfo) errlog ;
+ 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"
+let severity_to_str severity =
+ match severity with
+ | 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 *)
@@ -200,121 +202,120 @@ let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool =
try
let current_eds = ErrLogHash.find tbl err_key in
if ErrDataSet.subset err_datas current_eds then false
- else
- begin
- ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds);
- true
- end
- with Not_found ->
- begin
- ErrLogHash.add tbl err_key err_datas;
- true
- end
+ else (
+ ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds) ;
+ 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
+ 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 err_name, err_desc, ml_loc_opt, visibility, severity, force_kind, eclass =
- Exceptions.recognize_exception exn in
- let err_kind = match force_kind with
- | Some err_kind -> err_kind
- | _ -> err_kind in
- let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *)
- not Config.developer_mode &&
- Config.curr_language_is Config.Java &&
- Int.equal loc.Location.line 0 in
+ Exceptions.recognize_exception exn
+ in
+ let err_kind = match force_kind with Some err_kind -> err_kind | _ -> err_kind in
+ let hide_java_loc_zero =
+ (* hide java errors at location zero unless in -developer_mode *)
+ not Config.developer_mode && Config.curr_language_is Config.Java
+ && Int.equal loc.Location.line 0
+ in
let hide_memory_error =
match Localise.error_desc_get_bucket err_desc with
- | Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin ->
- not Mleak_buckets.should_raise_leak_unknown_origin
- | _ -> false in
+ | 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 visibility Exceptions.Exn_user ||
- (Config.developer_mode &&
- Exceptions.equal_visibility visibility Exceptions.Exn_developer) in
- if log_it && not hide_java_loc_zero && not hide_memory_error then begin
+ Exceptions.equal_visibility visibility Exceptions.Exn_user
+ || Config.developer_mode && Exceptions.equal_visibility visibility Exceptions.Exn_developer
+ in
+ if log_it && not hide_java_loc_zero && not hide_memory_error then
let added =
let node_id_key = {node_id; node_key} in
- let err_data = {
- node_id_key;
- session;
- loc;
- loc_in_ml_source = ml_loc_opt;
- loc_trace = ltr;
- err_class = eclass;
- visibility;
- linters_def_file;
- doc_url;
- } in
- let err_key = {
- err_kind;
- in_footprint = !Config.footprint;
- err_name;
- err_desc;
- severity = severity_to_str severity
- } in
- add_issue err_log err_key (ErrDataSet.singleton err_data) in
- let should_print_now =
- match exn with
- | Exceptions.Internal_error _ -> true
- | _ -> added in
+ let err_data =
+ { node_id_key
+ ; session
+ ; loc
+ ; loc_in_ml_source= ml_loc_opt
+ ; loc_trace= ltr
+ ; err_class= eclass
+ ; visibility
+ ; linters_def_file
+ ; doc_url }
+ in
+ let err_key =
+ { err_kind
+ ; in_footprint= !Config.footprint
+ ; err_name
+ ; err_desc
+ ; severity= severity_to_str severity }
+ in
+ add_issue err_log err_key (ErrDataSet.singleton err_data)
+ in
+ let should_print_now = match exn with Exceptions.Internal_error _ -> true | _ -> added in
let print_now () =
let ex_name, desc, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
- L.(debug Analysis Medium) "@\n%a@\n@?"
- (Exceptions.pp_err ~node_key loc err_kind ex_name desc ml_loc_opt) ();
- if err_kind <> Exceptions.Kerror then begin
+ L.(debug Analysis Medium)
+ "@\n%a@\n@?" (Exceptions.pp_err ~node_key loc err_kind ex_name desc ml_loc_opt) () ;
+ if err_kind <> Exceptions.Kerror then
let warn_str =
let pp fmt =
- Format.fprintf fmt "%s %a"
- (Localise.to_issue_id err_name)
- Localise.pp_error_desc desc in
- F.asprintf "%t" pp 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 in
- d warn_str; L.d_ln();
- end in
+ Format.fprintf fmt "%s %a" (Localise.to_issue_id err_name) Localise.pp_error_desc desc
+ in
+ F.asprintf "%t" pp
+ 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
+ in
+ d warn_str ; L.d_ln ()
+ in
if should_print_now then print_now ()
- end
type err_log = t
(** Global per-file error table *)
module Err_table = struct
type t = err_log
+
let create = empty
- let count_err err_table err_name locs =
- ignore (add_issue err_table err_name locs)
+ let count_err err_table err_name locs = ignore (add_issue err_table err_name locs)
- let table_size filter (err_table: t) =
- size filter err_table
+ let table_size filter (err_table: t) = size filter err_table
let pp_stats_footprint ekind fmt (err_table: err_log) =
- let err_name_map = ref String.Map.empty in (* map error name to count *)
+ let err_name_map = ref String.Map.empty in
+ (* map error name to count *)
let count_err (err_name: Localise.t) n =
let err_string = Localise.to_issue_id err_name in
- let count = try String.Map.find_exn !err_name_map err_string with Not_found -> 0 in
- err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map in
+ let count =
+ try String.Map.find_exn !err_name_map err_string
+ with Not_found -> 0
+ in
+ err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map
+ in
let count key err_datas =
- if Exceptions.equal_err_kind ekind key.err_kind && key.in_footprint
- then count_err key.err_name (ErrDataSet.cardinal err_datas) in
- ErrLogHash.iter count err_table;
+ if Exceptions.equal_err_kind ekind key.err_kind && key.in_footprint then
+ count_err key.err_name (ErrDataSet.cardinal err_datas)
+ in
+ ErrLogHash.iter count err_table ;
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
- let compare = compare_err_data
- end)
+ module LocMap = Caml.Map.Make (struct
+ type t = ErrDataSet.elt
+
+ let compare = compare_err_data
+ end)
let print_err_table_details fmt err_table =
let map_err_fp = ref LocMap.empty in
@@ -325,40 +326,53 @@ module Err_table = struct
let map_advice = ref LocMap.empty in
let map_likes = ref LocMap.empty in
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 in
+ 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
+ in
try
let err_list = LocMap.find nslm !map in
map := LocMap.add nslm ((key.err_name, key.err_desc) :: err_list) !map
- with Not_found ->
- map := LocMap.add nslm [(key.err_name, key.err_desc)] !map in
- let f err_name eds =
- ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
- ErrLogHash.iter f err_table;
-
+ with Not_found -> map := LocMap.add nslm [(key.err_name, key.err_desc)] !map
+ in
+ let f err_name eds = ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
+ ErrLogHash.iter f err_table ;
let pp ekind err_data fmt err_names =
- List.iter ~f:(fun (err_name, desc) ->
- Exceptions.pp_err
- ~node_key:err_data.node_id_key.node_key err_data.loc ekind err_name desc
- err_data.loc_in_ml_source fmt ()) err_names in
- F.fprintf fmt "@.Detailed errors during footprint phase:@.";
- LocMap.iter (fun nslm err_names ->
- F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
- F.fprintf fmt "@.Detailed errors during re-execution phase:@.";
- LocMap.iter (fun nslm err_names ->
- F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re;
- F.fprintf fmt "@.Detailed warnings during footprint phase:@.";
- LocMap.iter (fun nslm err_names ->
- F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp;
- F.fprintf fmt "@.Detailed warnings during re-execution phase:@.";
- LocMap.iter (fun nslm err_names ->
- F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re
+ List.iter
+ ~f:(fun (err_name, desc) ->
+ Exceptions.pp_err ~node_key:err_data.node_id_key.node_key err_data.loc ekind err_name
+ desc err_data.loc_in_ml_source fmt ())
+ err_names
+ in
+ F.fprintf fmt "@.Detailed errors during footprint phase:@." ;
+ LocMap.iter
+ (fun nslm err_names -> F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names)
+ !map_err_fp ;
+ F.fprintf fmt "@.Detailed errors during re-execution phase:@." ;
+ LocMap.iter
+ (fun nslm err_names -> F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names)
+ !map_err_re ;
+ F.fprintf fmt "@.Detailed warnings during footprint phase:@." ;
+ LocMap.iter
+ (fun nslm err_names -> F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names)
+ !map_warn_fp ;
+ F.fprintf fmt "@.Detailed warnings during re-execution phase:@." ;
+ 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
@@ -367,8 +381,7 @@ type err_table = Err_table.t
let create_err_table = Err_table.create
(** Print an error log and add it to the global per-file table *)
-let extend_table err_table err_log =
- ErrLogHash.iter (Err_table.count_err err_table) err_log
+let extend_table err_table err_log = ErrLogHash.iter (Err_table.count_err err_table) err_log
(** Size of the global per-file error table for the footprint phase *)
let err_table_size_footprint ekind =
@@ -379,5 +392,4 @@ let err_table_size_footprint ekind =
let pp_err_table_stats ekind = Err_table.pp_stats_footprint ekind
(** Print details of the global per-file error table *)
-let print_err_table_details =
- Err_table.print_err_table_details
+let print_err_table_details = Err_table.print_err_table_details
diff --git a/infer/src/IR/Errlog.mli b/infer/src/IR/Errlog.mli
index d500b2e17..3095b6e57 100644
--- a/infer/src/IR/Errlog.mli
+++ b/infer/src/IR/Errlog.mli
@@ -18,102 +18,98 @@ type node_tag =
| Procedure_end of Typ.Procname.t
(** Element of a loc trace *)
-type loc_trace_elem = private {
- lt_level : int; (** nesting level of procedure calls *)
- lt_loc : Location.t; (** source location at the current step in the trace *)
- lt_description : string; (** description of the current step in the trace *)
- lt_node_tags : node_tag list (** tags describing the node at the current location *)
-}
+type loc_trace_elem = private
+ { lt_level: int (** nesting level of procedure calls *)
+ ; lt_loc: Location.t (** source location at the current step in the trace *)
+ ; lt_description: string (** description of the current step in the trace *)
+ ; lt_node_tags: node_tag list (** tags describing the node at the current location *) }
-(** build a loc_trace_elem from its constituents (unambiguously identified by their types). *)
val make_trace_element : int -> Location.t -> string -> node_tag list -> loc_trace_elem
+(** build a loc_trace_elem from its constituents (unambiguously identified by their types). *)
(** Trace of locations *)
type loc_trace = loc_trace_elem list
+val compute_local_exception_line : loc_trace -> int option
(** Look at all the trace steps and find those that are arising any exception,
then bind them to the closest step at level 0.
This extra information adds value to the report itself, and may avoid
digging into the trace to understand the cause of the report. *)
-val compute_local_exception_line : loc_trace -> int option
-type node_id_key = private {
- node_id : int;
- node_key : int
-}
+type node_id_key = private {node_id: int; node_key: int}
-type err_key = private {
- err_kind : Exceptions.err_kind;
- in_footprint : bool;
- err_name : Localise.t;
- err_desc : Localise.error_desc;
- severity : string
-}[@@deriving compare]
+type err_key = private
+ { err_kind: Exceptions.err_kind
+ ; in_footprint: bool
+ ; err_name: Localise.t
+ ; err_desc: Localise.error_desc
+ ; severity: string }
+ [@@deriving compare]
(** Data associated to a specific error *)
-type err_data = private {
- node_id_key : node_id_key;
- session : int;
- loc : Location.t;
- loc_in_ml_source : Logging.ml_loc option;
- loc_trace : loc_trace;
- err_class : Exceptions.err_class;
- visibility : Exceptions.visibility;
- linters_def_file : string option;
- doc_url : string option; (* url to documentation of the issue type *)
-}
+type err_data = private
+ { node_id_key: node_id_key
+ ; session: int
+ ; loc: Location.t
+ ; loc_in_ml_source: Logging.ml_loc option
+ ; loc_trace: loc_trace
+ ; err_class: Exceptions.err_class
+ ; visibility: Exceptions.visibility
+ ; linters_def_file: string option
+ ; doc_url: string option
+ (* url to documentation of the issue type *) }
(** Type of the error log *)
-type t[@@deriving compare]
+type t [@@deriving compare]
-(** Empty error log *)
val empty : unit -> t
+(** Empty error log *)
(** type of the function to be passed to iter *)
type iter_fun = err_key -> err_data -> unit
-(** Apply f to nodes and error names *)
val iter : iter_fun -> t -> unit
+(** Apply f to nodes and error names *)
val pp_loc_trace_elem : Format.formatter -> loc_trace_elem -> unit
val pp_loc_trace : Format.formatter -> loc_trace -> unit
-(** Print errors from error log *)
val pp_errors : Format.formatter -> t -> unit
+(** Print errors from error log *)
-(** Print warnings from error log *)
val pp_warnings : Format.formatter -> t -> unit
+(** Print warnings from error log *)
-(** Print an error log in html format *)
val pp_html : SourceFile.t -> DB.Results_dir.path -> Format.formatter -> t -> unit
+(** Print an error log in html format *)
-(** Return the number of elements in the error log which satisfy the filter. *)
val size : (Exceptions.err_kind -> bool -> bool) -> t -> int
+(** Return the number of elements in the error log which satisfy the filter. *)
-(** Update an old error log with a new one *)
val update : t -> t -> unit
+(** Update an old error log with a new one *)
val log_issue :
- Exceptions.err_kind -> t -> Location.t -> (int * int) -> int -> loc_trace ->
- ?linters_def_file:string -> ?doc_url:string -> exn -> unit
+ Exceptions.err_kind -> t -> Location.t -> int * int -> int -> loc_trace
+ -> ?linters_def_file:string -> ?doc_url:string -> exn -> unit
(** {2 Functions for manipulating per-file error tables} *)
(** Type for per-file error tables *)
type err_table
-(** Create an error table *)
val create_err_table : unit -> err_table
+(** Create an error table *)
-(** Add an error log to the global per-file table *)
val extend_table : err_table -> t -> unit
+(** Add an error log to the global per-file table *)
-(** Size of the global per-file error table for the footprint phase *)
val err_table_size_footprint : Exceptions.err_kind -> err_table -> int
+(** Size of the global per-file error table for the footprint phase *)
-(** Print stats for the global per-file error table *)
val pp_err_table_stats : Exceptions.err_kind -> Format.formatter -> err_table -> unit
+(** Print stats for the global per-file error table *)
-(** Print details of the global per-file error table *)
val print_err_table_details : Format.formatter -> err_table -> unit
+(** Print details of the global per-file error table *)
diff --git a/infer/src/IR/Exceptions.ml b/infer/src/IR/Exceptions.ml
index 692bd37f8..3a23b521d 100644
--- a/infer/src/IR/Exceptions.ml
+++ b/infer/src/IR/Exceptions.ml
@@ -9,30 +9,27 @@
*)
open! IStd
-
module L = Logging
module F = Format
(** visibility of the exception *)
type visibility =
- | Exn_user (** always add to error log *)
- | Exn_developer (** only add to error log in developer mode *)
- | Exn_system (** never add to error log *)
-[@@deriving compare]
+ | Exn_user (** always add to error log *)
+ | Exn_developer (** only add to error log in developer mode *)
+ | Exn_system (** never add to error log *)
+ [@@deriving compare]
let equal_visibility = [%compare.equal : visibility]
let string_of_visibility vis =
- match vis with
- | Exn_user -> "user"
- | Exn_developer -> "developer"
- | Exn_system -> "system"
+ match vis with Exn_user -> "user" | Exn_developer -> "developer" | Exn_system -> "system"
(** severity of bugs *)
-type severity =
- | High (* high severity bug *)
+type severity = High (* high severity bug *)
| Medium (* medium severity bug *)
- | Low (* low severity bug *)
+ | Low
+
+(* low severity bug *)
(** class of error/warning *)
type err_class = Checker | Prover | Nocat | Linters [@@deriving compare]
@@ -45,305 +42,434 @@ type err_kind = Kwarning | Kerror | Kinfo | Kadvice | Klike [@@deriving compare]
let equal_err_kind = [%compare.equal : err_kind]
exception Abduction_case_not_implemented of L.ml_loc
+
exception Analysis_stops of Localise.error_desc * L.ml_loc option
+
exception Array_out_of_bounds_l1 of Localise.error_desc * L.ml_loc
+
exception Array_out_of_bounds_l2 of Localise.error_desc * L.ml_loc
+
exception Array_out_of_bounds_l3 of Localise.error_desc * L.ml_loc
+
exception Array_of_pointsto of L.ml_loc
+
exception Bad_footprint of L.ml_loc
+
exception Cannot_star of L.ml_loc
+
exception Class_cast_exception of Localise.error_desc * L.ml_loc
+
exception Codequery of Localise.error_desc
+
exception Comparing_floats_for_equality of Localise.error_desc * L.ml_loc
+
exception Condition_is_assignment of Localise.error_desc * L.ml_loc
+
exception Condition_always_true_false of Localise.error_desc * bool * L.ml_loc
+
exception Context_leak of Localise.error_desc * L.ml_loc
+
exception Custom_error of string * Localise.error_desc
+
exception Dangling_pointer_dereference of
- PredSymb.dangling_kind option * Localise.error_desc * L.ml_loc
+ PredSymb.dangling_kind option * Localise.error_desc * L.ml_loc
+
exception Deallocate_stack_variable of Localise.error_desc
+
exception Deallocate_static_memory of Localise.error_desc
+
exception Deallocation_mismatch of Localise.error_desc * L.ml_loc
+
exception Divide_by_zero of Localise.error_desc * L.ml_loc
+
exception Double_lock of Localise.error_desc * L.ml_loc
+
exception Empty_vector_access of Localise.error_desc * L.ml_loc
+
exception Eradicate of string * Localise.error_desc
+
exception Field_not_null_checked of Localise.error_desc * L.ml_loc
+
exception Frontend_warning of (string * string option) * Localise.error_desc * L.ml_loc
+
exception Checkers of string * Localise.error_desc
+
exception Inherently_dangerous_function of Localise.error_desc
+
exception Internal_error of Localise.error_desc
+
exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc
+
exception Leak of
- bool * Sil.hpred * (visibility * Localise.error_desc)
- * bool * PredSymb.resource * L.ml_loc
+ bool * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * L.ml_loc
+
exception Missing_fld of Typ.Fieldname.t * L.ml_loc
+
exception Premature_nil_termination of Localise.error_desc * L.ml_loc
+
exception Null_dereference of Localise.error_desc * L.ml_loc
+
exception Null_test_after_dereference of Localise.error_desc * L.ml_loc
+
exception Parameter_not_null_checked of Localise.error_desc * L.ml_loc
+
exception Pointer_size_mismatch of Localise.error_desc * L.ml_loc
+
exception Precondition_not_found of Localise.error_desc * L.ml_loc
+
exception Precondition_not_met of Localise.error_desc * L.ml_loc
+
exception Retain_cycle of Sil.hpred * Localise.error_desc * L.ml_loc
+
exception Registered_observer_being_deallocated of Localise.error_desc * L.ml_loc
+
exception Return_expression_required of Localise.error_desc * L.ml_loc
+
exception Return_statement_missing of Localise.error_desc * L.ml_loc
+
exception Return_value_ignored of Localise.error_desc * L.ml_loc
+
exception Skip_function of Localise.error_desc
+
exception Skip_pointer_dereference of Localise.error_desc * L.ml_loc
+
exception Stack_variable_address_escape of Localise.error_desc * L.ml_loc
+
exception Symexec_memory_error of L.ml_loc
+
exception Tainted_value_reaching_sensitive_function of Localise.error_desc * L.ml_loc
+
exception Unary_minus_applied_to_unsigned_expression of Localise.error_desc * L.ml_loc
+
exception Uninitialized_value of Localise.error_desc * L.ml_loc
+
exception Unknown_proc
+
exception Unreachable_code_after of Localise.error_desc * L.ml_loc
+
exception Unsafe_guarded_by_access of Localise.error_desc * L.ml_loc
+
exception Use_after_free of Localise.error_desc * L.ml_loc
-exception Wrong_argument_number of L.ml_loc
+exception Wrong_argument_number of L.ml_loc
(** Turn an exception into a descriptive string, error description, location in ml source, and category *)
let recognize_exception exn =
- let err_name, desc, (ml_loc_opt : L.ml_loc option), visibility, severity, force_kind, eclass =
- match exn with (* all the names of Exn_user errors must be defined in Localise *)
- | Abduction_case_not_implemented ml_loc ->
- (Localise.from_string "Abduction_case_not_implemented",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Context_leak (desc, _) ->
- (Localise.context_leak,
- desc, None, Exn_user, High, None, Nocat)
- | Analysis_stops (desc, ml_loc_opt) ->
- let visibility = if Config.analysis_stops then Exn_user else Exn_developer in
+ let err_name, desc, (ml_loc_opt: L.ml_loc option), visibility, severity, force_kind, eclass =
+ match exn with
+ (* all the names of Exn_user errors must be defined in Localise *)
+ | Abduction_case_not_implemented ml_loc
+ -> ( Localise.from_string "Abduction_case_not_implemented"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Context_leak (desc, _)
+ -> (Localise.context_leak, desc, None, Exn_user, High, None, Nocat)
+ | Analysis_stops (desc, ml_loc_opt)
+ -> let visibility = if Config.analysis_stops then Exn_user else Exn_developer in
(Localise.analysis_stops, desc, ml_loc_opt, visibility, Medium, None, Nocat)
- | Array_of_pointsto ml_loc ->
- (Localise.from_string "Array_of_pointsto",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Array_out_of_bounds_l1 (desc, ml_loc) ->
- (Localise.array_out_of_bounds_l1,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
- | Array_out_of_bounds_l2 (desc, ml_loc) ->
- (Localise.array_out_of_bounds_l2,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Array_out_of_bounds_l3 (desc, ml_loc) ->
- (Localise.array_out_of_bounds_l3,
- desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
- | Assert_failure (f, l, c) ->
- let ml_loc = (f, l, c, c) in
- (Localise.from_string "Assert_failure",
- Localise.no_desc, Some ml_loc, Exn_developer, High, None, Nocat)
- | Bad_footprint ml_loc ->
- (Localise.from_string "Bad_footprint",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Cannot_star ml_loc ->
- (Localise.from_string "Cannot_star",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Class_cast_exception (desc, ml_loc) ->
- (Localise.class_cast_exception,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Codequery desc ->
- (Localise.from_string "Codequery",
- desc, None, Exn_user, High, None, Prover)
- | Comparing_floats_for_equality(desc, ml_loc) ->
- (Localise.comparing_floats_for_equality,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Condition_always_true_false (desc, b, ml_loc) ->
- let name =
- if b then Localise.condition_always_true
- else Localise.condition_always_false in
+ | Array_of_pointsto ml_loc
+ -> ( Localise.from_string "Array_of_pointsto"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Array_out_of_bounds_l1 (desc, ml_loc)
+ -> (Localise.array_out_of_bounds_l1, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
+ | Array_out_of_bounds_l2 (desc, ml_loc)
+ -> (Localise.array_out_of_bounds_l2, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Array_out_of_bounds_l3 (desc, ml_loc)
+ -> (Localise.array_out_of_bounds_l3, desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
+ | Assert_failure (f, l, c)
+ -> let ml_loc = (f, l, c, c) in
+ ( Localise.from_string "Assert_failure"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , High
+ , None
+ , Nocat )
+ | Bad_footprint ml_loc
+ -> ( Localise.from_string "Bad_footprint"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Cannot_star ml_loc
+ -> ( Localise.from_string "Cannot_star"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Class_cast_exception (desc, ml_loc)
+ -> (Localise.class_cast_exception, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Codequery desc
+ -> (Localise.from_string "Codequery", desc, None, Exn_user, High, None, Prover)
+ | Comparing_floats_for_equality (desc, ml_loc)
+ -> (Localise.comparing_floats_for_equality, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Condition_always_true_false (desc, b, ml_loc)
+ -> let name = if b then Localise.condition_always_true else Localise.condition_always_false in
(name, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Custom_error (error_msg, desc) ->
- (Localise.from_string error_msg,
- desc, None, Exn_user, High, None, Checker)
- | Condition_is_assignment(desc, ml_loc) ->
- (Localise.condition_is_assignment,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | 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 in
- (Localise.dangling_pointer_dereference,
- desc, Some ml_loc, visibility, High, None, Prover)
- | Deallocate_stack_variable desc ->
- (Localise.deallocate_stack_variable,
- desc, None, Exn_user, High, None, Prover)
- | Deallocate_static_memory desc ->
- (Localise.deallocate_static_memory,
- desc, None, Exn_user, High, None, Prover)
- | Deallocation_mismatch (desc, ml_loc) ->
- (Localise.deallocation_mismatch,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Divide_by_zero (desc, ml_loc) ->
- (Localise.divide_by_zero,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
- | Double_lock (desc, ml_loc) ->
- (Localise.double_lock,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
- | Eradicate (kind_s, desc) ->
- (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
- | Empty_vector_access (desc, ml_loc) ->
- (Localise.empty_vector_access,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
- | Field_not_null_checked (desc, ml_loc) ->
- (Localise.field_not_null_checked,
- desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
- | Frontend_warning ((name, hum), desc, ml_loc) ->
- (Localise.from_string name ?hum,
- desc, Some ml_loc, Exn_user, Medium, None, Linters)
- | Checkers (kind_s, desc) ->
- (Localise.from_string kind_s,
- desc, None, Exn_user, High, None, Prover)
- | Null_dereference (desc, ml_loc) ->
- (Localise.null_dereference,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Null_test_after_dereference (desc, ml_loc) ->
- (Localise.null_test_after_dereference,
- desc, Some ml_loc, Exn_user, High, None, Nocat)
- | Pointer_size_mismatch (desc, ml_loc) ->
- (Localise.pointer_size_mismatch,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
- | Inherently_dangerous_function desc ->
- (Localise.inherently_dangerous_function,
- desc, None, Exn_developer, Medium, None, Nocat)
- | Internal_error desc ->
- (Localise.from_string "Internal_error",
- desc, None, Exn_developer, High, None, Nocat)
- | Invalid_argument s ->
- let desc = Localise.verbatim_desc s in
- (Localise.from_string "Invalid_argument",
- desc, None, Exn_system, Low, None, Nocat)
- | Java_runtime_exception (exn_name, _, desc) ->
- let exn_str = Typ.Name.name exn_name in
+ | Custom_error (error_msg, desc)
+ -> (Localise.from_string error_msg, desc, None, Exn_user, High, None, Checker)
+ | Condition_is_assignment (desc, ml_loc)
+ -> (Localise.condition_is_assignment, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | 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
+ in
+ (Localise.dangling_pointer_dereference, desc, Some ml_loc, visibility, High, None, Prover)
+ | Deallocate_stack_variable desc
+ -> (Localise.deallocate_stack_variable, desc, None, Exn_user, High, None, Prover)
+ | Deallocate_static_memory desc
+ -> (Localise.deallocate_static_memory, desc, None, Exn_user, High, None, Prover)
+ | Deallocation_mismatch (desc, ml_loc)
+ -> (Localise.deallocation_mismatch, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Divide_by_zero (desc, ml_loc)
+ -> (Localise.divide_by_zero, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
+ | Double_lock (desc, ml_loc)
+ -> (Localise.double_lock, desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
+ | Eradicate (kind_s, desc)
+ -> (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
+ | Empty_vector_access (desc, ml_loc)
+ -> (Localise.empty_vector_access, desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
+ | Field_not_null_checked (desc, ml_loc)
+ -> (Localise.field_not_null_checked, desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
+ | Frontend_warning ((name, hum), desc, ml_loc)
+ -> (Localise.from_string name ?hum, desc, Some ml_loc, Exn_user, Medium, None, Linters)
+ | Checkers (kind_s, desc)
+ -> (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
+ | Null_dereference (desc, ml_loc)
+ -> (Localise.null_dereference, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Null_test_after_dereference (desc, ml_loc)
+ -> (Localise.null_test_after_dereference, desc, Some ml_loc, Exn_user, High, None, Nocat)
+ | Pointer_size_mismatch (desc, ml_loc)
+ -> (Localise.pointer_size_mismatch, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
+ | Inherently_dangerous_function desc
+ -> (Localise.inherently_dangerous_function, desc, None, Exn_developer, Medium, None, Nocat)
+ | Internal_error desc
+ -> (Localise.from_string "Internal_error", desc, None, Exn_developer, High, None, Nocat)
+ | Invalid_argument s
+ -> let desc = Localise.verbatim_desc s in
+ (Localise.from_string "Invalid_argument", desc, None, Exn_system, Low, None, Nocat)
+ | Java_runtime_exception (exn_name, _, desc)
+ -> let exn_str = Typ.Name.name exn_name in
(Localise.from_string exn_str, desc, None, Exn_user, High, None, Prover)
- | Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) ->
- if done_array_abstraction
- then (Localise.from_string "Leak_after_array_abstraction",
- error_desc, Some ml_loc, Exn_developer, High, None, Prover)
- else if fp_part
- then (Localise.from_string "Leak_in_footprint",
- error_desc, Some ml_loc, Exn_developer, High, None, Prover)
+ | Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc)
+ -> if done_array_abstraction then
+ ( Localise.from_string "Leak_after_array_abstraction"
+ , error_desc
+ , Some ml_loc
+ , Exn_developer
+ , High
+ , None
+ , Prover )
+ else if fp_part then
+ ( Localise.from_string "Leak_in_footprint"
+ , error_desc
+ , Some ml_loc
+ , Exn_developer
+ , High
+ , None
+ , Prover )
else
- let loc_str = match resource with
- | PredSymb.Rmemory _ -> Localise.memory_leak
- | PredSymb.Rfile -> Localise.resource_leak
- | PredSymb.Rlock -> Localise.resource_leak
- | PredSymb.Rignore -> Localise.memory_leak in
+ let loc_str =
+ match resource with
+ | PredSymb.Rmemory _
+ -> Localise.memory_leak
+ | PredSymb.Rfile
+ -> Localise.resource_leak
+ | PredSymb.Rlock
+ -> Localise.resource_leak
+ | PredSymb.Rignore
+ -> Localise.memory_leak
+ in
(loc_str, error_desc, Some ml_loc, exn_vis, High, None, Prover)
- | Match_failure (f, l, c) ->
- let ml_loc = (f, l, c, c) in
- (Localise.from_string "Match failure",
- Localise.no_desc, Some ml_loc, Exn_developer, High, None, Nocat)
- | Missing_fld (fld, ml_loc) ->
- let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
- (Localise.from_string "Missing_fld" ~hum:"Missing Field",
- desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
- | Premature_nil_termination (desc, ml_loc) ->
- (Localise.premature_nil_termination,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Not_found ->
- (Localise.from_string "Not_found",
- Localise.no_desc, None, Exn_system, Low, None, Nocat)
- | Parameter_not_null_checked (desc, ml_loc) ->
- (Localise.parameter_not_null_checked,
- desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
- | Precondition_not_found (desc, ml_loc) ->
- (Localise.precondition_not_found,
- desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Precondition_not_met (desc, ml_loc) ->
- (Localise.precondition_not_met,
- desc, Some ml_loc, Exn_developer, Medium, Some Kwarning, Nocat) (* always a warning *)
- | Retain_cycle (_, desc, ml_loc) ->
- (Localise.retain_cycle,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Registered_observer_being_deallocated (desc, ml_loc) ->
- (Localise.registered_observer_being_deallocated,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Nocat)
- | Return_expression_required (desc, ml_loc) ->
- (Localise.return_expression_required,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Stack_variable_address_escape (desc, ml_loc) ->
- (Localise.stack_variable_address_escape,
- desc, Some ml_loc, Exn_user, High, Some Kerror, Nocat)
- | Return_statement_missing (desc, ml_loc) ->
- (Localise.return_statement_missing,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Return_value_ignored (desc, ml_loc) ->
- (Localise.return_value_ignored,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | SymOp.Analysis_failure_exe _ ->
- (Localise.from_string "Failure_exe",
- Localise.no_desc, None, Exn_system, Low, None, Nocat)
- | Skip_function desc ->
- (Localise.skip_function, desc, None, Exn_developer, Low, None, Nocat)
- | Skip_pointer_dereference (desc, ml_loc) ->
- (Localise.skip_pointer_dereference,
- desc, Some ml_loc, Exn_user, Medium, Some Kinfo, Nocat) (* always an info *)
- | Symexec_memory_error ml_loc ->
- (Localise.from_string "Symexec_memory_error" ~hum:"Symbolic Execution Memory Error",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Sys_error s ->
- let desc = Localise.verbatim_desc s in
- (Localise.from_string "Sys_error" ~hum:"System Error",
- desc, None, Exn_system, Low, None, Nocat)
- | Tainted_value_reaching_sensitive_function (desc, ml_loc) ->
- (Localise.tainted_value_reaching_sensitive_function,
- desc, Some ml_loc, Exn_user, Medium, Some Kerror, Nocat)
- | Unix.Unix_error (_, s1, s2) ->
- let desc = Localise.verbatim_desc (s1 ^ s2) in
- (Localise.from_string "Unix_error",
- desc, None, Exn_system, Low, None, Nocat)
- | Uninitialized_value (desc, ml_loc) ->
- (Localise.uninitialized_value,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Unary_minus_applied_to_unsigned_expression(desc, ml_loc) ->
- (Localise.unary_minus_applied_to_unsigned_expression,
- desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Unknown_proc ->
- (Localise.from_string "Unknown_proc" ~hum:"Unknown Procedure",
- Localise.no_desc, None, Exn_developer, Low, None, Nocat)
- | Unreachable_code_after (desc, ml_loc) ->
- (Localise.unreachable_code_after, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
- | Unsafe_guarded_by_access (desc, ml_loc) ->
- (Localise.unsafe_guarded_by_access,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Use_after_free (desc, ml_loc) ->
- (Localise.use_after_free,
- desc, Some ml_loc, Exn_user, High, None, Prover)
- | Wrong_argument_number ml_loc ->
- (Localise.from_string "Wrong_argument_number" ~hum:"Wrong Argument Number",
- Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
- | Failure _ as f ->
- raise f
- | exn ->
- let exn_name = Exn.to_string exn in
- (Localise.from_string exn_name,
- Localise.no_desc, None, Exn_developer, Low, None, Nocat) in
+ | Match_failure (f, l, c)
+ -> let ml_loc = (f, l, c, c) in
+ ( Localise.from_string "Match failure"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , High
+ , None
+ , Nocat )
+ | Missing_fld (fld, ml_loc)
+ -> let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
+ ( Localise.from_string "Missing_fld" ~hum:"Missing Field"
+ , desc
+ , Some ml_loc
+ , Exn_developer
+ , Medium
+ , None
+ , Nocat )
+ | Premature_nil_termination (desc, ml_loc)
+ -> (Localise.premature_nil_termination, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Not_found
+ -> (Localise.from_string "Not_found", Localise.no_desc, None, Exn_system, Low, None, Nocat)
+ | Parameter_not_null_checked (desc, ml_loc)
+ -> ( Localise.parameter_not_null_checked
+ , desc
+ , Some ml_loc
+ , Exn_user
+ , Medium
+ , Some Kwarning
+ , Nocat )
+ | Precondition_not_found (desc, ml_loc)
+ -> (Localise.precondition_not_found, desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+ | Precondition_not_met (desc, ml_loc)
+ -> ( Localise.precondition_not_met
+ , desc
+ , Some ml_loc
+ , Exn_developer
+ , Medium
+ , Some Kwarning
+ , Nocat )
+ (* always a warning *)
+ | Retain_cycle (_, desc, ml_loc)
+ -> (Localise.retain_cycle, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Registered_observer_being_deallocated (desc, ml_loc)
+ -> ( Localise.registered_observer_being_deallocated
+ , desc
+ , Some ml_loc
+ , Exn_user
+ , High
+ , Some Kerror
+ , Nocat )
+ | Return_expression_required (desc, ml_loc)
+ -> (Localise.return_expression_required, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Stack_variable_address_escape (desc, ml_loc)
+ -> ( Localise.stack_variable_address_escape
+ , desc
+ , Some ml_loc
+ , Exn_user
+ , High
+ , Some Kerror
+ , Nocat )
+ | Return_statement_missing (desc, ml_loc)
+ -> (Localise.return_statement_missing, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Return_value_ignored (desc, ml_loc)
+ -> (Localise.return_value_ignored, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | SymOp.Analysis_failure_exe _
+ -> (Localise.from_string "Failure_exe", Localise.no_desc, None, Exn_system, Low, None, Nocat)
+ | Skip_function desc
+ -> (Localise.skip_function, desc, None, Exn_developer, Low, None, Nocat)
+ | Skip_pointer_dereference (desc, ml_loc)
+ -> (Localise.skip_pointer_dereference, desc, Some ml_loc, Exn_user, Medium, Some Kinfo, Nocat)
+ (* always an info *)
+ | Symexec_memory_error ml_loc
+ -> ( Localise.from_string "Symexec_memory_error" ~hum:"Symbolic Execution Memory Error"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Sys_error s
+ -> let desc = Localise.verbatim_desc s in
+ ( Localise.from_string "Sys_error" ~hum:"System Error"
+ , desc
+ , None
+ , Exn_system
+ , Low
+ , None
+ , Nocat )
+ | Tainted_value_reaching_sensitive_function (desc, ml_loc)
+ -> ( Localise.tainted_value_reaching_sensitive_function
+ , desc
+ , Some ml_loc
+ , Exn_user
+ , Medium
+ , Some Kerror
+ , Nocat )
+ | Unix.Unix_error (_, s1, s2)
+ -> let desc = Localise.verbatim_desc (s1 ^ s2) in
+ (Localise.from_string "Unix_error", desc, None, Exn_system, Low, None, Nocat)
+ | Uninitialized_value (desc, ml_loc)
+ -> (Localise.uninitialized_value, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Unary_minus_applied_to_unsigned_expression (desc, ml_loc)
+ -> ( Localise.unary_minus_applied_to_unsigned_expression
+ , desc
+ , Some ml_loc
+ , Exn_user
+ , Medium
+ , None
+ , Nocat )
+ | Unknown_proc
+ -> ( Localise.from_string "Unknown_proc" ~hum:"Unknown Procedure"
+ , Localise.no_desc
+ , None
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Unreachable_code_after (desc, ml_loc)
+ -> (Localise.unreachable_code_after, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+ | Unsafe_guarded_by_access (desc, ml_loc)
+ -> (Localise.unsafe_guarded_by_access, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Use_after_free (desc, ml_loc)
+ -> (Localise.use_after_free, desc, Some ml_loc, Exn_user, High, None, Prover)
+ | Wrong_argument_number ml_loc
+ -> ( Localise.from_string "Wrong_argument_number" ~hum:"Wrong Argument Number"
+ , Localise.no_desc
+ , Some ml_loc
+ , Exn_developer
+ , Low
+ , None
+ , Nocat )
+ | Failure _ as f
+ -> raise f
+ | exn
+ -> let exn_name = Exn.to_string exn in
+ (Localise.from_string exn_name, Localise.no_desc, None, Exn_developer, Low, None, Nocat)
+ in
(err_name, desc, ml_loc_opt, visibility, severity, force_kind, eclass)
(** print a description of the exception to the html output *)
let print_exception_html s exn =
let err_name, desc, ml_loc_opt, _, _, _, _ = recognize_exception exn in
- let ml_loc_string = match ml_loc_opt with
- | None -> ""
- | Some ml_loc -> " " ^ L.ml_loc_to_string ml_loc in
+ let ml_loc_string =
+ match ml_loc_opt with None -> "" | Some ml_loc -> " " ^ L.ml_loc_to_string ml_loc
+ in
let desc_str = F.asprintf "%a" Localise.pp_error_desc desc in
- (L.d_strln_color Red) (s ^ (Localise.to_issue_id err_name) ^ " " ^ desc_str ^ ml_loc_string)
+ L.d_strln_color Red (s ^ Localise.to_issue_id err_name ^ " " ^ 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
@@ -352,17 +478,10 @@ let print_key = false
let pp_err ~node_key loc ekind ex_name desc ml_loc_opt fmt () =
let kind = err_kind_string (if equal_err_kind ekind Kinfo then Kwarning else ekind) in
let pp_key fmt k = if print_key then F.fprintf fmt " key: %d " k else () in
- F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n"
- SourceFile.pp loc.Location.file
- loc.Location.line
- kind
- Localise.pp ex_name
- Localise.pp_error_desc desc
- pp_key node_key
- L.pp_ml_loc_opt ml_loc_opt
+ F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n" SourceFile.pp loc.Location.file loc.Location.line kind
+ Localise.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 _, _, _, visibility, _, _, _ = recognize_exception exn in
- equal_visibility visibility Exn_user ||
- equal_visibility visibility Exn_developer
+ equal_visibility visibility Exn_user || equal_visibility visibility Exn_developer
diff --git a/infer/src/IR/Exceptions.mli b/infer/src/IR/Exceptions.mli
index 8a95078e0..9ac55d2d7 100644
--- a/infer/src/IR/Exceptions.mli
+++ b/infer/src/IR/Exceptions.mli
@@ -14,10 +14,10 @@ open! IStd
(** visibility of the exception *)
type visibility =
- | Exn_user (** always add to error log *)
- | Exn_developer (** only add to error log in developer mode *)
- | Exn_system (** never add to error log *)
-[@@deriving compare]
+ | Exn_user (** always add to error log *)
+ | Exn_developer (** only add to error log in developer mode *)
+ | Exn_system (** never add to error log *)
+ [@@deriving compare]
val equal_visibility : visibility -> visibility -> bool
@@ -25,9 +25,9 @@ val string_of_visibility : visibility -> string
(** severity of bugs *)
type severity =
- | High (** high severity bug *)
- | Medium (** medium severity bug *)
- | Low (** low severity bug *)
+ | High (** high severity bug *)
+ | Medium (** medium severity bug *)
+ | Low (** low severity bug *)
(** kind of error/warning *)
type err_kind = Kwarning | Kerror | Kinfo | Kadvice | Klike [@@deriving compare]
@@ -40,82 +40,144 @@ type err_class = Checker | Prover | Nocat | Linters
val equal_err_class : err_class -> err_class -> bool
exception Abduction_case_not_implemented of Logging.ml_loc
+
exception Analysis_stops of Localise.error_desc * Logging.ml_loc option
+
exception Array_of_pointsto of Logging.ml_loc
+
exception Array_out_of_bounds_l1 of Localise.error_desc * Logging.ml_loc
+
exception Array_out_of_bounds_l2 of Localise.error_desc * Logging.ml_loc
+
exception Array_out_of_bounds_l3 of Localise.error_desc * Logging.ml_loc
+
exception Bad_footprint of Logging.ml_loc
+
exception Cannot_star of Logging.ml_loc
+
exception Class_cast_exception of Localise.error_desc * Logging.ml_loc
+
exception Codequery of Localise.error_desc
+
exception Comparing_floats_for_equality of Localise.error_desc * Logging.ml_loc
+
exception Condition_always_true_false of Localise.error_desc * bool * Logging.ml_loc
+
exception Condition_is_assignment of Localise.error_desc * Logging.ml_loc
+
exception Context_leak of Localise.error_desc * Logging.ml_loc
+
exception Custom_error of string * Localise.error_desc
-exception Dangling_pointer_dereference of
- PredSymb.dangling_kind option * Localise.error_desc * Logging.ml_loc
+
+exception
+ Dangling_pointer_dereference of
+ PredSymb.dangling_kind option * Localise.error_desc * Logging.ml_loc
+
exception Deallocate_stack_variable of Localise.error_desc
+
exception Deallocate_static_memory of Localise.error_desc
+
exception Deallocation_mismatch of Localise.error_desc * Logging.ml_loc
+
exception Double_lock of Localise.error_desc * Logging.ml_loc
+
exception Divide_by_zero of Localise.error_desc * Logging.ml_loc
+
exception Field_not_null_checked of Localise.error_desc * Logging.ml_loc
+
exception Empty_vector_access of Localise.error_desc * Logging.ml_loc
+
exception Eradicate of string * Localise.error_desc
+
exception Checkers of string * Localise.error_desc
+
exception Frontend_warning of (string * string option) * Localise.error_desc * Logging.ml_loc
+
exception Inherently_dangerous_function of Localise.error_desc
+
exception Internal_error of Localise.error_desc
+
exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc
-exception Leak of
- bool * Sil.hpred * (visibility * Localise.error_desc)
- * bool * PredSymb.resource * Logging.ml_loc
+
+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
+
exception Premature_nil_termination of Localise.error_desc * Logging.ml_loc
+
exception Null_dereference of Localise.error_desc * Logging.ml_loc
+
exception Null_test_after_dereference of Localise.error_desc * Logging.ml_loc
+
exception Parameter_not_null_checked of Localise.error_desc * Logging.ml_loc
+
exception Pointer_size_mismatch of Localise.error_desc * Logging.ml_loc
+
exception Precondition_not_found of Localise.error_desc * Logging.ml_loc
+
exception Precondition_not_met of Localise.error_desc * Logging.ml_loc
+
exception Retain_cycle of Sil.hpred * Localise.error_desc * Logging.ml_loc
+
exception Registered_observer_being_deallocated of Localise.error_desc * Logging.ml_loc
+
exception Return_expression_required of Localise.error_desc * Logging.ml_loc
+
exception Return_statement_missing of Localise.error_desc * Logging.ml_loc
+
exception Return_value_ignored of Localise.error_desc * Logging.ml_loc
+
exception Skip_function of Localise.error_desc
+
exception Skip_pointer_dereference of Localise.error_desc * Logging.ml_loc
+
exception Stack_variable_address_escape of Localise.error_desc * Logging.ml_loc
+
exception Symexec_memory_error of Logging.ml_loc
+
exception Tainted_value_reaching_sensitive_function of Localise.error_desc * Logging.ml_loc
+
exception Unary_minus_applied_to_unsigned_expression of Localise.error_desc * Logging.ml_loc
+
exception Uninitialized_value of Localise.error_desc * Logging.ml_loc
+
exception Unknown_proc
+
exception Unreachable_code_after of Localise.error_desc * Logging.ml_loc
+
exception Unsafe_guarded_by_access of Localise.error_desc * Logging.ml_loc
+
exception Use_after_free of Localise.error_desc * Logging.ml_loc
+
exception Wrong_argument_number of Logging.ml_loc
-(** string describing an error class *)
val err_class_string : err_class -> string
+(** string describing an error class *)
-(** string describing an error kind *)
val err_kind_string : err_kind -> string
+(** string describing an error kind *)
-(** Return true if the exception is not serious and should be handled in timeout mode *)
val handle_exception : exn -> bool
+(** Return true if the exception is not serious and should be handled in timeout mode *)
-(** print a description of the exception to the html output *)
val print_exception_html : string -> exn -> unit
+(** print a description of the exception to the html output *)
+val pp_err :
+ node_key:int -> Location.t -> err_kind -> Localise.t -> Localise.error_desc
+ -> Logging.ml_loc option -> Format.formatter -> unit -> unit
(** pretty print an error *)
-val pp_err : node_key:int -> Location.t -> err_kind -> Localise.t -> Localise.error_desc ->
- Logging.ml_loc option -> Format.formatter -> unit -> unit
+val recognize_exception :
+ exn
+ -> Localise.t
+ * Localise.error_desc
+ * Logging.ml_loc option
+ * visibility
+ * severity
+ * err_kind option
+ * err_class
(** Turn an exception into an error name, error description,
location in ml source, and category *)
-val recognize_exception : exn ->
- (Localise.t * Localise.error_desc * (Logging.ml_loc option) * visibility *
- severity * err_kind option * err_class)
diff --git a/infer/src/IR/Exp.ml b/infer/src/IR/Exp.ml
new file mode 100644
index 000000000..c8a3569da
--- /dev/null
+++ b/infer/src/IR/Exp.ml
@@ -0,0 +1,259 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Expressions *)
+open! IStd
+module Hashtbl = Caml.Hashtbl
+module L = Logging
+module F = Format
+
+(* reverse the natural order on Var *)
+type _ident = Ident.t
+
+let compare__ident x y = Ident.compare y x
+
+type closure = {name: Typ.Procname.t; captured_vars: (t * Pvar.t * Typ.t) list}
+
+(** This records information about a [sizeof(typ)] expression.
+
+ [nbytes] represents the result of the evaluation of [sizeof(typ)] if it is statically known.
+
+ If [typ] is of the form [Tarray elt (Some static_length)], then [dynamic_length] is the number
+ of elements of type [elt] in the array. The [dynamic_length], tracked by symbolic execution, may
+ differ from the [static_length] obtained from the type definition, e.g. when an array is
+ over-allocated.
+
+ If [typ] is a struct type, the [dynamic_length] is that of the final extensible array, if any.*)
+and sizeof_data = {typ: Typ.t; nbytes: int option; dynamic_length: t option; subtype: Subtype.t}
+
+(** Program expressions. *)
+and t =
+ (** Pure variable: it is not an lvalue *)
+ | Var of _ident (** Unary operator with type of the result if known *)
+ | UnOp of Unop.t * t * Typ.t option (** Binary operator *)
+ | BinOp of Binop.t * t * t (** Exception *)
+ | Exn of t (** Anonymous function *)
+ | Closure of closure (** Constants *)
+ | Const of Const.t (** Type cast *)
+ | Cast of Typ.t * t (** The address of a program variable *)
+ | Lvar of Pvar.t (** A field offset, the type is the surrounding struct type *)
+ | Lfield of t * Typ.Fieldname.t * Typ.t (** An array index offset: [exp1\[exp2\]] *)
+ | Lindex of t * t
+ | Sizeof of sizeof_data
+ [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+let hash = Hashtbl.hash
+
+module Set = Caml.Set.Make (struct
+ type nonrec t = t
+
+ let compare = compare
+end)
+
+module Map = Caml.Map.Make (struct
+ type nonrec t = t
+
+ let compare = compare
+end)
+
+module Hash = Hashtbl.Make (struct
+ type nonrec t = t
+
+ let equal = equal
+
+ let hash = hash
+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
+
+let is_zero = function Const Cint n -> IntLit.iszero n | _ -> false
+
+(** {2 Utility Functions for Expressions} *)
+
+(** 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
+
+(** 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
+
+(** 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
+
+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
+
+(** 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
+
+(** Create integer constant *)
+let int i = Const (Cint i)
+
+(** Create float constant *)
+let float v = Const (Cfloat v)
+
+(** Integer constant 0 *)
+let zero = int IntLit.zero
+
+(** Null constant *)
+let null = int IntLit.null
+
+(** Integer constant 1 *)
+let one = int IntLit.one
+
+(** Integer constant -1 *)
+let minus_one = int IntLit.minus_one
+
+(** Create integer constant corresponding to the boolean value *)
+let bool b = if b then one else zero
+
+(** Create expresstion [e1 == e2] *)
+let eq e1 e2 = BinOp (Eq, e1, e2)
+
+(** Create expresstion [e1 != e2] *)
+let ne e1 e2 = BinOp (Ne, e1, e2)
+
+(** Create expression [e1 <= e2] *)
+let le e1 e2 = BinOp (Le, e1, e2)
+
+(** Create expression [e1 < e2] *)
+let lt e1 e2 = BinOp (Lt, e1, e2)
+
+(** Extract the ids and pvars from an expression *)
+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
+ -> 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
+ (* TODO: Sizeof dynamic length expressions may contain variables, do not ignore them. *)
+ | 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
+ 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
+ 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
+ let pp_size f size = Option.iter ~f:(Int.pp f) size in
+ F.fprintf f "sizeof(%a%a%a%a)" pp_t typ pp_size nbytes pp_len dynamic_length Subtype.pp
+ 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
+
+let to_string e = F.asprintf "%a" pp e
diff --git a/infer/src/IR/Exp.mli b/infer/src/IR/Exp.mli
new file mode 100644
index 000000000..5dddfd601
--- /dev/null
+++ b/infer/src/IR/Exp.mli
@@ -0,0 +1,159 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** The Smallfoot Intermediate Language: Expressions *)
+open! IStd
+module L = Logging
+module F = Format
+
+type closure = {name: Typ.Procname.t; captured_vars: (t * Pvar.t * Typ.t) list}
+
+(** This records information about a [sizeof(typ)] expression.
+
+ [nbytes] represents the result of the evaluation of [sizeof(typ)] if it is statically known.
+
+ If [typ] is of the form [Tarray elt (Some static_length)], then [dynamic_length] is the number
+ of elements of type [elt] in the array. The [dynamic_length], tracked by symbolic execution, may
+ differ from the [static_length] obtained from the type definition, e.g. when an array is
+ over-allocated.
+
+ If [typ] is a struct type, the [dynamic_length] is that of the final extensible array, if any.*)
+and sizeof_data = {typ: Typ.t; nbytes: int option; dynamic_length: t option; subtype: Subtype.t}
+
+(** Program expressions. *)
+and t =
+ (** Pure variable: it is not an lvalue *)
+ | Var of Ident.t (** Unary operator with type of the result if known *)
+ | UnOp of Unop.t * t * Typ.t option (** Binary operator *)
+ | BinOp of Binop.t * t * t (** Exception *)
+ | Exn of t (** Anonymous function *)
+ | Closure of closure (** Constants *)
+ | Const of Const.t (** Type cast *)
+ | Cast of Typ.t * t (** The address of a program variable *)
+ | Lvar of Pvar.t (** A field offset, the type is the surrounding struct type *)
+ | Lfield of t * Typ.Fieldname.t * Typ.t (** An array index offset: [exp1\[exp2\]] *)
+ | Lindex of t * t
+ | Sizeof of sizeof_data
+ [@@deriving compare]
+
+(** Equality for expressions. *)
+
+val equal : t -> t -> bool
+
+(** Hash function for expressions. *)
+
+val hash : t -> int
+
+(** Set of expressions. *)
+
+module Set : Caml.Set.S with type elt = t
+
+(** Map with expression keys. *)
+
+module Map : Caml.Map.S with type key = t
+
+(** Hashtable with expression keys. *)
+
+module Hash : Caml.Hashtbl.S with type key = t
+
+(** returns true is index is an array index of arr. *)
+
+val is_array_index_of : t -> t -> bool
+
+val is_null_literal : t -> bool
+
+(** return true if [exp] is the special this/self expression *)
+
+val is_this : t -> bool
+
+val is_zero : t -> bool
+
+(** {2 Utility Functions for Expressions} *)
+
+(** 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 *)
+
+val texp_to_typ : Typ.t option -> t -> Typ.t
+
+(** Return the root of [lexp]. *)
+
+val root_of_lexp : t -> t
+
+(** Get an expression "undefined", the boolean indicates
+ whether the undefined value goest into the footprint *)
+
+val get_undefined : bool -> t
+
+(** Checks whether an expression denotes a location using pointer arithmetic.
+ Currently, catches array - indexing expressions such as a[i] only. *)
+
+val pointer_arith : t -> bool
+
+(** returns true if the expression represents a stack-directed address *)
+
+val is_stack_addr : t -> bool
+
+(** returns true if the expression operates on address of local variable *)
+
+val has_local_addr : t -> bool
+
+(** Integer constant 0 *)
+
+val zero : t
+
+(** Null constant *)
+
+val null : t
+
+(** Integer constant 1 *)
+
+val one : t
+
+(** Integer constant -1 *)
+
+val minus_one : t
+
+(** Create integer constant *)
+
+val int : IntLit.t -> t
+
+(** Create float constant *)
+
+val float : float -> t
+
+(** Create integer constant corresponding to the boolean value *)
+
+val bool : bool -> t
+
+(** Create expresstion [e1 == e2] *)
+
+val eq : t -> t -> t
+
+(** Create expresstion [e1 != e2] *)
+
+val ne : t -> t -> t
+
+(** Create expresstion [e1 <= e2] *)
+
+val le : t -> t -> t
+
+(** Create expression [e1 < e2] *)
+
+val lt : t -> t -> t
+
+(** Extract the ids and pvars from an expression *)
+
+val get_vars : t -> Ident.t list * Pvar.t list
+
+val pp_printenv : Pp.env -> (Pp.env -> F.formatter -> Typ.t -> unit) -> F.formatter -> t -> unit
+
+val pp : F.formatter -> t -> unit
+
+val to_string : t -> string
diff --git a/infer/src/IR/Exp.re b/infer/src/IR/Exp.re
deleted file mode 100644
index f2e7ba2e7..000000000
--- a/infer/src/IR/Exp.re
+++ /dev/null
@@ -1,280 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module Hashtbl = Caml.Hashtbl;
-
-
-/** The Smallfoot Intermediate Language: Expressions */
-module L = Logging;
-
-module F = Format;
-
-/* reverse the natural order on Var */
-type _ident = Ident.t;
-
-let compare__ident x y => Ident.compare y x;
-
-type closure = {name: Typ.Procname.t, captured_vars: list (t, Pvar.t, Typ.t)}
-/** This records information about a [sizeof(typ)] expression.
-
- [nbytes] represents the result of the evaluation of [sizeof(typ)] if it is statically known.
-
- If [typ] is of the form [Tarray elt (Some static_length)], then [dynamic_length] is the number
- of elements of type [elt] in the array. The [dynamic_length], tracked by symbolic execution, may
- differ from the [static_length] obtained from the type definition, e.g. when an array is
- over-allocated.
-
- If [typ] is a struct type, the [dynamic_length] is that of the final extensible array, if any.*/
-and sizeof_data = {typ: Typ.t, nbytes: option int, dynamic_length: option t, subtype: Subtype.t}
-/** Program expressions. */
-and t =
- /** Pure variable: it is not an lvalue */
- | Var _ident
- /** Unary operator with type of the result if known */
- | UnOp Unop.t t (option Typ.t)
- /** Binary operator */
- | BinOp Binop.t t t
- /** Exception */
- | Exn t
- /** Anonymous function */
- | Closure closure
- /** Constants */
- | Const Const.t
- /** Type cast */
- | Cast Typ.t t
- /** The address of a program variable */
- | Lvar Pvar.t
- /** A field offset, the type is the surrounding struct type */
- | Lfield t Typ.Fieldname.t Typ.t
- /** An array index offset: [exp1\[exp2\]] */
- | Lindex t t
- | Sizeof sizeof_data
-[@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-let hash = Hashtbl.hash;
-
-module Set =
- Caml.Set.Make {
- type nonrec t = t;
- let compare = compare;
- };
-
-module Map =
- Caml.Map.Make {
- type nonrec t = t;
- let compare = compare;
- };
-
-module Hash =
- Hashtbl.Make {
- type nonrec t = t;
- let equal = equal;
- let hash = hash;
- };
-
-let rec is_array_index_of exp1 exp2 =>
- switch exp1 {
- | Lindex exp _ => is_array_index_of exp exp2
- | _ => equal exp1 exp2
- };
-
-let is_null_literal =
- fun
- | Const (Cint n) => IntLit.isnull n
- | _ => false;
-
-let is_this =
- fun
- | Lvar pvar => Pvar.is_this pvar
- | _ => false;
-
-let is_zero =
- fun
- | Const (Cint n) => IntLit.iszero n
- | _ => false;
-
-
-/** {2 Utility Functions for Expressions} */
-
-/** 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 =>
- fun
- | Sizeof {typ} => typ
- | _ => Typ.unsome "texp_to_typ" default_opt;
-
-
-/** Return the root of [lexp]. */
-let rec root_of_lexp lexp =>
- switch (lexp: t) {
- | 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 =
- fun
- | Lfield e _ _ => pointer_arith e
- | Lindex _ => true
- | _ => false;
-
-let get_undefined footprint =>
- Var (Ident.create_fresh (if footprint {Ident.kfootprint} else {Ident.kprimed}));
-
-
-/** returns true if the expression represents a stack-directed address */
-let rec is_stack_addr e =>
- switch (e: t) {
- | 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 =>
- switch (e: t) {
- | 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);
-
-
-/** Create float constant */
-let float v => Const (Cfloat v);
-
-
-/** Integer constant 0 */
-let zero = int IntLit.zero;
-
-
-/** Null constant */
-let null = int IntLit.null;
-
-
-/** Integer constant 1 */
-let one = int IntLit.one;
-
-
-/** Integer constant -1 */
-let minus_one = int IntLit.minus_one;
-
-
-/** Create integer constant corresponding to the boolean value */
-let bool b => if b {one} else {zero};
-
-
-/** Create expresstion [e1 == e2] */
-let eq e1 e2 => BinOp Eq e1 e2;
-
-
-/** Create expresstion [e1 != e2] */
-let ne e1 e2 => BinOp Ne e1 e2;
-
-
-/** Create expression [e1 <= e2] */
-let le e1 e2 => BinOp Le e1 e2;
-
-
-/** Create expression [e1 < e2] */
-let lt e1 e2 => BinOp Lt e1 e2;
-
-
-/** Extract the ids and pvars from an expression */
-let get_vars exp => {
- let rec get_vars_ exp vars =>
- switch exp {
- | Lvar pvar => (fst vars, [pvar, ...snd vars])
- | Var id => ([id, ...fst vars], snd vars)
- | Cast _ e
- | UnOp _ e _
- | Lfield e _ _
- | Exn 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
- /* TODO: Sizeof dynamic length expressions may contain variables, do not ignore them. */
- | Sizeof _ => vars
- };
- get_vars_ exp ([], [])
-};
-
-
-/** Pretty print an expression. */
-let rec pp_ pe pp_t f e => {
- let pp_exp = pp_ pe pp_t;
- let print_binop_stm_output e1 op e2 =>
- switch (op: Binop.t) {
- | 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
- };
- switch (e: t) {
- | 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;
- 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;
- let pp_size f size => Option.iter f::(Int.pp f) size;
- F.fprintf f "sizeof(%a%a%a%a)" pp_t typ pp_size nbytes pp_len dynamic_length Subtype.pp 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;
-
-let to_string e => F.asprintf "%a" pp e;
diff --git a/infer/src/IR/Exp.rei b/infer/src/IR/Exp.rei
deleted file mode 100644
index 36715bc2c..000000000
--- a/infer/src/IR/Exp.rei
+++ /dev/null
@@ -1,168 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** The Smallfoot Intermediate Language: Expressions */
-module L = Logging;
-
-module F = Format;
-
-type closure = {name: Typ.Procname.t, captured_vars: list (t, Pvar.t, Typ.t)}
-/** This records information about a [sizeof(typ)] expression.
-
- [nbytes] represents the result of the evaluation of [sizeof(typ)] if it is statically known.
-
- If [typ] is of the form [Tarray elt (Some static_length)], then [dynamic_length] is the number
- of elements of type [elt] in the array. The [dynamic_length], tracked by symbolic execution, may
- differ from the [static_length] obtained from the type definition, e.g. when an array is
- over-allocated.
-
- If [typ] is a struct type, the [dynamic_length] is that of the final extensible array, if any.*/
-and sizeof_data = {typ: Typ.t, nbytes: option int, dynamic_length: option t, subtype: Subtype.t}
-/** Program expressions. */
-and t =
- /** Pure variable: it is not an lvalue */
- | Var Ident.t
- /** Unary operator with type of the result if known */
- | UnOp Unop.t t (option Typ.t)
- /** Binary operator */
- | BinOp Binop.t t t
- /** Exception */
- | Exn t
- /** Anonymous function */
- | Closure closure
- /** Constants */
- | Const Const.t
- /** Type cast */
- | Cast Typ.t t
- /** The address of a program variable */
- | Lvar Pvar.t
- /** A field offset, the type is the surrounding struct type */
- | Lfield t Typ.Fieldname.t Typ.t
- /** An array index offset: [exp1\[exp2\]] */
- | Lindex t t
- | Sizeof sizeof_data
-[@@deriving compare];
-
-
-/** Equality for expressions. */
-let equal: t => t => bool;
-
-
-/** Hash function for expressions. */
-let hash: t => int;
-
-
-/** Set of expressions. */
-module Set: Caml.Set.S with type elt = t;
-
-
-/** Map with expression keys. */
-module Map: Caml.Map.S with type key = t;
-
-
-/** Hashtable with expression keys. */
-module Hash: Caml.Hashtbl.S with type key = t;
-
-
-/** returns true is index is an array index of arr. */
-let is_array_index_of: t => t => bool;
-
-let is_null_literal: t => bool;
-
-
-/** return true if [exp] is the special this/self expression */
-let is_this: t => bool;
-
-let is_zero: t => bool;
-
-
-/** {2 Utility Functions for Expressions} */
-
-/** 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: option Typ.t => t => Typ.t;
-
-
-/** Return the root of [lexp]. */
-let root_of_lexp: t => t;
-
-
-/** Get an expression "undefined", the boolean indicates
- whether the undefined value goest into the footprint */
-let get_undefined: bool => t;
-
-
-/** Checks whether an expression denotes a location using pointer arithmetic.
- Currently, catches array - indexing expressions such as a[i] only. */
-let pointer_arith: t => bool;
-
-
-/** returns true if the expression represents a stack-directed address */
-let is_stack_addr: t => bool;
-
-
-/** returns true if the expression operates on address of local variable */
-let has_local_addr: t => bool;
-
-
-/** Integer constant 0 */
-let zero: t;
-
-
-/** Null constant */
-let null: t;
-
-
-/** Integer constant 1 */
-let one: t;
-
-
-/** Integer constant -1 */
-let minus_one: t;
-
-
-/** Create integer constant */
-let int: IntLit.t => t;
-
-
-/** Create float constant */
-let float: float => t;
-
-
-/** Create integer constant corresponding to the boolean value */
-let bool: bool => t;
-
-
-/** Create expresstion [e1 == e2] */
-let eq: t => t => t;
-
-
-/** Create expresstion [e1 != e2] */
-let ne: t => t => t;
-
-
-/** Create expresstion [e1 <= e2] */
-let le: t => t => t;
-
-
-/** Create expression [e1 < e2] */
-let lt: t => t => t;
-
-
-/** Extract the ids and pvars from an expression */
-let get_vars: t => (list Ident.t, list Pvar.t);
-
-let pp_printenv: Pp.env => (Pp.env => F.formatter => Typ.t => unit) => F.formatter => t => unit;
-
-let pp: F.formatter => t => unit;
-
-let to_string: t => string;
diff --git a/infer/src/IR/HilExp.ml b/infer/src/IR/HilExp.ml
index 086ab49b8..0ebb5e3ff 100644
--- a/infer/src/IR/HilExp.ml
+++ b/infer/src/IR/HilExp.ml
@@ -8,7 +8,6 @@
*)
open! IStd
-
module F = Format
module L = Logging
@@ -21,107 +20,109 @@ type t =
| Constant of Const.t
| Cast of Typ.t * t
| Sizeof of Typ.t * t option
-[@@deriving compare]
+ [@@deriving compare]
let rec pp fmt = function
- | AccessPath access_path ->
- AccessPath.Raw.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.Raw.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 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 in
+ | 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
using [f_resolve_id] *)
-let rec of_sil ~f_resolve_id (exp : Exp.t) typ = match exp with
- | Var id ->
- let ap = match f_resolve_id (Var.of_id id) with
- | Some access_path -> access_path
- | None -> AccessPath.of_id id typ in
+let rec of_sil ~f_resolve_id (exp: Exp.t) typ =
+ match exp with
+ | Var id
+ -> let ap =
+ match f_resolve_id (Var.of_id id) with
+ | Some access_path
+ -> access_path
+ | None
+ -> AccessPath.of_id id typ
+ in
AccessPath ap
- | UnOp (op, e, typ_opt) ->
- UnaryOperator (op, of_sil ~f_resolve_id e typ, typ_opt)
- | BinOp (op, e0, e1) ->
- BinaryOperator (op, of_sil ~f_resolve_id e0 typ, of_sil ~f_resolve_id e1 typ)
- | Exn e ->
- Exception (of_sil ~f_resolve_id e typ)
- | Const c ->
- Constant c
- | Cast (cast_typ, e) ->
- Cast (cast_typ, of_sil ~f_resolve_id e typ)
- | Sizeof {typ; dynamic_length} ->
- Sizeof (typ, Option.map ~f:(fun e -> of_sil ~f_resolve_id e typ) dynamic_length)
- | Closure closure ->
- let environment =
+ | UnOp (op, e, typ_opt)
+ -> UnaryOperator (op, of_sil ~f_resolve_id e typ, typ_opt)
+ | BinOp (op, e0, e1)
+ -> BinaryOperator (op, of_sil ~f_resolve_id e0 typ, of_sil ~f_resolve_id e1 typ)
+ | Exn e
+ -> Exception (of_sil ~f_resolve_id e typ)
+ | Const c
+ -> Constant c
+ | Cast (cast_typ, e)
+ -> Cast (cast_typ, of_sil ~f_resolve_id e typ)
+ | Sizeof {typ; dynamic_length}
+ -> Sizeof (typ, Option.map ~f:(fun e -> of_sil ~f_resolve_id e typ) dynamic_length)
+ | Closure closure
+ -> let environment =
List.map
~f:(fun (value, pvar, typ) ->
- AccessPath.base_of_pvar pvar typ, of_sil ~f_resolve_id value typ)
- closure.captured_vars in
+ (AccessPath.base_of_pvar pvar typ, of_sil ~f_resolve_id value typ))
+ closure.captured_vars
+ in
Closure (closure.name, environment)
| Lfield (root_exp, fld, root_exp_typ) -> (
- match AccessPath.of_lhs_exp exp typ ~f_resolve_id with
- | Some access_path ->
- AccessPath access_path
- | None ->
- (* unsupported field expression: represent with a dummy variable *)
- of_sil ~f_resolve_id
- (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
+ match AccessPath.of_lhs_exp exp typ ~f_resolve_id with
+ | Some access_path
+ -> AccessPath access_path
+ | None
+ -> (* unsupported field expression: represent with a dummy variable *)
+ of_sil ~f_resolve_id
+ (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
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` *)
of_sil ~f_resolve_id
(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 exp typ ~f_resolve_id with
- | Some access_path ->
- AccessPath access_path
- | None ->
- (* unsupported index expression: represent with a dummy variable *)
- of_sil ~f_resolve_id
- (Exp.Lindex
- (Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0),
- index_exp))
- typ )
+ match AccessPath.of_lhs_exp exp typ ~f_resolve_id with
+ | Some access_path
+ -> AccessPath access_path
+ | None
+ -> (* unsupported index expression: represent with a dummy variable *)
+ of_sil ~f_resolve_id
+ (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 exp typ ~f_resolve_id with
- | Some access_path ->
- AccessPath access_path
- | None ->
- failwithf "Couldn't convert var expression %a to access path" Exp.pp exp
+ match AccessPath.of_lhs_exp exp typ ~f_resolve_id with
+ | Some access_path
+ -> AccessPath access_path
+ | None
+ -> failwithf "Couldn't convert var expression %a to access path" Exp.pp exp
-let is_null_literal = function
- | Constant (Cint n) -> IntLit.isnull n
- | _ -> false
+let is_null_literal = function Constant Cint n -> IntLit.isnull n | _ -> false
diff --git a/infer/src/IR/HilExp.mli b/infer/src/IR/HilExp.mli
index 61a17dba1..7018814b7 100644
--- a/infer/src/IR/HilExp.mli
+++ b/infer/src/IR/HilExp.mli
@@ -8,36 +8,29 @@
*)
open! IStd
-
module F = Format
type t =
- | AccessPath of AccessPath.Raw.t
- (** access path (e.g., x.f.g or x[i]) *)
+ | AccessPath of AccessPath.Raw.t (** access path (e.g., x.f.g or x[i]) *)
| UnaryOperator of Unop.t * t * Typ.t option
- (** Unary operator with type of the result if known *)
- | BinaryOperator of Binop.t * t * t
- (** Binary operator *)
- | Exception of t
- (** Exception *)
- | Closure of Typ.Procname.t * (AccessPath.base * t) list
- (** Name of function + environment *)
- | Constant of Const.t
- (** Constants *)
- | Cast of Typ.t * t
- (** Type cast *)
+ (** Unary operator with type of the result if known *)
+ | BinaryOperator of Binop.t * t * t (** Binary operator *)
+ | Exception of t (** Exception *)
+ | Closure of Typ.Procname.t * (AccessPath.base * t) list (** Name of function + environment *)
+ | Constant of Const.t (** Constants *)
+ | Cast of Typ.t * t (** Type cast *)
| Sizeof of Typ.t * t option
- (** C-style sizeof(), and also used to treate a type as an expression. Refer to [Exp] module for
+ (** C-style sizeof(), and also used to treate a type as an expression. Refer to [Exp] module for
canonical documentation *)
-[@@deriving compare]
+ [@@deriving compare]
val pp : F.formatter -> t -> unit
-(** Convert SIL expression to HIL expression *)
val of_sil : f_resolve_id:(Var.t -> AccessPath.Raw.t option) -> Exp.t -> Typ.t -> t
+(** Convert SIL expression to HIL expression *)
+val get_access_paths : t -> AccessPath.Raw.t list
(** Get all the access paths used in the given HIL expression, including duplicates if a path is
used more than once. *)
-val get_access_paths : t -> AccessPath.Raw.t list
val is_null_literal : t -> bool
diff --git a/infer/src/IR/HilInstr.ml b/infer/src/IR/HilInstr.ml
index 65d526b7f..4a3e8ebfd 100644
--- a/infer/src/IR/HilInstr.ml
+++ b/infer/src/IR/HilInstr.ml
@@ -8,108 +8,110 @@
*)
open! IStd
-
module F = Format
module L = Logging
-type call =
- | Direct of Typ.Procname.t
- | Indirect of AccessPath.Raw.t
-[@@deriving compare]
+type call = Direct of Typ.Procname.t | Indirect of AccessPath.Raw.t [@@deriving compare]
let pp_call fmt = function
- | Direct pname -> Typ.Procname.pp fmt pname
- | Indirect access_path -> F.fprintf fmt "*%a" AccessPath.Raw.pp access_path
+ | Direct pname
+ -> Typ.Procname.pp fmt pname
+ | Indirect access_path
+ -> F.fprintf fmt "*%a" AccessPath.Raw.pp access_path
type t =
| Assign of AccessPath.Raw.t * HilExp.t * Location.t
| Assume of HilExp.t * [`Then | `Else] * Sil.if_kind * Location.t
| Call of AccessPath.base option * call * HilExp.t list * CallFlags.t * Location.t
-[@@deriving compare]
+ [@@deriving compare]
let pp fmt = function
- | Assign (access_path, exp, loc) ->
- F.fprintf fmt "%a := %a [%a]" AccessPath.Raw.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.Raw.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.Raw.t
- | Unbind of Var.t list
- | Ignore
+type translation = Instr of t | Bind of Var.t * AccessPath.Raw.t | Unbind of Var.t list | Ignore
(* convert an SIL instruction into an HIL instruction. the [f_resolve_id] function should map an SSA
temporary variable to the access path it represents. evaluating the HIL instruction should
produce the same result as evaluating the SIL instruction and replacing the temporary variables
using [f_resolve_id]. *)
-let of_sil ~f_resolve_id (instr : Sil.instr) =
+let of_sil ~f_resolve_id (instr: Sil.instr) =
let analyze_id_assignment lhs_id rhs_exp rhs_typ loc =
let rhs_hil_exp = HilExp.of_sil ~f_resolve_id 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)) in
+ | [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
- | 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 =
+ | 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 =
match HilExp.of_sil ~f_resolve_id lhs_exp typ with
- | AccessPath ap ->
- ap
- | BinaryOperator (_, exp0, exp1) ->
+ | AccessPath ap
+ -> ap
+ | BinaryOperator (_, exp0, exp1) -> (
+ match
(* pointer arithmetic. somewhere in one of the expressions, there should be at least
one pointer type represented as an access path. just use that access path and forget
about the arithmetic. if you need to model this more precisely, you should be using
SIL instead *)
- begin
- match HilExp.get_access_paths exp0 with
- | ap :: _ ->
- ap
- | [] ->
- begin
- match HilExp.get_access_paths exp1 with
- | ap :: _ ->
- ap
- | [] ->
- invalid_argf
- "Invalid pointer arithmetic expression %a used as LHS" Exp.pp lhs_exp
- end
- end
- | _ ->
- invalid_argf "Non-assignable LHS expression %a" Exp.pp lhs_exp in
+ HilExp.get_access_paths exp0
+ with
+ | ap :: _
+ -> ap
+ | [] ->
+ match HilExp.get_access_paths exp1 with
+ | ap :: _
+ -> ap
+ | []
+ -> invalid_argf "Invalid pointer arithmetic expression %a used as LHS" Exp.pp lhs_exp
+ )
+ | _
+ -> invalid_argf "Non-assignable LHS expression %a" Exp.pp lhs_exp
+ in
Instr (Assign (lhs_access_path, HilExp.of_sil ~f_resolve_id 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 HilExp.of_sil ~f_resolve_id call_exp (Typ.mk Tvoid) with
- | Constant (Cfun procname) -> Direct procname
- | AccessPath access_path -> Indirect access_path
- | call_exp -> invalid_argf "Unexpected call expression %a" HilExp.pp call_exp in
+ | Constant Cfun procname
+ -> Direct procname
+ | AccessPath access_path
+ -> Indirect access_path
+ | call_exp
+ -> invalid_argf "Unexpected call expression %a" HilExp.pp call_exp
+ in
let formals = List.map ~f:(fun (exp, typ) -> HilExp.of_sil ~f_resolve_id exp typ) formals in
Instr (Call (hil_ret, hil_call, formals, call_flags, loc))
- | Prune (exp, loc, true_branch, if_kind) ->
- let hil_exp = HilExp.of_sil ~f_resolve_id exp (Typ.mk (Tint IBool)) in
+ | Prune (exp, loc, true_branch, if_kind)
+ -> let hil_exp = HilExp.of_sil ~f_resolve_id 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 *)
+ | Abstract _
+ | Declare_locals _
+ -> (* these don't seem useful for most analyses. can translate them later if we want to *)
Ignore
diff --git a/infer/src/IR/HilInstr.mli b/infer/src/IR/HilInstr.mli
index c72557f9f..3686d2883 100644
--- a/infer/src/IR/HilInstr.mli
+++ b/infer/src/IR/HilInstr.mli
@@ -8,34 +8,29 @@
*)
open! IStd
-
module F = Format
(** type of a procedure call; either direct or via function pointer *)
-type call =
- | Direct of Typ.Procname.t
- | Indirect of AccessPath.Raw.t
-[@@deriving compare]
+type call = Direct of Typ.Procname.t | Indirect of AccessPath.Raw.t [@@deriving compare]
val pp_call : F.formatter -> call -> unit
type t =
- | Assign of AccessPath.Raw.t * HilExp.t * Location.t
- (** LHS access path, RHS expression *)
+ | Assign of AccessPath.Raw.t * HilExp.t * Location.t (** LHS access path, RHS expression *)
| Assume of HilExp.t * [`Then | `Else] * Sil.if_kind * Location.t
- (** Assumed expression, true_branch boolean, source of the assume (conditional, ternary, etc.) *)
+ (** Assumed expression, true_branch boolean, source of the assume (conditional, ternary, etc.) *)
| Call of AccessPath.base option * call * HilExp.t list * CallFlags.t * Location.t
- (** Var to hold the return if it exists, call expression, formals *)
-[@@deriving compare]
+ (** Var to hold the return if it exists, call expression, formals *)
+ [@@deriving compare]
val pp : F.formatter -> t -> unit
(** Result of translating an SIL instruction *)
type translation =
- | Instr of t (** HIL instruction to execute *)
- | Bind of Var.t * AccessPath.Raw.t (** add binding to identifier map *)
- | Unbind of Var.t list (** remove binding from identifier map *)
- | Ignore (** no-op *)
+ | Instr of t (** HIL instruction to execute *)
+ | Bind of Var.t * AccessPath.Raw.t (** add binding to identifier map *)
+ | Unbind of Var.t list (** remove binding from identifier map *)
+ | Ignore (** no-op *)
-(** Convert an SIL instruction to an HIL instruction *)
val of_sil : f_resolve_id:(Var.t -> AccessPath.Raw.t option) -> Sil.instr -> translation
+(** Convert an SIL instruction to an HIL instruction *)
diff --git a/infer/src/IR/Ident.ml b/infer/src/IR/Ident.ml
new file mode 100644
index 000000000..8c4ebac5a
--- /dev/null
+++ b/infer/src/IR/Ident.ml
@@ -0,0 +1,256 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+(** Module for Names and Identifiers *)
+open! IStd
+module Hashtbl = Caml.Hashtbl
+module L = Logging
+module F = Format
+
+module Name = struct
+ type t = Primed | Normal | Footprint | Spec | FromString of string [@@deriving compare]
+
+ let primed = "t"
+
+ let normal = "n"
+
+ let footprint = "f"
+
+ let spec = "val"
+
+ let from_string s = FromString s
+
+ let to_string = function
+ | Primed
+ -> primed
+ | Normal
+ -> normal
+ | Footprint
+ -> footprint
+ | Spec
+ -> spec
+ | FromString s
+ -> s
+end
+
+type name = Name.t [@@deriving compare]
+
+let name_spec = Name.Spec
+
+let name_primed = Name.Primed
+
+let equal_name = [%compare.equal : name]
+
+type kind =
+ | KNone
+ (** special kind of "null ident" (basically, a more compact way of implementing an ident option).
+ useful for situations when an instruction requires an id, but no one should read the result. *)
+ | KFootprint
+ | KNormal
+ | KPrimed
+ [@@deriving compare]
+
+let kfootprint = KFootprint
+
+let knormal = KNormal
+
+let kprimed = KPrimed
+
+let equal_kind = [%compare.equal : kind]
+
+(* timestamp for a path identifier *)
+let path_ident_stamp = -3
+
+type t = {kind: kind; name: Name.t; stamp: int} [@@deriving compare]
+
+(* most unlikely first *)
+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
+
+ let compare = compare
+end)
+
+module IdentMap = Caml.Map.Make (struct
+ type nonrec t = t
+
+ let compare = compare
+end)
+
+module IdentHash = Hashtbl.Make (struct
+ type nonrec t = t
+
+ let equal = equal
+
+ let hash (id: t) = Hashtbl.hash id
+end)
+
+let idlist_to_idset ids = List.fold ~f:(fun set id -> IdentSet.add id set) ~init:IdentSet.empty ids
+
+(** {2 Conversion between Names and Strings} *)
+module NameHash = Hashtbl.Make (struct
+ type t = name
+
+ let equal = equal_name
+
+ let hash = Hashtbl.hash
+end)
+
+(** Convert a string to a name *)
+let string_to_name = Name.from_string
+
+(** Convert a name to a string. *)
+let name_to_string = Name.to_string
+
+(** {2 Functions and Hash Tables for Managing Stamps} *)
+
+(** Set the stamp of the identifier *)
+let set_stamp i stamp = {i with stamp}
+
+(** Get the stamp of the identifier *)
+let get_stamp i = i.stamp
+
+module NameGenerator = struct
+ type t = int NameHash.t
+
+ let create () : t = NameHash.create 17
+
+ (** Map from names to stamps. *)
+ let name_map = ref (create ())
+
+ let get_current () = !name_map
+
+ let set_current map = name_map := map
+
+ (** Reset the name generator *)
+ let reset () = name_map := create ()
+
+ (** Create a fresh identifier with the given kind and name. *)
+ let create_fresh_ident kind name =
+ let stamp =
+ try
+ let stamp = NameHash.find !name_map name in
+ NameHash.replace !name_map name (stamp + 1) ;
+ stamp + 1
+ with Not_found ->
+ NameHash.add !name_map name 0 ;
+ 0
+ in
+ {kind; name; stamp}
+
+ (** Make sure that fresh ids after whis one will be with different stamps *)
+ let update_name_hash name stamp =
+ try
+ let curr_stamp = NameHash.find !name_map name in
+ 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 *)
+let name_return = Mangled.from_string "return"
+
+(** Return the standard name for the given kind *)
+let standard_name kind =
+ if equal_kind kind KNormal || equal_kind kind KNone then Name.Normal
+ 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}
+
+(** Create an identifier with default name for the given kind *)
+let create kind stamp = create_with_stamp kind (standard_name kind) stamp
+
+(** Generate a normal identifier with the given name and stamp *)
+let create_normal name stamp = create_with_stamp KNormal name stamp
+
+(** Create a fresh identifier with default name for the given kind. *)
+let create_fresh kind = NameGenerator.create_fresh_ident kind (standard_name kind)
+
+let create_none () = create_fresh KNone
+
+(** Generate a primed identifier with the given name and stamp *)
+let create_primed name stamp = create_with_stamp KPrimed name stamp
+
+(** Generate a footprint identifier with the given name and stamp *)
+let create_footprint name stamp = create_with_stamp KFootprint name stamp
+
+(** {2 Functions for Identifiers} *)
+
+(** Get a name of an identifier *)
+let get_name id = id.name
+
+let has_kind id kind = equal_kind id.kind kind
+
+let is_primed (id: t) = has_kind id KPrimed
+
+let is_normal (id: t) = has_kind id KNormal || has_kind id KNone
+
+let is_footprint (id: t) = has_kind id KFootprint
+
+let is_none (id: t) = has_kind id KNone
+
+let is_path (id: t) = has_kind id KNormal && Int.equal id.stamp path_ident_stamp
+
+let make_unprimed id =
+ if not (has_kind id KPrimed) then assert false
+ 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. *)
+let to_string id =
+ if has_kind id KNone then "_"
+ else
+ let base_name = name_to_string id.name in
+ let prefix = if has_kind id KFootprint then "@" else if has_kind id KNormal then "" else "_" in
+ 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)
+
+(** Pretty print a name in latex. *)
+let pp_name_latex style f (name: name) = Latex.pp_string style f (name_to_string name)
+
+(** 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
+ let style =
+ if has_kind id KFootprint then Latex.Boldface
+ else if has_kind id KNormal then Latex.Roman
+ else Latex.Roman
+ 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)
+
+(** pretty printer for lists of names *)
+let pp_name_list = Pp.comma_seq pp_name
diff --git a/infer/src/IR/Ident.mli b/infer/src/IR/Ident.mli
new file mode 100644
index 000000000..f6674ce2d
--- /dev/null
+++ b/infer/src/IR/Ident.mli
@@ -0,0 +1,193 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+open! IStd
+
+(** Identifiers: program variables and logical variables *)
+
+(** Program and logical variables. *)
+
+type t [@@deriving compare]
+
+(** Equality for identifiers. *)
+
+val equal : t -> t -> bool
+
+(** Names used to replace strings. *)
+
+type name [@@deriving compare]
+
+(** Equality for names. *)
+
+val equal_name : name -> name -> bool
+
+(** Kind of identifiers. *)
+
+type kind [@@deriving compare]
+
+(** Equality for kind. *)
+
+val equal_kind : kind -> kind -> bool
+
+(** Set for identifiers. *)
+
+module IdentSet : Caml.Set.S with type elt = t
+
+(** Hash table with ident as key. *)
+
+module IdentHash : Caml.Hashtbl.S with type key = t
+
+(** Map with ident as key. *)
+
+module IdentMap : Caml.Map.S with type key = t
+
+module NameGenerator : sig
+ type t
+
+ (** Get the current name generator. *)
+
+ val get_current : unit -> t
+
+ (** Reset the name generator. *)
+
+ val reset : unit -> unit
+
+ (** Set the current name generator. *)
+
+ val set_current : t -> unit
+end
+
+(** Convert an identfier list to an identifier set *)
+
+val idlist_to_idset : t list -> IdentSet.t
+
+val kprimed : kind
+
+val knormal : kind
+
+val kfootprint : kind
+
+(** hash table with names as keys *)
+
+module NameHash : Caml.Hashtbl.S with type key = name
+
+(** Name used for primed tmp variables *)
+
+val name_primed : name
+
+(** Name used for spec variables *)
+
+val name_spec : name
+
+(** Name used for the return variable *)
+
+val name_return : Mangled.t
+
+(** Convert a string to a name. *)
+
+val string_to_name : string -> name
+
+(** Convert a name to a string. *)
+
+val name_to_string : name -> string
+
+(** Name of the identifier. *)
+
+val get_name : t -> name
+
+(** Create an identifier with default name for the given kind *)
+
+val create : kind -> int -> t
+
+(** Generate a normal identifier with the given name and stamp. *)
+
+val create_normal : name -> int -> t
+
+(** Create a "null" identifier for situations where the IR requires an id that will never be read *)
+
+val create_none : unit -> t
+
+(** Generate a primed identifier with the given name and stamp. *)
+
+val create_primed : name -> int -> t
+
+(** Generate a footprint identifier with the given name and stamp. *)
+
+val create_footprint : name -> int -> t
+
+(** Update the name generator so that the given id's are not generated again *)
+
+val update_name_generator : t list -> unit
+
+(** Create a fresh identifier with default name for the given kind. *)
+
+val create_fresh : kind -> t
+
+(** Generate a normal identifier whose name encodes a path given as a string. *)
+
+val create_path : string -> t
+
+(** Check whether an identifier is primed or not. *)
+
+val is_primed : t -> bool
+
+(** Check whether an identifier is normal or not. *)
+
+val is_normal : t -> bool
+
+(** Check whether an identifier is footprint or not. *)
+
+val is_footprint : t -> bool
+
+(** Check whether an identifier represents a path or not. *)
+
+val is_path : t -> bool
+
+(** Check whether an identifier is the special "none" identifier *)
+
+val is_none : t -> bool
+
+(** Convert a primed ident into a nonprimed one, keeping the stamp. *)
+
+val make_unprimed : t -> t
+
+(** Get the stamp of the identifier *)
+
+val get_stamp : t -> int
+
+(** Set the stamp of the identifier *)
+
+val set_stamp : t -> int -> t
+
+(** {2 Pretty Printing} *)
+
+(** Pretty print a name. *)
+
+val pp_name : Format.formatter -> name -> unit
+
+(** Pretty print a name in latex. *)
+
+val pp_name_latex : Latex.style -> Format.formatter -> name -> unit
+
+(** Pretty print an identifier. *)
+
+val pp : Pp.env -> Format.formatter -> t -> unit
+
+(** Convert an identifier to a string. *)
+
+val to_string : t -> string
+
+(** Pretty print a list of identifiers. *)
+
+val pp_list : Pp.env -> Format.formatter -> t list -> unit
+
+(** Pretty print a list of names. *)
+
+val pp_name_list : Format.formatter -> name list -> unit
diff --git a/infer/src/IR/Ident.re b/infer/src/IR/Ident.re
deleted file mode 100644
index 105711283..000000000
--- a/infer/src/IR/Ident.re
+++ /dev/null
@@ -1,304 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module Hashtbl = Caml.Hashtbl;
-
-
-/** Module for Names and Identifiers */
-module L = Logging;
-
-module F = Format;
-
-module Name = {
- type t =
- | Primed
- | Normal
- | Footprint
- | Spec
- | FromString string
- [@@deriving compare];
- let primed = "t";
- let normal = "n";
- let footprint = "f";
- let spec = "val";
- let from_string s => FromString s;
- let to_string =
- fun
- | Primed => primed
- | Normal => normal
- | Footprint => footprint
- | Spec => spec
- | FromString s => s;
-};
-
-type name = Name.t [@@deriving compare];
-
-let name_spec = Name.Spec;
-
-let name_primed = Name.Primed;
-
-let equal_name = [%compare.equal : name];
-
-type kind =
- | KNone
- /** special kind of "null ident" (basically, a more compact way of implementing an ident option).
- useful for situations when an instruction requires an id, but no one should read the result. */
- | KFootprint
- | KNormal
- | KPrimed
-[@@deriving compare];
-
-let kfootprint = KFootprint;
-
-let knormal = KNormal;
-
-let kprimed = KPrimed;
-
-let equal_kind = [%compare.equal : kind];
-
-/* timestamp for a path identifier */
-let path_ident_stamp = (-3);
-
-type t = {kind, name: Name.t, stamp: int} [@@deriving compare];
-
-/* most unlikely first */
-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 {
- type nonrec t = t;
- let compare = compare;
- };
-
-module IdentMap =
- Caml.Map.Make {
- type nonrec t = t;
- let compare = compare;
- };
-
-module IdentHash =
- Hashtbl.Make {
- type nonrec t = t;
- let equal = equal;
- let hash (id: t) => Hashtbl.hash id;
- };
-
-let idlist_to_idset ids =>
- List.fold f::(fun set id => IdentSet.add id set) init::IdentSet.empty ids;
-
-
-/** {2 Conversion between Names and Strings} */
-module NameHash =
- Hashtbl.Make {
- type t = name;
- let equal = equal_name;
- let hash = Hashtbl.hash;
- };
-
-
-/** Convert a string to a name */
-let string_to_name = Name.from_string;
-
-
-/** Convert a name to a string. */
-let name_to_string = Name.to_string;
-
-
-/** {2 Functions and Hash Tables for Managing Stamps} */
-
-/** Set the stamp of the identifier */
-let set_stamp i stamp => {...i, stamp};
-
-
-/** Get the stamp of the identifier */
-let get_stamp i => i.stamp;
-
-module NameGenerator = {
- type t = NameHash.t int;
- let create () :t => NameHash.create 17;
-
- /** Map from names to stamps. */
- let name_map = ref (create ());
- let get_current () => !name_map;
- let set_current map => name_map := map;
-
- /** Reset the name generator */
- let reset () => name_map := create ();
-
- /** Create a fresh identifier with the given kind and name. */
- let create_fresh_ident kind name => {
- let stamp =
- try {
- let stamp = NameHash.find !name_map name;
- NameHash.replace !name_map name (stamp + 1);
- stamp + 1
- } {
- | Not_found =>
- NameHash.add !name_map name 0;
- 0
- };
- {kind, name, stamp}
- };
-
- /** Make sure that fresh ids after whis one will be with different stamps */
- let update_name_hash name stamp =>
- try {
- let curr_stamp = NameHash.find !name_map name;
- let new_stamp = max curr_stamp stamp;
- NameHash.replace !name_map name new_stamp
- } {
- | Not_found => NameHash.add !name_map name stamp
- };
-};
-
-
-/** Name used for the return variable */
-let name_return = Mangled.from_string "return";
-
-
-/** Return the standard name for the given kind */
-let standard_name kind =>
- if (equal_kind kind KNormal || equal_kind kind KNone) {
- Name.Normal
- } else if (
- equal_kind kind KFootprint
- ) {
- 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}
-};
-
-
-/** Create an identifier with default name for the given kind */
-let create kind stamp => create_with_stamp kind (standard_name kind) stamp;
-
-
-/** Generate a normal identifier with the given name and stamp */
-let create_normal name stamp => create_with_stamp KNormal name stamp;
-
-
-/** Create a fresh identifier with default name for the given kind. */
-let create_fresh kind => NameGenerator.create_fresh_ident kind (standard_name kind);
-
-let create_none () => create_fresh KNone;
-
-
-/** Generate a primed identifier with the given name and stamp */
-let create_primed name stamp => create_with_stamp KPrimed name stamp;
-
-
-/** Generate a footprint identifier with the given name and stamp */
-let create_footprint name stamp => create_with_stamp KFootprint name stamp;
-
-
-/** {2 Functions for Identifiers} */
-
-/** Get a name of an identifier */
-let get_name id => id.name;
-
-let has_kind id kind => equal_kind id.kind kind;
-
-let is_primed (id: t) => has_kind id KPrimed;
-
-let is_normal (id: t) => has_kind id KNormal || has_kind id KNone;
-
-let is_footprint (id: t) => has_kind id KFootprint;
-
-let is_none (id: t) => has_kind id KNone;
-
-let is_path (id: t) => has_kind id KNormal && Int.equal id.stamp path_ident_stamp;
-
-let make_unprimed id =>
- if (not (has_kind id KPrimed)) {
- assert false
- } else if (has_kind id KNone) {
- {...id, kind: KNone}
- } else {
- {...id, 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);
- 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. */
-let to_string id =>
- if (has_kind id KNone) {
- "_"
- } else {
- let base_name = name_to_string id.name;
- let prefix =
- if (has_kind id KFootprint) {
- "@"
- } else if (has_kind id KNormal) {
- ""
- } else {
- "_"
- };
- let suffix = "$" ^ string_of_int id.stamp;
- prefix ^ base_name ^ suffix
- };
-
-
-/** Pretty print a name. */
-let pp_name f name => F.fprintf f "%s" (name_to_string name);
-
-
-/** Pretty print a name in latex. */
-let pp_name_latex style f (name: name) => Latex.pp_string style f (name_to_string name);
-
-
-/** Pretty print an identifier. */
-let pp pe f id =>
- switch pe.Pp.kind {
- | TEXT
- | HTML => F.fprintf f "%s" (to_string id)
- | LATEX =>
- let base_name = name_to_string id.name;
- let style =
- if (has_kind id KFootprint) {
- Latex.Boldface
- } else if (has_kind id KNormal) {
- Latex.Roman
- } else {
- Latex.Roman
- };
- 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);
-
-
-/** pretty printer for lists of names */
-let pp_name_list = Pp.comma_seq pp_name;
diff --git a/infer/src/IR/Ident.rei b/infer/src/IR/Ident.rei
deleted file mode 100644
index 86e6cf5ab..000000000
--- a/infer/src/IR/Ident.rei
+++ /dev/null
@@ -1,189 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-
-/** Identifiers: program variables and logical variables */
-
-/** Program and logical variables. */
-type t [@@deriving compare];
-
-
-/** Equality for identifiers. */
-let equal: t => t => bool;
-
-
-/** Names used to replace strings. */
-type name [@@deriving compare];
-
-
-/** Equality for names. */
-let equal_name: name => name => bool;
-
-
-/** Kind of identifiers. */
-type kind [@@deriving compare];
-
-
-/** Equality for kind. */
-let equal_kind: kind => kind => bool;
-
-
-/** Set for identifiers. */
-module IdentSet: Caml.Set.S with type elt = t;
-
-
-/** Hash table with ident as key. */
-module IdentHash: Caml.Hashtbl.S with type key = t;
-
-
-/** Map with ident as key. */
-module IdentMap: Caml.Map.S with type key = t;
-
-module NameGenerator: {
- type t;
-
- /** Get the current name generator. */
- let get_current: unit => t;
-
- /** Reset the name generator. */
- let reset: unit => unit;
-
- /** Set the current name generator. */
- let set_current: t => unit;
-};
-
-
-/** Convert an identfier list to an identifier set */
-let idlist_to_idset: list t => IdentSet.t;
-
-let kprimed: kind;
-
-let knormal: kind;
-
-let kfootprint: kind;
-
-
-/** hash table with names as keys */
-module NameHash: Caml.Hashtbl.S with type key = name;
-
-
-/** Name used for primed tmp variables */
-let name_primed: name;
-
-
-/** Name used for spec variables */
-let name_spec: name;
-
-
-/** Name used for the return variable */
-let name_return: Mangled.t;
-
-
-/** Convert a string to a name. */
-let string_to_name: string => name;
-
-
-/** Convert a name to a string. */
-let name_to_string: name => string;
-
-
-/** Name of the identifier. */
-let get_name: t => name;
-
-
-/** Create an identifier with default name for the given kind */
-let create: kind => int => t;
-
-
-/** Generate a normal identifier with the given name and stamp. */
-let create_normal: name => int => t;
-
-
-/** Create a "null" identifier for situations where the IR requires an id that will never be read */
-let create_none: unit => t;
-
-
-/** Generate a primed identifier with the given name and stamp. */
-let create_primed: name => int => t;
-
-
-/** Generate a footprint identifier with the given name and stamp. */
-let create_footprint: name => int => t;
-
-
-/** Update the name generator so that the given id's are not generated again */
-let update_name_generator: list t => unit;
-
-
-/** Create a fresh identifier with default name for the given kind. */
-let create_fresh: kind => t;
-
-
-/** Generate a normal identifier whose name encodes a path given as a string. */
-let create_path: string => t;
-
-
-/** Check whether an identifier is primed or not. */
-let is_primed: t => bool;
-
-
-/** Check whether an identifier is normal or not. */
-let is_normal: t => bool;
-
-
-/** Check whether an identifier is footprint or not. */
-let is_footprint: t => bool;
-
-
-/** Check whether an identifier represents a path or not. */
-let is_path: t => bool;
-
-
-/** Check whether an identifier is the special "none" identifier */
-let is_none: t => bool;
-
-
-/** Convert a primed ident into a nonprimed one, keeping the stamp. */
-let make_unprimed: t => t;
-
-
-/** Get the stamp of the identifier */
-let get_stamp: t => int;
-
-
-/** Set the stamp of the identifier */
-let set_stamp: t => int => t;
-
-
-/** {2 Pretty Printing} */
-
-/** Pretty print a name. */
-let pp_name: Format.formatter => name => unit;
-
-
-/** Pretty print a name in latex. */
-let pp_name_latex: Latex.style => Format.formatter => name => unit;
-
-
-/** Pretty print an identifier. */
-let pp: Pp.env => Format.formatter => t => unit;
-
-
-/** Convert an identifier to a string. */
-let to_string: t => string;
-
-
-/** Pretty print a list of identifiers. */
-let pp_list: Pp.env => Format.formatter => list t => unit;
-
-
-/** Pretty print a list of names. */
-let pp_name_list: Format.formatter => list name => unit;
diff --git a/infer/src/IR/IntLit.ml b/infer/src/IR/IntLit.ml
new file mode 100644
index 000000000..665534336
--- /dev/null
+++ b/infer/src/IR/IntLit.ml
@@ -0,0 +1,116 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+open! IStd
+module F = Format
+
+(* the first bool indicates whether this is an unsigned value,
+ and the second whether it is a pointer *)
+
+(** signed and unsigned integer literals *)
+type t = bool * Int64.t * bool
+
+let area u i =
+ match (i < 0L, u) with
+ | true, false
+ -> 1
+ (* only representable as signed *)
+ | false, _
+ -> 2
+ (* in the intersection between signed and unsigned *)
+ | true, true
+ -> 3
+
+(* only representable as unsigned *)
+
+let to_signed (unsigned, i, ptr) =
+ if Int.equal (area unsigned i) 3 then None
+ else Some (* not representable as signed *)
+ (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
+
+let leq i1 i2 = compare_value i1 i2 <= 0
+
+let lt i1 i2 = compare_value i1 i2 < 0
+
+let geq i1 i2 = compare_value i1 i2 >= 0
+
+let gt i1 i2 = compare_value i1 i2 > 0
+
+let of_int64 i = (false, i, false)
+
+let of_int32 i = of_int64 (Int64.of_int32 i)
+
+let of_int64_unsigned i unsigned = (unsigned, i, false)
+
+let of_int i = of_int64 (Int64.of_int i)
+
+let to_int (_, i, _) = Int64.to_int_exn i
+
+let null = (false, 0L, true)
+
+let zero = of_int 0
+
+let one = of_int 1
+
+let two = of_int 2
+
+let minus_one = of_int (-1)
+
+let isone (_, i, _) = Int64.equal i 1L
+
+let iszero (_, i, _) = Int64.equal i 0L
+
+let isnull (_, i, ptr) = Int64.equal i 0L && ptr
+
+let isminusone (unsigned, i, _) = not unsigned && Int64.equal i (-1L)
+
+let isnegative (unsigned, i, _) = not unsigned && i < 0L
+
+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
+
+let mul i1 i2 = lift Int64.( * ) i1 i2
+
+let div i1 i2 = lift Int64.( / ) i1 i2
+
+let rem i1 i2 = lift Int64.rem i1 i2
+
+let logand i1 i2 = lift Int64.bit_and i1 i2
+
+let logor i1 i2 = lift Int64.bit_or i1 i2
+
+let logxor i1 i2 = lift Int64.bit_xor i1 i2
+
+let lognot i = lift1 Int64.bit_not i
+
+let sub i1 i2 = add i1 (neg i2)
+
+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
diff --git a/infer/src/IR/IntLit.mli b/infer/src/IR/IntLit.mli
new file mode 100644
index 000000000..beb910956
--- /dev/null
+++ b/infer/src/IR/IntLit.mli
@@ -0,0 +1,97 @@
+(*
+ * Copyright (c) 2009 - 2013 Monoidics ltd.
+ * Copyright (c) 2013 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ *)
+
+open! IStd
+module F = Format
+
+(** signed and unsigned integer literals *)
+
+type t
+
+val add : t -> t -> t
+
+(** compare integers ignoring the distinction between pointers and non-pointers *)
+
+val compare : t -> t -> int
+
+(** compare the value of the integers, notice this is different from const compare,
+ which distinguished between signed and unsigned +1 *)
+
+val compare_value : t -> t -> int
+
+val div : t -> t -> t
+
+val eq : t -> t -> bool
+
+val of_int : int -> t
+
+val of_int32 : int32 -> t
+
+val of_int64 : int64 -> t
+
+val of_int64_unsigned : int64 -> bool -> t
+
+val geq : t -> t -> bool
+
+val gt : t -> t -> bool
+
+val isminusone : t -> bool
+
+val isnegative : t -> bool
+
+val isnull : t -> bool
+
+val isone : t -> bool
+
+val iszero : t -> bool
+
+val leq : t -> t -> bool
+
+val logand : t -> t -> t
+
+val lognot : t -> t
+
+val logor : t -> t -> t
+
+val logxor : t -> t -> t
+
+val lt : t -> t -> bool
+
+val minus_one : t
+
+val mul : t -> t -> t
+
+val neg : t -> t
+
+val neq : t -> t -> bool
+
+val null : t
+
+(** null behaves like zero except for the function isnull *)
+
+val one : t
+
+val pp : F.formatter -> t -> unit
+
+val rem : t -> t -> t
+
+val sub : t -> t -> t
+
+val to_int : t -> int
+
+val to_signed : t -> t option
+
+(** convert to signed if the value is representable *)
+
+val to_string : t -> string
+
+val two : t
+
+val zero : t
diff --git a/infer/src/IR/IntLit.re b/infer/src/IR/IntLit.re
deleted file mode 100644
index a53f52add..000000000
--- a/infer/src/IR/IntLit.re
+++ /dev/null
@@ -1,127 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module F = Format;
-
-
-/** signed and unsigned integer literals */
-/* the first bool indicates whether this is an unsigned value,
- and the second whether it is a pointer */
-type t = (bool, Int64.t, bool);
-
-let area u i =>
- switch (i < 0L, u) {
- | (true, false) => 1 /* only representable as signed */
- | (false, _) => 2 /* in the intersection between signed and unsigned */
- | (true, true) => 3 /* only representable as unsigned */
- };
-
-let to_signed (unsigned, i, ptr) =>
- if (Int.equal (area unsigned i) 3) {
- None
- } else {
- Some
- /* not representable as signed */
- (false, i, ptr)
- };
-
-let compare (unsigned1, i1, _) (unsigned2, i2, _) => {
- let n = Bool.compare unsigned1 unsigned2;
- if (n != 0) {
- 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;
-
-let leq i1 i2 => compare_value i1 i2 <= 0;
-
-let lt i1 i2 => compare_value i1 i2 < 0;
-
-let geq i1 i2 => compare_value i1 i2 >= 0;
-
-let gt i1 i2 => compare_value i1 i2 > 0;
-
-let of_int64 i => (false, i, false);
-
-let of_int32 i => of_int64 (Int64.of_int32 i);
-
-let of_int64_unsigned i unsigned => (unsigned, i, false);
-
-let of_int i => of_int64 (Int64.of_int i);
-
-let to_int (_, i, _) => Int64.to_int_exn i;
-
-let null = (false, 0L, true);
-
-let zero = of_int 0;
-
-let one = of_int 1;
-
-let two = of_int 2;
-
-let minus_one = of_int (-1);
-
-let isone (_, i, _) => Int64.equal i 1L;
-
-let iszero (_, i, _) => Int64.equal i 0L;
-
-let isnull (_, i, ptr) => Int64.equal i 0L && ptr;
-
-let isminusone (unsigned, i, _) => not unsigned && Int64.equal i (-1L);
-
-let isnegative (unsigned, i, _) => not unsigned && i < 0L;
-
-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;
-
-let mul i1 i2 => lift Int64.( * ) i1 i2;
-
-let div i1 i2 => lift Int64.(/) i1 i2;
-
-let rem i1 i2 => lift Int64.rem i1 i2;
-
-let logand i1 i2 => lift Int64.bit_and i1 i2;
-
-let logor i1 i2 => lift Int64.bit_or i1 i2;
-
-let logxor i1 i2 => lift Int64.bit_xor i1 i2;
-
-let lognot i => lift1 Int64.bit_not i;
-
-let sub i1 i2 => add i1 (neg i2);
-
-let pp f (unsigned, n, ptr) =>
- if (ptr && Int64.equal n 0L) {
- F.fprintf f "null"
- } else if unsigned {
- F.fprintf f "%Lu" n
- } else {
- F.fprintf f "%Ld" n
- };
-
-let to_string i => F.asprintf "%a" pp i;
diff --git a/infer/src/IR/IntLit.rei b/infer/src/IR/IntLit.rei
deleted file mode 100644
index ebe230a81..000000000
--- a/infer/src/IR/IntLit.rei
+++ /dev/null
@@ -1,93 +0,0 @@
-/*
- * Copyright (c) 2009 - 2013 Monoidics ltd.
- * Copyright (c) 2013 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- */
-open! IStd;
-
-module F = Format;
-
-
-/** signed and unsigned integer literals */
-type t;
-
-let add: t => t => t;
-
-
-/** compare integers ignoring the distinction between pointers and non-pointers */
-let compare: t => t => int;
-
-
-/** compare the value of the integers, notice this is different from const compare,
- which distinguished between signed and unsigned +1 */
-let compare_value: t => t => int;
-
-let div: t => t => t;
-
-let eq: t => t => bool;
-
-let of_int: int => t;
-
-let of_int32: int32 => t;
-
-let of_int64: int64 => t;
-
-let of_int64_unsigned: int64 => bool => t;
-
-let geq: t => t => bool;
-
-let gt: t => t => bool;
-
-let isminusone: t => bool;
-
-let isnegative: t => bool;
-
-let isnull: t => bool;
-
-let isone: t => bool;
-
-let iszero: t => bool;
-
-let leq: t => t => bool;
-
-let logand: t => t => t;
-
-let lognot: t => t;
-
-let logor: t => t => t;
-
-let logxor: t => t => t;
-
-let lt: t => t => bool;
-
-let minus_one: t;
-
-let mul: t => t => t;
-
-let neg: t => t;
-
-let neq: t => t => bool;
-
-let null: t; /** null behaves like zero except for the function isnull */
-
-let one: t;
-
-let pp: F.formatter => t => unit;
-
-let rem: t => t => t;
-
-let sub: t => t => t;
-
-let to_int: t => int;
-
-let to_signed: t => option t; /** convert to signed if the value is representable */
-
-let to_string: t => string;
-
-let two: t;
-
-let zero: t;
diff --git a/infer/src/IR/Io_infer.ml b/infer/src/IR/Io_infer.ml
index a10d63dba..b025a5ac4 100644
--- a/infer/src/IR/Io_infer.ml
+++ b/infer/src/IR/Io_infer.ml
@@ -15,25 +15,26 @@ open! IStd
module F = Format
(* =============== START of module Html =============== *)
-module Html =
-struct
+module Html = struct
(** Create a new html file *)
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") in
+ let fname, dir_path =
+ match List.rev path with
+ | 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
let fmt = F.formatter_of_out_channel outc in
let s =
-{|
+ {|
-|} ^
- fname ^
-{|
+|}
+ ^ fname
+ ^ {|
-|} in
- F.fprintf fmt "%s" s;
- (fd, fmt)
+|}
+ 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") in
+ let dir_path =
+ match List.rev path with
+ | 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)
- ~mode:Unix.[O_WRONLY; O_APPEND]
- ~perm:0o777 in
+ Unix.openfile (DB.filename_to_string full_fname)
+ ~mode:Unix.([O_WRONLY; O_APPEND])
+ ~perm:0o777
+ in
let outc = Unix.out_channel_of_descr fd in
let fmt = F.formatter_of_out_channel outc in
(fd, fmt)
@@ -107,212 +110,223 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
(** 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
+ 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 "@\n@.";
- Unix.close fd
+ let close (fd, fmt) = F.fprintf fmt "@\n