Convert Reason to OCaml, and auto-format OCaml

Summary:
Conversion and reformat of infer source using ocamlformat
auto-formatting tool.

Current status:

- Because Reason does not handle docstrings, the output of the
  conversion is not 'Warning 50'-clean, meaning that there are
  docstrings with ambiguous placement.  I'll need to manually fix
  them just before landing.

Reviewed By: jvillard

Differential Revision: D5225546

fbshipit-source-id: 3bd2786

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.
+- Format code with ocamlformat.
-
-- 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`.
 
 ### C/C++/Objective-C
 

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
-
+fmt:
-.PHONY: fmt_all_ml
+	parallel $(OCAMLFORMAT_EXE) -i -- $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$")
-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))
 
-%.ml: %.re
+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)
-	refmt --print=binary_reason $< | $(OCAMLFORMAT_EXE) $< --reason-impl -o $@
-
-%.mli: %.rei
-	refmt --print=binary_reason $< | $(OCAMLFORMAT_EXE) $< --reason-intf -o $@
 
 .PHONY: fmt_all
-fmt_all: fmt_all_ml $(SRC_RE_ML) $(SRC_REI_MLI)
+fmt_all:
-	git add $(SRC_RE_ML) $(SRC_REI_MLI)
+	parallel $(OCAMLFORMAT_EXE) -i -- $(SRC_ML)
-	rm -f $(SRC_RE) $(SRC_REI)
 
 .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

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@

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.])

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

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

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

infer/src/IR/Annot.re

@@ -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];
-};

infer/src/IR/Annot.rei

@@ -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;
-};

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

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

infer/src/IR/AttributesTable.re

@@ -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
-    }
-  };

infer/src/IR/AttributesTable.rei

@@ -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;

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

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
+     -> " &gt;= "
+    | Le
+     -> " &lt;= "
+    | Gt
+     -> " &gt; "
+    | Lt
+     -> " &lt; "
+    | Shiftlt
+     -> " &lt;&lt; "
+    | Shiftrt
+     -> " &gt;&gt; "
+    | _
+     -> text binop )
+  | LATEX -> (
+    match binop with Ge -> " \\geq " | Le -> " \\leq " | _ -> text binop )
+  | _
+   -> text binop

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

infer/src/IR/Binop.re

@@ -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 => " &gt;= "
-    | Le => " &lt;= "
-    | Gt => " &gt; "
-    | Lt => " &lt; "
-    | Shiftlt => " &lt;&lt; "
-    | Shiftrt => " &gt;&gt; "
-    | _ => text binop
-    }
-  | LATEX =>
-    switch binop {
-    | Ge => " \\geq "
-    | Le => " \\leq "
-    | _ => text binop
-    }
-  | _ => text binop
-  };

infer/src/IR/Binop.rei

@@ -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;

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 =
+let register pname = builtin_decls := Typ.Procname.Set.add pname !builtin_decls
-  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;
+  register pname ; 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
+  let pname =
-      (Typ.Procname.objc_cpp tname method_name method_kind Typ.NoTemplate ~is_generic_model:false) in
+    Typ.Procname.ObjC_Cpp
-  register pname;
+      (Typ.Procname.objc_cpp tname method_name method_kind Typ.NoTemplate ~is_generic_model:false)
-  pname
+  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"

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= [] }

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

infer/src/IR/CallFlags.re

@@ -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: []
-};

infer/src/IR/CallFlags.rei

@@ -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;

infer/src/IR/CallSite.ml

@@ -8,35 +8,26 @@
  *)
 
 open! IStd
-
 module F = Format
 
-type t =
+type t = {pname: Typ.Procname.t; loc: Location.t} [@@deriving compare]
-  {
-    pname : Typ.Procname.t;
-    loc : Location.t;
-  }
-[@@deriving compare]
 
 let equal = [%compare.equal : t]
 
-let pname t =
+let pname t = t.pname
-  t.pname
 
-let loc t =
+let loc t = t.loc
-  t.loc
 
-let make pname loc =
+let make pname loc = {pname; loc}
-  { pname; loc; }
 
-let dummy =
+let dummy = make Typ.Procname.empty_block Location.dummy
-  make Typ.Procname.empty_block Location.dummy
 
-let pp fmt t =
+let pp fmt t = F.fprintf fmt "%a at %a" Typ.Procname.pp t.pname Location.pp t.loc
-  F.fprintf fmt "%a at %a" Typ.Procname.pp t.pname Location.pp t.loc
 
 module Set = PrettyPrintable.MakePPSet (struct
   type nonrec t = t
+
   let compare = compare
+
   let pp = pp
 end)

infer/src/IR/CallSite.mli

@@ -8,7 +8,6 @@
  *)
 
 open! IStd
-
 module F = Format
 
 type t [@@deriving compare]

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

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

infer/src/IR/Cfg.re

@@ -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
-};

infer/src/IR/Cfg.rei

@@ -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;

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

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

infer/src/IR/Cg.re

@@ -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
-};

infer/src/IR/Cg.rei

@@ -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;

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

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

infer/src/IR/Const.re

@@ -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;

infer/src/IR/Const.rei

@@ -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;

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

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

infer/src/IR/DecompiledExp.re

@@ -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;

infer/src/IR/DecompiledExp.rei

@@ -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;

infer/src/IR/Errlog.ml

@@ -9,7 +9,6 @@
 
 open! IStd
 module Hashtbl = Caml.Hashtbl
-
 module L = Logging
 module F = Format
 
@@ -20,24 +19,24 @@ type node_tag =
   | Procedure_end of Typ.Procname.t
 
 (** Element of a loc trace *)
-type loc_trace_elem = {
+type loc_trace_elem =
-  lt_level : int; (** nesting level of procedure calls *)
+  { lt_level: int  (** nesting level of procedure calls *)
-  lt_loc : Location.t; (** source location at the current step in the trace *)
+  ; 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_description: string  (** description of the current step in the trace *)
-  lt_node_tags : node_tag list (** tags describing the node at the current location *)
+  ; lt_node_tags: node_tag list  (** tags describing the node at the current location *) }
-}
 
-let pp_loc_trace_elem fmt { lt_level; lt_loc; } =
+let pp_loc_trace_elem fmt {lt_level; lt_loc} = F.fprintf fmt "%d %a" lt_level Location.pp lt_loc
-  F.fprintf fmt "%d %a" lt_level Location.pp lt_loc
 
-let pp_loc_trace fmt l =
+let pp_loc_trace fmt l = PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_elem 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
+    | Exception _
-    | Condition _ | Procedure_start _ | Procedure_end _ -> false in
+     -> 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 =
@@ -49,49 +48,48 @@ 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
+    | `Stop _
-    | `Continue (last_known_step_at_level_zero_opt, line_opt) ->
+     -> state
-        let last_known_step_at_level_zero_opt' =
+    | `Continue (last_known_step_at_level_zero_opt, line_opt)
-          if Int.equal step.lt_level 0 then Some step
+     -> let last_known_step_at_level_zero_opt' =
-          else last_known_step_at_level_zero_opt in
+          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 ->
+        | Some step_zero when contains_exception step
-            `Stop (last_known_step_at_level_zero_opt', Some step_zero.lt_loc.line)
+         -> `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
+        | _
+         -> `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 = {
+type node_id_key = {node_id: int; node_key: int}
-  node_id : int;
-  node_key : int
-}
 
-type err_key = {
+type err_key =
-  err_kind : Exceptions.err_kind;
+  { err_kind: Exceptions.err_kind
-  in_footprint : bool;
+  ; in_footprint: bool
-  err_name : Localise.t;
+  ; err_name: Localise.t
-  err_desc : Localise.error_desc;
+  ; err_desc: Localise.error_desc
-  severity : string
+  ; severity: string }
-}[@@deriving compare]
+  [@@deriving compare]
 
 (** Data associated to a specific error *)
-type err_data = {
+type err_data =
-  node_id_key : node_id_key;
+  { node_id_key: node_id_key
-  session : int;
+  ; session: int
-  loc : Location.t;
+  ; loc: Location.t
-  loc_in_ml_source : L.ml_loc option;
+  ; loc_in_ml_source: L.ml_loc option
-  loc_trace : loc_trace;
+  ; loc_trace: loc_trace
-  err_class : Exceptions.err_class;
+  ; err_class: Exceptions.err_class
-  visibility : Exceptions.visibility;
+  ; visibility: Exceptions.visibility
-  linters_def_file : string option;
+  ; linters_def_file: string option
-  doc_url : string option;
+  ; doc_url: string option }
-}
+
-
+let compare_err_data err_data1 err_data2 = Location.compare err_data1.loc err_data2.loc
-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)
 
@@ -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) &&
+        (key2.err_kind, key2.in_footprint, key2.err_name)
-      Localise.error_desc_equal key1.err_desc key2.err_desc
+      && Localise.error_desc_equal key1.err_desc key2.err_desc
-
   end
+
   include Hashtbl.Make (Key)
 end
 
@@ -132,48 +130,49 @@ 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 ->
+  ErrLogHash.iter
-      ErrDataSet.iter (fun err_data -> f err_key err_data) set)
+    (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 ->
+  ErrLogHash.iter
-      if filter key.err_kind key.in_footprint
+    (fun key err_datas ->
-      then count := !count + (ErrDataSet.cardinal err_datas)) err_log;
+      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 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 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
+    let pp_nodeid_session_loc fmt err_data =
-        fmt err_data =
+      Io_infer.Html.pp_session_link source path_to_root fmt
-      Io_infer.Html.pp_session_link
+        (err_data.node_id_key.node_id, err_data.session, err_data.loc.Location.line)
-        source path_to_root fmt
+    in
-        (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
-    ErrDataSet.iter (pp_nodeid_session_loc fmt) err_datas in
+  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
+    if Exceptions.equal_err_kind key.err_kind ek && Bool.equal do_fp key.in_footprint then
-    then
+      F.fprintf fmt "<br>%a %a %a" Localise.pp key.err_name Localise.pp_error_desc key.err_desc
-      F.fprintf fmt "<br>%a %a %a"
+        pp_eds err_datas
-        Localise.pp key.err_name
+  in
-        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 () ;
@@ -187,12 +186,15 @@ let pp_html source path_to_root fmt (errlog: t) =
   F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline () ;
   ErrLogHash.iter (pp_err_log false Exceptions.Kinfo) errlog
 
-
 (* I use string in case we want to display a different name to the user*)
-let severity_to_str severity = match severity with
+let severity_to_str severity =
-  | Exceptions.High -> "HIGH"
+  match severity with
-  | Exceptions.Medium -> "MEDIUM"
+  | Exceptions.High
-  | Exceptions.Low -> "LOW"
+   -> "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,119 +202,118 @@ 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
+    else (
-      begin
       ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds) ;
-        true
+      true )
-      end
+  with Not_found -> ErrLogHash.add tbl err_key err_datas ; true
-  with Not_found ->
-    begin
-      ErrLogHash.add tbl err_key err_datas;
-      true
-    end
 
 (** Update an old error log with a new one *)
 let update errlog_old errlog_new =
-  ErrLogHash.iter
+  ErrLogHash.iter (fun err_key l -> ignore (add_issue errlog_old err_key l)) errlog_new
-    (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
+    Exceptions.recognize_exception exn
-  let err_kind = match force_kind with
+  in
-    | Some err_kind -> err_kind
+  let err_kind = match force_kind with Some err_kind -> err_kind | _ -> err_kind in
-    | _ -> err_kind in
+  let hide_java_loc_zero =
-  let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *)
+    (* hide java errors at location zero unless in -developer_mode *)
-    not Config.developer_mode &&
+    not Config.developer_mode && Config.curr_language_is Config.Java
-    Config.curr_language_is Config.Java &&
+    && Int.equal loc.Location.line 0
-    Int.equal loc.Location.line 0 in
+  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 ->
+    | Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin
-        not Mleak_buckets.should_raise_leak_unknown_origin
+     -> not Mleak_buckets.should_raise_leak_unknown_origin
-    | _ -> false in
+    | _
+     -> false
+  in
   let log_it =
-    Exceptions.equal_visibility visibility Exceptions.Exn_user ||
+    Exceptions.equal_visibility visibility Exceptions.Exn_user
-    (Config.developer_mode &&
+    || Config.developer_mode && Exceptions.equal_visibility visibility Exceptions.Exn_developer
-     Exceptions.equal_visibility visibility Exceptions.Exn_developer) in
+  in
-  if log_it && not hide_java_loc_zero && not hide_memory_error then begin
+  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 = {
+      let err_data =
-        node_id_key;
+        { node_id_key
-        session;
+        ; session
-        loc;
+        ; loc
-        loc_in_ml_source = ml_loc_opt;
+        ; loc_in_ml_source= ml_loc_opt
-        loc_trace = ltr;
+        ; loc_trace= ltr
-        err_class = eclass;
+        ; err_class= eclass
-        visibility;
+        ; visibility
-        linters_def_file;
+        ; linters_def_file
-        doc_url;
+        ; doc_url }
-      } in
+      in
-      let err_key = {
+      let err_key =
-        err_kind;
+        { err_kind
-        in_footprint = !Config.footprint;
+        ; in_footprint= !Config.footprint
-        err_name;
+        ; err_name
-        err_desc;
+        ; err_desc
-        severity = severity_to_str severity
+        ; severity= severity_to_str severity }
-      } in
+      in
-      add_issue err_log err_key (ErrDataSet.singleton err_data) in
+      add_issue err_log err_key (ErrDataSet.singleton err_data)
-    let should_print_now =
+    in
-      match exn with
+    let should_print_now = match exn with Exceptions.Internal_error _ -> true | _ -> added in
-      | 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@?"
+      L.(debug Analysis Medium)
-        (Exceptions.pp_err ~node_key loc err_kind ex_name desc ml_loc_opt) ();
+        "@\n%a@\n@?" (Exceptions.pp_err ~node_key loc err_kind ex_name desc ml_loc_opt) () ;
-      if err_kind <> Exceptions.Kerror then begin
+      if err_kind <> Exceptions.Kerror then
         let warn_str =
           let pp fmt =
-            Format.fprintf fmt "%s %a"
+            Format.fprintf fmt "%s %a" (Localise.to_issue_id err_name) Localise.pp_error_desc desc
-              (Localise.to_issue_id err_name)
+          in
-              Localise.pp_error_desc desc in
+          F.asprintf "%t" pp
-          F.asprintf "%t" pp in
+        in
-        let d = match err_kind with
+        let d =
-          | Exceptions.Kerror -> L.d_error
+          match err_kind with
-          | Exceptions.Kwarning -> L.d_warning
+          | Exceptions.Kerror
-          | Exceptions.Kinfo
+           -> L.d_error
-          | Exceptions.Kadvice
+          | Exceptions.Kwarning
-          | Exceptions.Klike -> L.d_info in
+           -> L.d_warning
-        d warn_str; L.d_ln();
+          | Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike
-      end in
+           -> 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 =
+  let count_err err_table err_name locs = ignore (add_issue err_table err_name locs)
-    ignore (add_issue err_table err_name locs)
 
-  let table_size filter (err_table: t) =
+  let table_size filter (err_table: t) = size filter err_table
-    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
+      let count =
-      err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map in
+        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
+      if Exceptions.equal_err_kind ekind key.err_kind && key.in_footprint then
-      then count_err key.err_name (ErrDataSet.cardinal err_datas) in
+        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 =
+  module LocMap = Caml.Map.Make (struct
-    Caml.Map.Make(struct
     type t = ErrDataSet.elt
+
     let compare = compare_err_data
   end)
 
@@ -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
+      let map =
-        | true, Exceptions.Kerror -> map_err_fp
+        match (key.in_footprint, key.err_kind) with
-        | false, Exceptions.Kerror -> map_err_re
+        | true, Exceptions.Kerror
-        | true, Exceptions.Kwarning -> map_warn_fp
+         -> map_err_fp
-        | false, Exceptions.Kwarning -> map_warn_re
+        | false, Exceptions.Kerror
-        | _, Exceptions.Kinfo -> map_info
+         -> map_err_re
-        | _, Exceptions.Kadvice -> map_advice
+        | true, Exceptions.Kwarning
-        | _, Exceptions.Klike -> map_likes in
+         -> 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 ->
+      with Not_found -> map := LocMap.add nslm [(key.err_name, key.err_desc)] !map
-        map := LocMap.add nslm [(key.err_name, key.err_desc)] !map in
+    in
-    let f err_name eds =
+    let f err_name eds = ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
-      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) ->
+      List.iter
-          Exceptions.pp_err
+        ~f:(fun (err_name, desc) ->
-            ~node_key:err_data.node_id_key.node_key err_data.loc ekind err_name desc
+          Exceptions.pp_err ~node_key:err_data.node_id_key.node_key err_data.loc ekind err_name
-            err_data.loc_in_ml_source fmt ()) err_names in
+            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 ->
+    LocMap.iter
-        F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
+      (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 ->
+    LocMap.iter
-        F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re;
+      (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 ->
+    LocMap.iter
-        F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp;
+      (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 ->
+    LocMap.iter
-        F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re
+      (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 =
+let extend_table err_table err_log = ErrLogHash.iter (Err_table.count_err 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 =
+let print_err_table_details = Err_table.print_err_table_details
-  Err_table.print_err_table_details

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 {
+type loc_trace_elem = private
-  lt_level : int; (** nesting level of procedure calls *)
+  { lt_level: int  (** nesting level of procedure calls *)
-  lt_loc : Location.t; (** source location at the current step in the trace *)
+  ; 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_description: string  (** description of the current step in the trace *)
-  lt_node_tags : node_tag list (** tags describing the node at the current location *)
+  ; 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 {
+type node_id_key = private {node_id: int; node_key: int}
-  node_id : int;
-  node_key : int
-}
 
-type err_key = private {
+type err_key = private
-  err_kind : Exceptions.err_kind;
+  { err_kind: Exceptions.err_kind
-  in_footprint : bool;
+  ; in_footprint: bool
-  err_name : Localise.t;
+  ; err_name: Localise.t
-  err_desc : Localise.error_desc;
+  ; err_desc: Localise.error_desc
-  severity : string
+  ; severity: string }
-}[@@deriving compare]
+  [@@deriving compare]
 
 (** Data associated to a specific error *)
-type err_data = private {
+type err_data = private
-  node_id_key : node_id_key;
+  { node_id_key: node_id_key
-  session : int;
+  ; session: int
-  loc : Location.t;
+  ; loc: Location.t
-  loc_in_ml_source : Logging.ml_loc option;
+  ; loc_in_ml_source: Logging.ml_loc option
-  loc_trace : loc_trace;
+  ; loc_trace: loc_trace
-  err_class : Exceptions.err_class;
+  ; err_class: Exceptions.err_class
-  visibility : Exceptions.visibility;
+  ; visibility: Exceptions.visibility
-  linters_def_file : string option;
+  ; linters_def_file: string option
-  doc_url : string option; (* url to documentation of the issue type *)
+  ; doc_url: string option
-}
+  (* url to documentation of the issue type *) }
 
 (** Type of the error log *)
 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 ->
+  Exceptions.err_kind -> t -> Location.t -> int * int -> int -> loc_trace
-  ?linters_def_file:string -> ?doc_url:string -> exn -> unit
+  -> ?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 *)

infer/src/IR/Exceptions.ml

@@ -9,7 +9,6 @@
  *)
 
 open! IStd
-
 module L = Logging
 module F = Format
 
@@ -23,16 +22,14 @@ type visibility =
 let equal_visibility = [%compare.equal : visibility]
 
 let string_of_visibility vis =
-  match vis with
+  match vis with Exn_user -> "user" | Exn_developer -> "developer" | Exn_system -> "system"
-  | Exn_user -> "user"
-  | Exn_developer -> "developer"
-  | Exn_system  -> "system"
 
 (** severity of bugs *)
-type severity =
+type severity = High (* high severity bug *)
-  | 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
+
 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 * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * L.ml_loc
-    * 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 *)
+    match exn with
-    | Abduction_case_not_implemented ml_loc ->
+    (* all the names of Exn_user errors must be defined in Localise *)
-        (Localise.from_string "Abduction_case_not_implemented",
+    | Abduction_case_not_implemented ml_loc
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+     -> ( Localise.from_string "Abduction_case_not_implemented"
-    | Context_leak (desc, _) ->
+        , Localise.no_desc
-        (Localise.context_leak,
+        , Some ml_loc
-         desc, None, Exn_user, High, None, Nocat)
+        , Exn_developer
-    | Analysis_stops (desc, ml_loc_opt) ->
+        , Low
-        let visibility = if Config.analysis_stops then Exn_user else Exn_developer in
+        , 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 ->
+    | Array_of_pointsto ml_loc
-        (Localise.from_string "Array_of_pointsto",
+     -> ( Localise.from_string "Array_of_pointsto"
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+        , Localise.no_desc
-    | Array_out_of_bounds_l1 (desc, ml_loc) ->
+        , Some ml_loc
-        (Localise.array_out_of_bounds_l1,
+        , Exn_developer
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
+        , Low
-    | Array_out_of_bounds_l2 (desc, ml_loc) ->
+        , None
-        (Localise.array_out_of_bounds_l2,
+        , Nocat )
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+    | Array_out_of_bounds_l1 (desc, ml_loc)
-    | Array_out_of_bounds_l3 (desc, ml_loc) ->
+     -> (Localise.array_out_of_bounds_l1, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
-        (Localise.array_out_of_bounds_l3,
+    | Array_out_of_bounds_l2 (desc, ml_loc)
-         desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
+     -> (Localise.array_out_of_bounds_l2, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
-    | Assert_failure (f, l, c) ->
+    | Array_out_of_bounds_l3 (desc, ml_loc)
-        let ml_loc = (f, l, c, c) in
+     -> (Localise.array_out_of_bounds_l3, desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
-        (Localise.from_string "Assert_failure",
+    | Assert_failure (f, l, c)
-         Localise.no_desc, Some ml_loc, Exn_developer, High, None, Nocat)
+     -> let ml_loc = (f, l, c, c) in
-    | Bad_footprint ml_loc ->
+        ( Localise.from_string "Assert_failure"
-        (Localise.from_string "Bad_footprint",
+        , Localise.no_desc
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+        , Some ml_loc
-    | Cannot_star ml_loc ->
+        , Exn_developer
-        (Localise.from_string "Cannot_star",
+        , High
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+        , None
-    | Class_cast_exception (desc, ml_loc) ->
+        , Nocat )
-        (Localise.class_cast_exception,
+    | Bad_footprint ml_loc
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+     -> ( Localise.from_string "Bad_footprint"
-    | Codequery desc ->
+        , Localise.no_desc
-        (Localise.from_string "Codequery",
+        , Some ml_loc
-         desc, None, Exn_user, High, None, Prover)
+        , Exn_developer
-    | Comparing_floats_for_equality(desc, ml_loc) ->
+        , Low
-        (Localise.comparing_floats_for_equality,
+        , None
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+        , Nocat )
-    | Condition_always_true_false (desc, b, ml_loc) ->
+    | Cannot_star ml_loc
-        let name =
+     -> ( Localise.from_string "Cannot_star"
-          if b then Localise.condition_always_true
+        , Localise.no_desc
-          else Localise.condition_always_false in
+        , 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) ->
+    | Custom_error (error_msg, desc)
-        (Localise.from_string error_msg,
+     -> (Localise.from_string error_msg, desc, None, Exn_user, High, None, Checker)
-         desc, None, Exn_user, High, None, Checker)
+    | Condition_is_assignment (desc, ml_loc)
-    | Condition_is_assignment(desc, ml_loc) ->
+     -> (Localise.condition_is_assignment, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
-        (Localise.condition_is_assignment,
+    | Dangling_pointer_dereference (dko, desc, ml_loc)
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+     -> let visibility =
-    | Dangling_pointer_dereference (dko, desc, ml_loc) ->
+          match dko with
-        let visibility = match dko with
+          | Some _
-          | Some _ -> Exn_user (* only show to the user if the category was identified *)
+           -> Exn_user (* only show to the user if the category was identified *)
-          | None -> Exn_developer in
+          | None
-        (Localise.dangling_pointer_dereference,
+           -> Exn_developer
-         desc, Some ml_loc, visibility, High, None, Prover)
+        in
-    | Deallocate_stack_variable desc ->
+        (Localise.dangling_pointer_dereference, desc, Some ml_loc, visibility, High, None, Prover)
-        (Localise.deallocate_stack_variable,
+    | Deallocate_stack_variable desc
-         desc, None, Exn_user, High, None, Prover)
+     -> (Localise.deallocate_stack_variable, desc, None, Exn_user, High, None, Prover)
-    | Deallocate_static_memory desc ->
+    | Deallocate_static_memory desc
-        (Localise.deallocate_static_memory,
+     -> (Localise.deallocate_static_memory, desc, None, Exn_user, High, None, Prover)
-         desc, None, Exn_user, High, None, Prover)
+    | Deallocation_mismatch (desc, ml_loc)
-    | Deallocation_mismatch (desc, ml_loc) ->
+     -> (Localise.deallocation_mismatch, desc, Some ml_loc, Exn_user, High, None, Prover)
-        (Localise.deallocation_mismatch,
+    | Divide_by_zero (desc, ml_loc)
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+     -> (Localise.divide_by_zero, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
-    | Divide_by_zero (desc, ml_loc) ->
+    | Double_lock (desc, ml_loc)
-        (Localise.divide_by_zero,
+     -> (Localise.double_lock, desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
+    | Eradicate (kind_s, desc)
-    | Double_lock (desc, ml_loc) ->
+     -> (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
-        (Localise.double_lock,
+    | Empty_vector_access (desc, ml_loc)
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
+     -> (Localise.empty_vector_access, desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
-    | Eradicate (kind_s, desc) ->
+    | Field_not_null_checked (desc, ml_loc)
-        (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
+     -> (Localise.field_not_null_checked, desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
-    | Empty_vector_access (desc, ml_loc) ->
+    | Frontend_warning ((name, hum), desc, ml_loc)
-        (Localise.empty_vector_access,
+     -> (Localise.from_string name ?hum, desc, Some ml_loc, Exn_user, Medium, None, Linters)
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Prover)
+    | Checkers (kind_s, desc)
-    | Field_not_null_checked (desc, ml_loc) ->
+     -> (Localise.from_string kind_s, desc, None, Exn_user, High, None, Prover)
-        (Localise.field_not_null_checked,
+    | Null_dereference (desc, ml_loc)
-         desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
+     -> (Localise.null_dereference, desc, Some ml_loc, Exn_user, High, None, Prover)
-    | Frontend_warning ((name, hum), desc, ml_loc) ->
+    | Null_test_after_dereference (desc, ml_loc)
-        (Localise.from_string name ?hum,
+     -> (Localise.null_test_after_dereference, desc, Some ml_loc, Exn_user, High, None, Nocat)
-         desc, Some ml_loc, Exn_user, Medium, None, Linters)
+    | Pointer_size_mismatch (desc, ml_loc)
-    | Checkers (kind_s, desc) ->
+     -> (Localise.pointer_size_mismatch, desc, Some ml_loc, Exn_user, High, Some Kerror, Checker)
-        (Localise.from_string kind_s,
+    | Inherently_dangerous_function desc
-         desc, None, Exn_user, High, None, Prover)
+     -> (Localise.inherently_dangerous_function, desc, None, Exn_developer, Medium, None, Nocat)
-    | Null_dereference (desc, ml_loc) ->
+    | Internal_error desc
-        (Localise.null_dereference,
+     -> (Localise.from_string "Internal_error", desc, None, Exn_developer, High, None, Nocat)
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+    | Invalid_argument s
-    | Null_test_after_dereference (desc, ml_loc) ->
+     -> let desc = Localise.verbatim_desc s in
-        (Localise.null_test_after_dereference,
+        (Localise.from_string "Invalid_argument", desc, None, Exn_system, Low, None, Nocat)
-         desc, Some ml_loc, Exn_user, High, None, Nocat)
+    | Java_runtime_exception (exn_name, _, desc)
-    | Pointer_size_mismatch (desc, ml_loc) ->
+     -> let exn_str = Typ.Name.name exn_name in
-        (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) ->
+    | Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc)
-        if done_array_abstraction
+     -> if done_array_abstraction then
-        then (Localise.from_string "Leak_after_array_abstraction",
+          ( Localise.from_string "Leak_after_array_abstraction"
-              error_desc, Some ml_loc, Exn_developer, High, None, Prover)
+          , error_desc
-        else if fp_part
+          , Some ml_loc
-        then (Localise.from_string "Leak_in_footprint",
+          , Exn_developer
-              error_desc, Some ml_loc, Exn_developer, High, None, Prover)
+          , 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
+          let loc_str =
-            | PredSymb.Rmemory _ -> Localise.memory_leak
+            match resource with
-            | PredSymb.Rfile -> Localise.resource_leak
+            | PredSymb.Rmemory _
-            | PredSymb.Rlock -> Localise.resource_leak
+             -> Localise.memory_leak
-            | PredSymb.Rignore -> Localise.memory_leak in
+            | 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) ->
+    | Match_failure (f, l, c)
-        let ml_loc = (f, l, c, c) in
+     -> let ml_loc = (f, l, c, c) in
-        (Localise.from_string "Match failure",
+        ( Localise.from_string "Match failure"
-         Localise.no_desc, Some ml_loc, Exn_developer, High, None, Nocat)
+        , Localise.no_desc
-    | Missing_fld (fld, ml_loc) ->
+        , Some ml_loc
-        let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
+        , Exn_developer
-        (Localise.from_string "Missing_fld" ~hum:"Missing Field",
+        , High
-         desc, Some ml_loc, Exn_developer, Medium, None, Nocat)
+        , None
-    | Premature_nil_termination (desc, ml_loc) ->
+        , Nocat )
-        (Localise.premature_nil_termination,
+    | Missing_fld (fld, ml_loc)
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+     -> let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in
-    | Not_found ->
+        ( Localise.from_string "Missing_fld" ~hum:"Missing Field"
-        (Localise.from_string "Not_found",
+        , desc
-         Localise.no_desc, None, Exn_system, Low, None, Nocat)
+        , Some ml_loc
-    | Parameter_not_null_checked (desc, ml_loc) ->
+        , Exn_developer
-        (Localise.parameter_not_null_checked,
+        , Medium
-         desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat)
+        , None
-    | Precondition_not_found (desc, ml_loc) ->
+        , Nocat )
-        (Localise.precondition_not_found,
+    | Premature_nil_termination (desc, ml_loc)
-         desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+     -> (Localise.premature_nil_termination, desc, Some ml_loc, Exn_user, High, None, Prover)
-    | Precondition_not_met (desc, ml_loc) ->
+    | Not_found
-        (Localise.precondition_not_met,
+     -> (Localise.from_string "Not_found", Localise.no_desc, None, Exn_system, Low, None, Nocat)
-         desc, Some ml_loc, Exn_developer, Medium, Some Kwarning, Nocat) (* always a warning *)
+    | Parameter_not_null_checked (desc, ml_loc)
-    | Retain_cycle (_, desc, ml_loc) ->
+     -> ( Localise.parameter_not_null_checked
-        (Localise.retain_cycle,
+        , desc
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+        , Some ml_loc
-    | Registered_observer_being_deallocated (desc, ml_loc) ->
+        , Exn_user
-        (Localise.registered_observer_being_deallocated,
+        , Medium
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Nocat)
+        , Some Kwarning
-    | Return_expression_required (desc, ml_loc) ->
+        , Nocat )
-        (Localise.return_expression_required,
+    | Precondition_not_found (desc, ml_loc)
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+     -> (Localise.precondition_not_found, desc, Some ml_loc, Exn_developer, Low, None, Nocat)
-    | Stack_variable_address_escape (desc, ml_loc) ->
+    | Precondition_not_met (desc, ml_loc)
-        (Localise.stack_variable_address_escape,
+     -> ( Localise.precondition_not_met
-         desc, Some ml_loc, Exn_user, High, Some Kerror, Nocat)
+        , desc
-    | Return_statement_missing (desc, ml_loc) ->
+        , Some ml_loc
-        (Localise.return_statement_missing,
+        , Exn_developer
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+        , Medium
-    | Return_value_ignored (desc, ml_loc) ->
+        , Some Kwarning
-        (Localise.return_value_ignored,
+        , Nocat )
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+        (* always a warning *)
-    | SymOp.Analysis_failure_exe _ ->
+    | Retain_cycle (_, desc, ml_loc)
-        (Localise.from_string "Failure_exe",
+     -> (Localise.retain_cycle, desc, Some ml_loc, Exn_user, High, None, Prover)
-         Localise.no_desc, None, Exn_system, Low, None, Nocat)
+    | Registered_observer_being_deallocated (desc, ml_loc)
-    | Skip_function desc ->
+     -> ( Localise.registered_observer_being_deallocated
-        (Localise.skip_function, desc, None, Exn_developer, Low, None, Nocat)
+        , desc
-    | Skip_pointer_dereference (desc, ml_loc) ->
+        , Some ml_loc
-        (Localise.skip_pointer_dereference,
+        , Exn_user
-         desc, Some ml_loc, Exn_user, Medium, Some Kinfo, Nocat) (* always an info *)
+        , High
-    | Symexec_memory_error ml_loc ->
+        , Some Kerror
-        (Localise.from_string "Symexec_memory_error" ~hum:"Symbolic Execution Memory Error",
+        , Nocat )
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+    | Return_expression_required (desc, ml_loc)
-    | Sys_error s ->
+     -> (Localise.return_expression_required, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
-        let desc = Localise.verbatim_desc s in
+    | Stack_variable_address_escape (desc, ml_loc)
-        (Localise.from_string "Sys_error" ~hum:"System Error",
+     -> ( Localise.stack_variable_address_escape
-         desc, None, Exn_system, Low, None, Nocat)
+        , desc
-    | Tainted_value_reaching_sensitive_function (desc, ml_loc) ->
+        , Some ml_loc
-        (Localise.tainted_value_reaching_sensitive_function,
+        , Exn_user
-         desc, Some ml_loc, Exn_user, Medium, Some Kerror, Nocat)
+        , High
-    | Unix.Unix_error (_, s1, s2) ->
+        , Some Kerror
-        let desc = Localise.verbatim_desc (s1 ^ s2) in
+        , Nocat )
-        (Localise.from_string "Unix_error",
+    | Return_statement_missing (desc, ml_loc)
-         desc, None, Exn_system, Low, None, Nocat)
+     -> (Localise.return_statement_missing, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
-    | Uninitialized_value (desc, ml_loc) ->
+    | Return_value_ignored (desc, ml_loc)
-        (Localise.uninitialized_value,
+     -> (Localise.return_value_ignored, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+    | SymOp.Analysis_failure_exe _
-    | Unary_minus_applied_to_unsigned_expression(desc, ml_loc) ->
+     -> (Localise.from_string "Failure_exe", Localise.no_desc, None, Exn_system, Low, None, Nocat)
-        (Localise.unary_minus_applied_to_unsigned_expression,
+    | Skip_function desc
-         desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+     -> (Localise.skip_function, desc, None, Exn_developer, Low, None, Nocat)
-    | Unknown_proc ->
+    | Skip_pointer_dereference (desc, ml_loc)
-        (Localise.from_string "Unknown_proc" ~hum:"Unknown Procedure",
+     -> (Localise.skip_pointer_dereference, desc, Some ml_loc, Exn_user, Medium, Some Kinfo, Nocat)
-         Localise.no_desc, None, Exn_developer, Low, None, Nocat)
+        (* always an info *)
-    | Unreachable_code_after (desc, ml_loc) ->
+    | Symexec_memory_error ml_loc
-        (Localise.unreachable_code_after, desc, Some ml_loc, Exn_user, Medium, None, Nocat)
+     -> ( Localise.from_string "Symexec_memory_error" ~hum:"Symbolic Execution Memory Error"
-    | Unsafe_guarded_by_access (desc, ml_loc) ->
+        , Localise.no_desc
-        (Localise.unsafe_guarded_by_access,
+        , Some ml_loc
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+        , Exn_developer
-    | Use_after_free (desc, ml_loc) ->
+        , Low
-        (Localise.use_after_free,
+        , None
-         desc, Some ml_loc, Exn_user, High, None, Prover)
+        , Nocat )
-    | Wrong_argument_number ml_loc ->
+    | Sys_error s
-        (Localise.from_string "Wrong_argument_number" ~hum:"Wrong Argument Number",
+     -> let desc = Localise.verbatim_desc s in
-         Localise.no_desc, Some ml_loc, Exn_developer, Low, None, Nocat)
+        ( Localise.from_string "Sys_error" ~hum:"System Error"
-    | Failure _ as f ->
+        , desc
-        raise f
+        , None
-    | exn ->
+        , Exn_system
-        let exn_name = Exn.to_string exn in
+        , Low
-        (Localise.from_string exn_name,
+        , None
-         Localise.no_desc, None, Exn_developer, Low, None, Nocat) in
+        , 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
+  let ml_loc_string =
-    | None -> ""
+    match ml_loc_opt with None -> "" | Some ml_loc -> " " ^ L.ml_loc_to_string ml_loc
-    | Some ml_loc -> " " ^ L.ml_loc_to_string ml_loc in
+  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"
+  | Kwarning
-  | Kerror -> "ERROR"
+   -> "WARNING"
-  | Kinfo -> "INFO"
+  | Kerror
-  | Kadvice -> "ADVICE"
+   -> "ERROR"
-  | Klike -> "LIKE"
+  | Kinfo
+   -> "INFO"
+  | Kadvice
+   -> "ADVICE"
+  | Klike
+   -> "LIKE"
 
 (** string describing an error class *)
 let err_class_string = function
-  | Checker -> "CHECKER"
+  | Checker
-  | Prover -> "PROVER"
+   -> "CHECKER"
-  | Nocat -> ""
+  | Prover
-  | Linters -> "Linters"
+   -> "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"
+  F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n" SourceFile.pp loc.Location.file loc.Location.line kind
-    SourceFile.pp loc.Location.file
+    Localise.pp ex_name Localise.pp_error_desc desc pp_key node_key L.pp_ml_loc_opt ml_loc_opt
-    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_user || equal_visibility visibility Exn_developer
-  equal_visibility visibility Exn_developer

infer/src/IR/Exceptions.mli

@@ -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
+
+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)
+exception
-    * bool * PredSymb.resource * Logging.ml_loc
+  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)

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

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

infer/src/IR/Exp.re

@@ -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;

infer/src/IR/Exp.rei

@@ -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;

infer/src/IR/HilExp.ml

@@ -8,7 +8,6 @@
  *)
 
 open! IStd
-
 module F = Format
 module L = Logging
 
@@ -24,81 +23,86 @@ type t =
   [@@deriving compare]
 
 let rec pp fmt = function
-  | AccessPath access_path ->
+  | AccessPath access_path
-      AccessPath.Raw.pp fmt access_path
+   -> AccessPath.Raw.pp fmt access_path
-  | UnaryOperator (op, e, _) ->
+  | UnaryOperator (op, e, _)
-      F.fprintf fmt "%s%a" (Unop.str op) pp e
+   -> F.fprintf fmt "%s%a" (Unop.str op) pp e
-  | BinaryOperator(op, e1, e2) ->
+  | BinaryOperator (op, e1, e2)
-      F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2
+   -> F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2
-  | Exception e ->
+  | Exception e
-      F.fprintf fmt "exception %a" pp e
+   -> F.fprintf fmt "exception %a" pp e
-  | Closure (pname, _) ->
+  | Closure (pname, _)
-      F.fprintf fmt "closure(%a)" Typ.Procname.pp pname
+   -> F.fprintf fmt "closure(%a)" Typ.Procname.pp pname
-  | Constant c ->
+  | Constant c
-      (Const.pp Pp.text) fmt c
+   -> Const.pp Pp.text fmt c
-  | Cast (typ, e) ->
+  | Cast (typ, e)
-      F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e
+   -> F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e
-  | Sizeof (typ, length) ->
+  | Sizeof (typ, length)
-      let pp_length fmt = Option.iter ~f:(F.fprintf fmt "[%a]" pp) in
+   -> 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 ->
+    | AccessPath ap
-        ap :: acc
+     -> ap :: acc
-    | Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e) ->
+    | Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e)
-        get_access_paths_ e acc
+     -> get_access_paths_ e acc
-    | BinaryOperator (_, e1, e2) ->
+    | BinaryOperator (_, e1, e2)
-        get_access_paths_ e1 acc
+     -> get_access_paths_ e1 acc |> get_access_paths_ e2
-        |> get_access_paths_ e2
+    | Closure _ | Constant _ | Sizeof _
-    | Closure _ | Constant _ | Sizeof _ ->
+     -> acc
-        acc in
+  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
+let rec of_sil ~f_resolve_id (exp: Exp.t) typ =
-  | Var id ->
+  match exp with
-      let ap = match f_resolve_id (Var.of_id id) with
+  | Var id
-        | Some access_path -> access_path
+   -> let ap =
-        | None -> AccessPath.of_id id typ in
+        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) ->
+  | UnOp (op, e, typ_opt)
-      UnaryOperator (op, of_sil ~f_resolve_id e typ, typ_opt)
+   -> UnaryOperator (op, of_sil ~f_resolve_id e typ, typ_opt)
-  | BinOp (op, e0, e1) ->
+  | BinOp (op, e0, e1)
-      BinaryOperator (op, of_sil ~f_resolve_id e0 typ, of_sil ~f_resolve_id e1 typ)
+   -> BinaryOperator (op, of_sil ~f_resolve_id e0 typ, of_sil ~f_resolve_id e1 typ)
-  | Exn e ->
+  | Exn e
-      Exception (of_sil ~f_resolve_id e typ)
+   -> Exception (of_sil ~f_resolve_id e typ)
-  | Const c ->
+  | Const c
-      Constant c
+   -> Constant c
-  | Cast (cast_typ, e) ->
+  | Cast (cast_typ, e)
-      Cast (cast_typ, of_sil ~f_resolve_id e typ)
+   -> Cast (cast_typ, of_sil ~f_resolve_id e typ)
-  | Sizeof {typ; dynamic_length} ->
+  | Sizeof {typ; dynamic_length}
-      Sizeof (typ, Option.map ~f:(fun e -> of_sil ~f_resolve_id e typ) dynamic_length)
+   -> Sizeof (typ, Option.map ~f:(fun e -> of_sil ~f_resolve_id e typ) dynamic_length)
-  | Closure closure ->
+  | Closure closure
-      let environment =
+   -> let environment =
         List.map
           ~f:(fun (value, pvar, typ) ->
-              AccessPath.base_of_pvar pvar typ, of_sil ~f_resolve_id value typ)
+            (AccessPath.base_of_pvar pvar typ, of_sil ~f_resolve_id value typ))
-          closure.captured_vars in
+          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 ->
+    | Some access_path
-          AccessPath access_path
+     -> AccessPath access_path
-      | None ->
+    | None
-          (* unsupported field expression: represent with a dummy variable *)
+     -> (* 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),
+             ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0)
-                fld,
+             , fld
-                root_exp_typ))
+             , root_exp_typ )) typ )
-            typ )
+  | Lindex (Const Cstr s, index_exp)
-  | Lindex (Const (Cstr s), index_exp) ->
+   -> (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable
-      (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable
          for the string literal. if you actually need to see the value of the string literal in the
          analysis, you should probably be using SIL. this is unsound if the code modifies the
          literal, e.g. using `const_cast<char*>` *)
@@ -106,22 +110,19 @@ let rec of_sil ~f_resolve_id (exp : Exp.t) typ = match exp with
         (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 ->
+    | Some access_path
-          AccessPath access_path
+     -> AccessPath access_path
-      | None ->
+    | None
-          (* unsupported index expression: represent with a dummy variable *)
+     -> (* 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),
+             ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0)
-                index_exp))
+             , index_exp )) typ )
-            typ )
   | Lvar _ ->
     match AccessPath.of_lhs_exp exp typ ~f_resolve_id with
-      | Some access_path ->
+    | Some access_path
-          AccessPath access_path
+     -> AccessPath access_path
-      | None ->
+    | None
-          failwithf "Couldn't convert var expression %a to access path" Exp.pp exp
+     -> failwithf "Couldn't convert var expression %a to access path" Exp.pp exp
 
-let is_null_literal = function
+let is_null_literal = function Constant Cint n -> IntLit.isnull n | _ -> false
-  | Constant (Cint n) -> IntLit.isnull n
-  | _ -> false

infer/src/IR/HilExp.mli

@@ -8,24 +8,17 @@
  *)
 
 open! IStd
-
 module F = Format
 
 type t =
-  | AccessPath of AccessPath.Raw.t
+  | AccessPath of AccessPath.Raw.t  (** access path (e.g., x.f.g or x[i]) *)
-  (** 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
+  | BinaryOperator of Binop.t * t * t  (** Binary operator *)
-  (** Binary operator *)
+  | Exception of t  (** Exception *)
-  | Exception of t
+  | Closure of Typ.Procname.t * (AccessPath.base * t) list  (** Name of function + environment *)
-  (** Exception *)
+  | Constant of Const.t  (** Constants *)
-  | Closure of Typ.Procname.t * (AccessPath.base * t) list
+  | Cast of Typ.t * t  (** Type cast *)
-  (** 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
       canonical documentation *)
@@ -33,11 +26,11 @@ type t =
 
 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

infer/src/IR/HilInstr.ml

@@ -8,18 +8,16 @@
  *)
 
 open! IStd
-
 module F = Format
 module L = Logging
 
-type call =
+type call = Direct of Typ.Procname.t | Indirect of AccessPath.Raw.t [@@deriving compare]
-  | Direct of Typ.Procname.t
-  | Indirect of AccessPath.Raw.t
-[@@deriving compare]
 
 let pp_call fmt = function
-  | Direct pname -> Typ.Procname.pp fmt pname
+  | Direct pname
-  | Indirect access_path -> F.fprintf fmt "*%a" AccessPath.Raw.pp access_path
+   -> 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
@@ -28,20 +26,16 @@ type t =
   [@@deriving compare]
 
 let pp fmt = function
-  | Assign (access_path, exp, loc) ->
+  | Assign (access_path, exp, loc)
-      F.fprintf fmt "%a := %a [%a]" AccessPath.Raw.pp access_path HilExp.pp exp Location.pp loc
+   -> F.fprintf fmt "%a := %a [%a]" AccessPath.Raw.pp access_path HilExp.pp exp Location.pp loc
-  | Assume (exp, _, _, loc) ->
+  | Assume (exp, _, _, loc)
-      F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc
+   -> F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc
-  | Call (ret_opt, call, actuals, _, loc) ->
+  | Call (ret_opt, call, actuals, _, loc)
-      let pp_ret fmt = Option.iter ~f:(F.fprintf fmt "%a := " AccessPath.pp_base) in
+   -> 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 =
+type translation = Instr of t | Bind of Var.t * AccessPath.Raw.t | Unbind of Var.t list | Ignore
-  | 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
@@ -51,65 +45,73 @@ 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] ->
+    | [rhs_access_path]
-        Bind (lhs_id, rhs_access_path)
+     -> Bind (lhs_id, rhs_access_path)
-    | _ ->
+    | _
-        Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc)) in
+     -> Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc))
+  in
   match instr with
-  | Load (lhs_id, rhs_exp, rhs_typ, loc) ->
+  | Load (lhs_id, rhs_exp, rhs_typ, loc)
-      analyze_id_assignment (Var.of_id 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)
+  | Store (Lvar lhs_pvar, lhs_typ, rhs_exp, loc) when Pvar.is_ssa_frontend_tmp lhs_pvar
-    when Pvar.is_ssa_frontend_tmp lhs_pvar ->
+   -> analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc
-      analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc
+  | Call
-  | Call (Some (ret_id, _), Const (Cfun callee_pname),
+      ( Some (ret_id, _)
-          (target_exp, _) :: (Sizeof {typ=cast_typ}, _) :: _ , loc, _)
+      , Const Cfun callee_pname
-    when Typ.Procname.equal callee_pname BuiltinDecl.__cast ->
+      , (target_exp, _) :: (Sizeof {typ= cast_typ}, _) :: _
-      analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc
+      , loc
-  | Store (lhs_exp, typ, rhs_exp, loc) ->
+      , _ )
-      let lhs_access_path =
+    when Typ.Procname.equal callee_pname BuiltinDecl.__cast
+   -> analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc
+  | Store (lhs_exp, typ, rhs_exp, loc)
+   -> let lhs_access_path =
         match HilExp.of_sil ~f_resolve_id lhs_exp typ with
-        | AccessPath ap ->
+        | AccessPath ap
-            ap
+         -> ap
-        | BinaryOperator (_, exp0, exp1) ->
+        | 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
+            HilExp.get_access_paths exp0
-              match HilExp.get_access_paths exp0 with
+          with
-              | ap :: _ ->
+          | ap :: _
-                  ap
+           -> ap
           | [] ->
-                  begin
             match HilExp.get_access_paths exp1 with
-                    | ap :: _ ->
+            | ap :: _
-                        ap
+             -> ap
-                    | [] ->
+            | []
-                        invalid_argf
+             -> invalid_argf "Invalid pointer arithmetic expression %a used as LHS" Exp.pp lhs_exp
-                          "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
-            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) ->
+  | 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_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
+        | Constant Cfun procname
-        | AccessPath access_path -> Indirect access_path
+         -> Direct procname
-        | call_exp -> invalid_argf "Unexpected call expression %a" HilExp.pp call_exp in
+        | 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) ->
+  | Prune (exp, loc, true_branch, if_kind)
-      let hil_exp = HilExp.of_sil ~f_resolve_id exp (Typ.mk (Tint IBool)) in
+   -> 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, _) ->
+  | Nullify (pvar, _)
-      Unbind [Var.of_pvar pvar]
+   -> Unbind [Var.of_pvar pvar]
-  | Remove_temps (ids, _) ->
+  | Remove_temps (ids, _)
-      Unbind (List.map ~f:Var.of_id ids)
+   -> Unbind (List.map ~f:Var.of_id ids)
   (* ignoring for now; will translate as builtin function call if needed *)
-  | Abstract _ | Declare_locals _ ->
+  | Abstract _
-      (* these don't seem useful for most analyses. can translate them later if we want to *)
+  | Declare_locals _
+   -> (* these don't seem useful for most analyses. can translate them later if we want to *)
       Ignore

infer/src/IR/HilInstr.mli

@@ -8,20 +8,15 @@
  *)
 
 open! IStd
-
 module F = Format
 
 (** type of a procedure call; either direct or via function pointer *)
-type call =
+type call = Direct of Typ.Procname.t | Indirect of AccessPath.Raw.t [@@deriving compare]
-  | 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
+  | Assign of AccessPath.Raw.t * HilExp.t * Location.t  (** LHS access path, RHS expression *)
-  (** 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.) *)
   | Call of AccessPath.base option * call * HilExp.t list * CallFlags.t * Location.t
@@ -37,5 +32,5 @@ type translation =
   | 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 *)

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

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

infer/src/IR/Ident.re

@@ -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;

infer/src/IR/Ident.rei

@@ -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;

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

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

infer/src/IR/IntLit.re

@@ -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;

infer/src/IR/IntLit.rei

@@ -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;

infer/src/IR/Io_infer.ml

@@ -15,15 +15,16 @@ open! IStd
 module F = Format
 
 (* =============== START of module Html =============== *)
-module Html =
+module Html = struct
-struct
   (** Create a new html file *)
   let create pk path =
-    let fname, dir_path = match List.rev path with
+    let fname, dir_path =
-      | fname :: path_rev ->
+      match List.rev path with
-          fname, List.rev ((fname ^ ".html") :: path_rev)
+      | fname :: path_rev
-      | [] ->
+       -> (fname, List.rev ((fname ^ ".html") :: path_rev))
-          raise (Failure "Html.create") in
+      | []
+       -> 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
@@ -31,9 +32,9 @@ struct
       {|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
 <html>
 <head>
-<title>|} ^
+<title>|}
-      fname ^
+      ^ fname
-{|</title>
+      ^ {|</title>
 <style type="text/css">
 body { color:#000000; background-color:#ffffff }
 body { font-family:Helvetica, sans-serif; font-size:10pt }
@@ -79,27 +80,29 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
 </style>
 </head>
 <body>
-|} in
+|}
-    F.fprintf fmt "%s" s;
+    in
-    (fd, fmt)
+    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
+    let dir_path =
-      | fname :: path_rev ->
+      match List.rev path with
-          List.rev ((fname ^ ".html") :: path_rev)
+      | fname :: path_rev
-      | [] ->
+       -> List.rev ((fname ^ ".html") :: path_rev)
-          raise (Failure "Html.open_out") in
+      | []
+       -> 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
+      Unix.openfile (DB.filename_to_string full_fname)
-        (DB.filename_to_string full_fname)
+        ~mode:Unix.([O_WRONLY; O_APPEND])
-        ~mode:Unix.[O_WRONLY; O_APPEND]
+        ~perm:0o777
-        ~perm:0o777 in
+    in
     let outc = Unix.out_channel_of_descr fd in
     let fmt = F.formatter_of_out_channel outc in
     (fd, fmt)
@@ -107,71 +110,55 @@ 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
+    if DB.file_exists fname then DB.file_modified_time fname >= Config.initial_analysis_time
-      DB.file_modified_time fname >= Config.initial_analysis_time
     else false
 
   (** Close an Html file *)
-  let close (fd, fmt) =
+  let close (fd, fmt) = F.fprintf fmt "</body>@\n</html>@." ; Unix.close fd
-    F.fprintf fmt "</body>@\n</html>@.";
-    Unix.close fd
 
   (** Print a horizontal line *)
-  let pp_hline fmt () =
+  let pp_hline fmt () = F.fprintf fmt "<hr width=\"100%%\">@\n"
-    F.fprintf fmt "<hr width=\"100%%\">@\n"
 
   (** Print start color *)
-  let pp_start_color fmt color =
+  let pp_start_color fmt color = F.fprintf fmt "%s" ("<span class='" ^ Pp.color_string color ^ "'>")
-    F.fprintf fmt "%s" ("<span class='" ^ (Pp.color_string color) ^ "'>")
 
   (** Print end color *)
-  let pp_end_color fmt () =
+  let pp_end_color fmt () = F.fprintf fmt "%s" "</span>"
-    F.fprintf fmt "%s" "</span>"
 
   let pp_link ?(name= None) ?(pos= None) ~path fmt text =
-    let pos_str = match pos with
+    let pos_str = match pos with None -> "" | Some s -> "#" ^ s in
-      | None -> ""
-      | Some s -> "#" ^ s in
     let escaped_path = List.map ~f:Escape.escape_url path in
     let link_str =
-      (DB.filename_to_string (DB.Results_dir.path_to_filename DB.Results_dir.Rel escaped_path))
+      DB.filename_to_string (DB.Results_dir.path_to_filename DB.Results_dir.Rel escaped_path)
-      ^ ".html"
+      ^ ".html" ^ pos_str
-      ^ pos_str in
+    in
-    let name_str = match name with
+    let name_str = match name with None -> "" | Some n -> "name=\"" ^ n ^ "\"" in
-      | None -> ""
-      | Some n -> "name=\"" ^ n ^ "\"" in
     let pr_str = "<a " ^ name_str ^ "href=\"" ^ link_str ^ "\">" ^ text ^ "</a>" in
     F.fprintf fmt " %s" pr_str
 
   (** File name for the node, given the procedure name and node id *)
-  let node_filename pname id = (Typ.Procname.to_filename pname) ^ "_node" ^ string_of_int id
+  let node_filename pname id = Typ.Procname.to_filename pname ^ "_node" ^ string_of_int id
 
   (** Print an html link to the given node. *)
   let pp_node_link path_to_root pname ~description ~preds ~succs ~exn ~isvisited ~isproof fmt id =
     let display_name =
-      (if String.equal description "" then "N" else String.sub description ~pos:0 ~len:1)
+      (if String.equal description "" then "N" else String.sub description ~pos:0 ~len:1) ^ "_"
-      ^ "_"
+      ^ string_of_int id
-      ^ (string_of_int id) in
+    in
     let node_fname = node_filename pname id in
     let style_class =
-      if not isvisited
+      if not isvisited then "dangling" else if isproof then "visitedproof" else "visited"
-      then "dangling"
+    in
-      else if isproof then "visitedproof" else "visited" in
     let node_text =
       let pp fmt =
         Format.fprintf fmt
-          "<span class='%s'>%s\
+          "<span class='%s'>%s<span class='expansion'>node%d preds:%a succs:%a exn:%a %s%s</span></span>"
-           <span class='expansion'>\
+          style_class display_name id (Pp.seq Format.pp_print_int) preds
-           node%d preds:%a succs:%a exn:%a %s%s\
+          (Pp.seq Format.pp_print_int) succs (Pp.seq Format.pp_print_int) exn description
-           </span>\
+          (if not isvisited then "\nNOT VISITED" else "")
-           </span>"
+      in
-          style_class display_name id
+      F.asprintf "%t" pp
-          (Pp.seq Format.pp_print_int) preds
+    in
-          (Pp.seq Format.pp_print_int) succs
-          (Pp.seq Format.pp_print_int) exn
-          description
-          (if not isvisited then "\nNOT VISITED" else "") in
-      F.asprintf "%t" pp in
     pp_link ~path:(path_to_root @ ["nodes"; node_fname]) fmt node_text
 
   (** Print an html link to the given proc *)
@@ -194,119 +181,145 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e
   let pp_session_link ?(with_name= false) ?proc_name source path_to_root fmt
       (node_id, session, linenum) =
     let node_name = "node" ^ string_of_int node_id in
-    let node_fname = match proc_name with
+    let node_fname =
-      | Some pname -> node_filename pname node_id
+      match proc_name with Some pname -> node_filename pname node_id | None -> node_name
-      | None -> node_name in
+    in
     let path_to_node = path_to_root @ ["nodes"; node_fname] in
-    let pos = "session" ^ (string_of_int session) in
+    let pos = "session" ^ string_of_int session in
     pp_link
       ~name:(if with_name then Some pos else None)
-      ~pos: (Some pos)
+      ~pos:(Some pos) ~path:path_to_node fmt
-      ~path: path_to_node
-      fmt
       (node_name ^ "#" ^ pos) ;
     F.fprintf fmt "(%a)" (pp_line_link source path_to_root) linenum
 end
-(* =============== END of module Html =============== *)
 
+(* =============== END of module Html =============== *)
 (* =============== START of module Xml =============== *)
+
 (** Create and print xml trees *)
-module Xml =
+module Xml = struct
-struct
   let tag_branch = "branch"
+
   let tag_call_trace = "call_trace"
+
   let tag_callee = "callee"
+
   let tag_callee_id = "callee_id"
+
   let tag_caller = "caller"
+
   let tag_caller_id = "caller_id"
+
   let tag_class = "class"
+
   let tag_code = "code"
+
   let tag_description = "description"
+
   let tag_err = "err"
+
   let tag_flags = "flags"
+
   let tag_file = "file"
+
   let tag_hash = "hash"
+
   let tag_in_calls = "in_calls"
+
   let tag_key = "key"
+
   let tag_kind = "kind"
+
   let tag_level = "level"
+
   let tag_line = "line"
+
   let tag_loc = "loc"
+
   let tag_name = "name"
+
   let tag_name_id = "name_id"
+
   let tag_node = "node"
+
   let tag_out_calls = "out_calls"
+
   let tag_precondition = "precondition"
+
   let tag_procedure = "procedure"
+
   let tag_procedure_id = "procedure_id"
+
   let tag_proof_coverage = "proof_coverage"
+
   let tag_proof_trace = "proof_trace"
+
   let tag_qualifier = "qualifier"
+
   let tag_qualifier_tags = "qualifier_tags"
+
   let tag_rank = "rank"
+
   let tag_severity = "severity"
+
   let tag_signature = "signature"
+
   let tag_specs = "specs"
+
   let tag_symop = "symop"
+
   let tag_time = "time"
+
   let tag_to = "to"
+
   let tag_top = "top"
+
   let tag_trace = "trace"
+
   let tag_type = "type"
+
   let tag_weight = "weight"
 
   type tree = {name: string; attributes: (string * string) list; forest: node list}
-  and node =
+
-    | Tree of tree
+  and node = Tree of tree | String of string
-    | String of string
 
   let pp = F.fprintf
 
-  let create_tree name attributes forest =
+  let create_tree name attributes forest = Tree {name; attributes; forest}
-    Tree { name = name; attributes = attributes; forest = forest }
 
-  let pp_attribute fmt (name, value) =
+  let pp_attribute fmt (name, value) = pp fmt "%s=\"%s\"" name value
-    pp fmt "%s=\"%s\"" name value
 
-  let pp_attributes fmt l =
+  let pp_attributes fmt l = Pp.seq pp_attribute fmt l
-    Pp.seq pp_attribute fmt l
 
   (** print an xml node *)
   let rec pp_node newline indent fmt = function
-    | Tree { name = name; attributes = attributes; forest = forest } ->
+    | Tree {name; attributes; forest}
-        let indent' = if String.equal newline "" then "" else indent ^ "  " in
+     -> let indent' = if String.equal newline "" then "" else indent ^ "  " in
         let space = if List.is_empty attributes then "" else " " in
-        let pp_inside fmt () = match forest with
+        let pp_inside fmt () =
-          | [] ->
+          match forest with
-              ()
+          | []
-          | [String s] ->
+           -> ()
-              pp fmt "%s" s
+          | [(String s)]
-          | _ ->
+           -> pp fmt "%s" s
-              pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent in
+          | _
-        pp fmt "%s<%s%s%a>%a</%s>%s"
+           -> pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent
-          indent
+        in
-          name
+        pp fmt "%s<%s%s%a>%a</%s>%s" indent name space pp_attributes attributes pp_inside () name
-          space
-          pp_attributes attributes
-          pp_inside ()
-          name
           newline
-    | String s ->
+    | String s
-        F.fprintf fmt "%s%s%s" indent s newline
+     -> F.fprintf fmt "%s%s%s" indent s newline
-  and pp_forest newline indent fmt forest =
+
-    List.iter ~f:(pp_node newline indent fmt) forest
+  and pp_forest newline indent fmt forest = List.iter ~f:(pp_node newline indent fmt) forest
 
   let pp_prelude fmt = pp fmt "%s" "<?xml version=\"1.0\" encoding=\"UTF-8\"?>@\n"
 
-  let pp_open fmt name =
+  let pp_open fmt name = pp_prelude fmt ; pp fmt "<%s>@\n" name
-    pp_prelude fmt;
-    pp fmt "<%s>@\n" name
 
-  let pp_close fmt name =
+  let pp_close fmt name = pp fmt "</%s>@." name
-    pp fmt "</%s>@." name
 
-  let pp_inner_node fmt node =
+  let pp_inner_node fmt node = pp_node "\n" "" fmt node
-    pp_node "\n" "" fmt node
 
   (** print an xml document, if the first parameter is false on a single line without preamble *)
   let pp_document on_several_lines fmt node =
@@ -315,4 +328,5 @@ struct
     pp_node newline "" fmt node ;
     if on_several_lines then pp fmt "@."
 end
+
 (* =============== END of module Xml =============== *)

infer/src/IR/Io_infer.mli

@@ -13,115 +13,152 @@ open! IStd
 (** Module to handle IO. Includes html and xml modules. *)
 
 module Html : sig
-  (** Close an Html file *)
   val close : Unix.File_descr.t * Format.formatter -> unit
+  (** Close an Html file *)
 
-  (** Create a new html file *)
   val create :
     DB.Results_dir.path_kind -> DB.Results_dir.path -> Unix.File_descr.t * Format.formatter
+  (** Create a new html file *)
 
-  (** Return true if the html file was modified since the beginning of the analysis *)
   val modified_during_analysis : SourceFile.t -> DB.Results_dir.path -> bool
+  (** Return true if the html file was modified since the beginning of the analysis *)
 
-  (** File name for the node, given the procedure name and node id *)
   val node_filename : Typ.Procname.t -> int -> string
+  (** File name for the node, given the procedure name and node id *)
 
-  (** Open an Html file to append data *)
   val open_out : SourceFile.t -> DB.Results_dir.path -> Unix.File_descr.t * Format.formatter
+  (** Open an Html file to append data *)
 
-  (** Print an html link to the given line number of the current source file *)
   val pp_line_link :
-    ?with_name: bool -> ?text: (string option) ->
+    ?with_name:bool -> ?text:string option -> SourceFile.t -> DB.Results_dir.path
-    SourceFile.t -> DB.Results_dir.path -> Format.formatter -> int -> unit
+    -> Format.formatter -> int -> unit
+  (** Print an html link to the given line number of the current source file *)
 
-  (** Print a horizontal line *)
   val pp_hline : Format.formatter -> unit -> unit
+  (** Print a horizontal line *)
 
-  (** Print end color *)
   val pp_end_color : Format.formatter -> unit -> unit
+  (** Print end color *)
 
+  val pp_node_link :
+    DB.Results_dir.path -> Typ.Procname.t -> description:string -> preds:int list -> succs:int list
+    -> exn:int list -> isvisited:bool -> isproof:bool -> Format.formatter -> int -> unit
   (** Print an html link to the given node.
       Usage: [pp_node_link path_to_root ... fmt id].
       [path_to_root] is the path to the dir for the procedure in the spec db.
       [id] is the node identifier. *)
-  val pp_node_link :
-    DB.Results_dir.path -> Typ.Procname.t ->
-    description:string -> preds:int list -> succs:int list -> exn:int list ->
-    isvisited:bool -> isproof:bool -> Format.formatter -> int -> unit
 
+  val pp_proc_link : DB.Results_dir.path -> Typ.Procname.t -> Format.formatter -> string -> unit
   (** Print an html link to the given proc *)
-  val pp_proc_link :
-    DB.Results_dir.path -> Typ.Procname.t -> Format.formatter -> string -> unit
 
-  (** Print an html link given node id and session *)
   val pp_session_link :
-    ?with_name: bool -> ?proc_name: Typ.Procname.t -> SourceFile.t ->
+    ?with_name:bool -> ?proc_name:Typ.Procname.t -> SourceFile.t -> string list -> Format.formatter
-    string list -> Format.formatter -> int * int * int -> unit
+    -> int * int * int -> unit
+  (** Print an html link given node id and session *)
 
-  (** Print start color *)
   val pp_start_color : Format.formatter -> Pp.color -> unit
+  (** Print start color *)
 end
 
 (** Create and print xml trees *)
 module Xml : sig
   val tag_branch : string
+
   val tag_call_trace : string
+
   val tag_callee : string
+
   val tag_callee_id : string
+
   val tag_caller : string
+
   val tag_caller_id : string
+
   val tag_class : string
+
   val tag_code : string
+
   val tag_description : string
+
   val tag_err : string
+
   val tag_file : string
+
   val tag_flags : string
+
   val tag_hash : string
+
   val tag_in_calls : string
+
   val tag_key : string
+
   val tag_kind : string
+
   val tag_level : string
+
   val tag_line : string
+
   val tag_loc : string
+
   val tag_name : string
+
   val tag_name_id : string
+
   val tag_node : string
+
   val tag_out_calls : string
+
   val tag_precondition : string
+
   val tag_procedure : string
+
   val tag_procedure_id : string
+
   val tag_proof_coverage : string
+
   val tag_proof_trace : string
+
   val tag_qualifier : string
+
   val tag_qualifier_tags : string
+
   val tag_rank : string
+
   val tag_severity : string
+
   val tag_signature : string
+
   val tag_specs : string
+
   val tag_symop : string
+
   val tag_time : string
+
   val tag_to : string
+
   val tag_top : string
+
   val tag_trace : string
+
   val tag_type : string
+
   val tag_weight : string
 
   type tree = {name: string; attributes: (string * string) list; forest: node list}
-  and node =
+
-    | Tree of tree
+  and node = Tree of tree | String of string  (** create a tree *)
-    | String of string
+
-    (** create a tree *)
   val create_tree : string -> (string * string) list -> node list -> node
 
-  (** print an xml document, if the first parameter is false on a single line without preamble *)
   val pp_document : bool -> Format.formatter -> node -> unit
+  (** print an xml document, if the first parameter is false on a single line without preamble *)
 
-  (** print the opening lines of an xml document consisting of a main tree with the given name *)
   val pp_open : Format.formatter -> string -> unit
+  (** print the opening lines of an xml document consisting of a main tree with the given name *)
 
-  (** print the closing lines of an xml document consisting of a main tree with the given name *)
   val pp_close : Format.formatter -> string -> unit
+  (** print the closing lines of an xml document consisting of a main tree with the given name *)
 
-  (** print a node between a [pp_open] and a [pp_close] *)
   val pp_inner_node : Format.formatter -> node -> unit
+  (** print a node between a [pp_open] and a [pp_close] *)
 end

infer/src/IR/LintIssues.ml

@@ -13,16 +13,16 @@ open! IStd
 
 let errLogMap = ref Typ.Procname.Map.empty
 
-let exists_issues () =
+let exists_issues () = not (Typ.Procname.Map.is_empty !errLogMap)
-  not (Typ.Procname.Map.is_empty !errLogMap)
 
 let get_err_log procname =
   try Typ.Procname.Map.find procname !errLogMap
   with Not_found ->
     let errlog = Errlog.empty () in
-    errLogMap := Typ.Procname.Map.add procname errlog !errLogMap; errlog
+    errLogMap := Typ.Procname.Map.add procname errlog !errLogMap ;
+    errlog
 
-let lint_issues_serializer : (Errlog.t Typ.Procname.Map.t) Serialization.serializer =
+let lint_issues_serializer : Errlog.t Typ.Procname.Map.t Serialization.serializer =
   Serialization.create_serializer Serialization.Key.lint_issues
 
 (** Save issues to a file *)
@@ -30,27 +30,33 @@ let store_issues filename errLogMap =
   Serialization.write_to_file lint_issues_serializer filename ~data:errLogMap
 
 (** Load issues from the given file *)
-let load_issues issues_file =
+let load_issues issues_file = Serialization.read_from_file lint_issues_serializer issues_file
-  Serialization.read_from_file lint_issues_serializer issues_file
 
 (** Load all the lint issues in the given dir and update the issues map *)
 let load_issues_to_errlog_map dir =
   let issues_dir = Filename.concat Config.results_dir dir in
-  let children_opt = try Some (Sys.readdir issues_dir) with Sys_error _ -> None in
+  let children_opt =
+    try Some (Sys.readdir issues_dir)
+    with Sys_error _ -> None
+  in
   let load_issues_to_map issues_file =
     let file = DB.filename_from_string (Filename.concat issues_dir issues_file) in
     match load_issues file with
-    | Some map ->
+    | Some map
-        errLogMap := Typ.Procname.Map.merge (
+     -> errLogMap
-            fun _ issues1 issues2 ->
+        := Typ.Procname.Map.merge
-              match issues1, issues2 with
+             (fun _ issues1 issues2 ->
-              | Some issues1, Some issues2 ->
+               match (issues1, issues2) with
-                  Errlog.update issues1 issues2; Some issues1
+               | Some issues1, Some issues2
-              | Some issues1, None -> Some issues1
+                -> Errlog.update issues1 issues2 ; Some issues1
-              | None, Some issues2 -> Some issues2
+               | Some issues1, None
-              | None, None -> None
+                -> Some issues1
-          ) !errLogMap map
+               | None, Some issues2
-    | None -> () in
+                -> Some issues2
-  match children_opt with
+               | None, None
-  | Some children -> Array.iter ~f:load_issues_to_map children
+                -> None)
-  | None -> ()
+             !errLogMap map
+    | None
+     -> ()
+  in
+  match children_opt with Some children -> Array.iter ~f:load_issues_to_map children | None -> ()

infer/src/IR/LintIssues.mli

@@ -15,11 +15,11 @@ val errLogMap : Errlog.t Typ.Procname.Map.t ref
 
 val exists_issues : unit -> bool
 
-(** Save issues to a file *)
 val get_err_log : Typ.Procname.t -> Errlog.t
+(** Save issues to a file *)
 
-(** Load issues from the given file *)
 val store_issues : DB.filename -> Errlog.t Typ.Procname.Map.t -> unit
+(** Load issues from the given file *)
 
-(** Load all the lint issues in the given dir and update the issues map *)
 val load_issues_to_errlog_map : string -> unit
+(** Load all the lint issues in the given dir and update the issues map *)

infer/src/IR/Localise.mli

@@ -17,166 +17,244 @@ type t [@@deriving compare]
 
 val equal : t -> t -> bool
 
-(** pretty print a localised string *)
 val pp : Format.formatter -> t -> unit
+(** pretty print a localised string *)
 
-(** create from an ordinary string *)
 val from_string : ?hum:string -> string -> t
+(** create from an ordinary string *)
 
-(** return the id of an issue *)
 val to_issue_id : t -> string
+(** return the id of an issue *)
 
-(** return the human-readable name of an issue *)
 val to_human_readable_string : t -> string
+(** return the human-readable name of an issue *)
 
 val analysis_stops : t
+
 val array_out_of_bounds_l1 : t
+
 val array_out_of_bounds_l2 : t
+
 val array_out_of_bounds_l3 : t
+
 val buffer_overrun : t
+
 val checkers_access_global : t
+
 val checkers_immutable_cast : t
+
 val checkers_print_c_call : t
+
 val checkers_print_objc_method_calls : t
+
 val checkers_printf_args : t
+
 val checkers_repeated_calls : t
+
 val checkers_trace_calls_sequence : t
+
 val class_cast_exception : t
+
 val cluster_callback : t
+
 val comparing_floats_for_equality : t
+
 val condition_always_false : t
+
 val condition_always_true : t
+
 val condition_is_assignment : t
+
 val context_leak : t
+
 val dangling_pointer_dereference : t
+
 val deallocate_stack_variable : t
+
 val deallocate_static_memory : t
+
 val deallocation_mismatch : t
+
 val divide_by_zero : t
+
 val double_lock : t
+
 val empty_vector_access : t
+
 val eradicate_condition_redundant : t
+
 val eradicate_condition_redundant_nonnull : t
+
 val eradicate_field_not_initialized : t
+
 val eradicate_field_not_mutable : t
+
 val eradicate_field_not_nullable : t
+
 val eradicate_field_over_annotated : t
+
 val eradicate_field_value_absent : t
+
 val eradicate_inconsistent_subclass_parameter_annotation : t
+
 val eradicate_inconsistent_subclass_return_annotation : t
+
 val eradicate_null_field_access : t
+
 val eradicate_null_method_call : t
+
 val eradicate_parameter_not_nullable : t
+
 val eradicate_parameter_value_absent : t
+
 val eradicate_return_not_nullable : t
+
 val eradicate_return_over_annotated : t
+
 val eradicate_return_value_not_present : t
+
 val eradicate_value_not_present : t
+
 val field_should_be_nullable : t
+
 val field_not_null_checked : t
+
 val inherently_dangerous_function : t
+
 val memory_leak : t
+
 val null_dereference : t
+
 val null_test_after_dereference : t
+
 val parameter_not_null_checked : t
+
 val pointer_size_mismatch : t
+
 val precondition_not_found : t
+
 val precondition_not_met : t
+
 val premature_nil_termination : t
+
 val proc_callback : t
+
 val quandary_taint_error : t
+
 val registered_observer_being_deallocated : t
+
 val resource_leak : t
+
 val retain_cycle : t
+
 val return_expression_required : t
+
 val return_statement_missing : t
+
 val return_value_ignored : t
+
 val skip_function : t
+
 val skip_pointer_dereference : t
+
 val stack_variable_address_escape : t
+
 val static_initialization_order_fiasco : t
+
 val tainted_value_reaching_sensitive_function : t
+
 val thread_safety_violation : t
+
 val unary_minus_applied_to_unsigned_expression : t
+
 val uninitialized_value : t
+
 val unreachable_code_after : t
+
 val unsafe_guarded_by_access : t
+
 val use_after_free : t
 
 module Tags : sig
   type t
 
-  (** convert error description's tags to atd-serializable format *)
   val tag_value_records_of_tags : t -> Jsonbug_t.tag_value_record list
+  (** convert error description's tags to atd-serializable format *)
 
   (* convert atd-serializable format to error description's tags *)
+
   val tags_of_tag_value_records : Jsonbug_t.tag_value_record list -> t
 
   (* collect all lines from tags *)
+
   val lines_of_tags : t -> int list
 end
 
 (** description field of error messages *)
-type error_desc = {
+type error_desc =
-  descriptions : string list;
+  {descriptions: string list; advice: string option; tags: Tags.t; dotty: string option}
-  advice : string option;
+  [@@deriving compare]
-  tags : Tags.t;
-  dotty : string option;
-} [@@deriving compare]
 
-(** empty error description *)
 val no_desc : error_desc
+(** empty error description *)
 
-(** verbatim desc from a string, not to be used for user-visible descs *)
 val verbatim_desc : string -> error_desc
+(** verbatim desc from a string, not to be used for user-visible descs *)
 
-(** verbatim desc with custom tags *)
 val custom_desc : string -> (string * string) list -> error_desc
+(** verbatim desc with custom tags *)
 
-(** verbatim desc with advice and custom tags *)
 val custom_desc_with_advice : string -> string -> (string * string) list -> error_desc
+(** verbatim desc with advice and custom tags *)
 
 module BucketLevel : sig
-  val b1 : string (* highest likelyhood *)
+  val b1 : string
+
+  (* highest likelyhood *)
+
   val b2 : string
+
   val b3 : string
+
   val b4 : string
-  val b5 : string (* lowest likelyhood *)
+
+  val b5 : string
+  (* lowest likelyhood *)
 end
 
-(** returns the value of a tag or the empty string *)
 val error_desc_extract_tag_value : error_desc -> string -> string
+(** returns the value of a tag or the empty string *)
 
-(** returns all the tuples (tag, value) of an error_desc *)
 val error_desc_to_tag_value_pairs : error_desc -> (string * string) list
+(** returns all the tuples (tag, value) of an error_desc *)
 
-(** returns the content of the value tag of the error_desc *)
 val error_desc_get_tag_value : error_desc -> string
+(** returns the content of the value tag of the error_desc *)
 
-(** returns the content of the call_procedure tag of the error_desc *)
 val error_desc_get_tag_call_procedure : error_desc -> string
+(** returns the content of the call_procedure tag of the error_desc *)
 
-(** get the bucket value of an error_desc, if any *)
 val error_desc_get_bucket : error_desc -> string option
+(** get the bucket value of an error_desc, if any *)
 
+val error_desc_set_bucket : error_desc -> string -> bool -> error_desc
 (** set the bucket value of an error_desc.
     The boolean indicates where the bucket should be shown in the message *)
-val error_desc_set_bucket : error_desc -> string -> bool -> error_desc
 
-(** hash function for error_desc *)
 val error_desc_hash : error_desc -> int
+(** hash function for error_desc *)
 
-(** equality for error_desc *)
 val error_desc_equal : error_desc -> error_desc -> bool
+(** equality for error_desc *)
 
-(** pretty print an error description *)
 val pp_error_desc : Format.formatter -> error_desc -> unit
+(** pretty print an error description *)
 
-(** pretty print an error advice *)
 val pp_error_advice : Format.formatter -> error_desc -> unit
+(** pretty print an error advice *)
 
-(** get tags of error description *)
 val error_desc_get_tags : error_desc -> (string * string) list
+(** get tags of error description *)
 
 val error_desc_get_dotty : error_desc -> string option
 
@@ -185,40 +263,42 @@ val error_desc_get_dotty : error_desc -> string option
 (** dereference strings used to explain a dereference action in an error message *)
 type deref_str
 
-(** dereference strings for null dereference *)
 val deref_str_null : Typ.Procname.t option -> deref_str
+(** dereference strings for null dereference *)
 
-(** dereference strings for null dereference due to Nullable annotation *)
 val deref_str_nullable : Typ.Procname.t option -> string -> deref_str
+(** dereference strings for null dereference due to Nullable annotation *)
 
-(** dereference strings for null dereference due to weak captured variable in block *)
 val deref_str_weak_variable_in_block : Typ.Procname.t option -> string -> deref_str
+(** dereference strings for null dereference due to weak captured variable in block *)
 
-(** dereference strings for an undefined value coming from the given procedure *)
 val deref_str_undef : Typ.Procname.t * Location.t -> deref_str
+(** dereference strings for an undefined value coming from the given procedure *)
 
-(** dereference strings for a freed pointer dereference *)
 val deref_str_freed : PredSymb.res_action -> deref_str
+(** dereference strings for a freed pointer dereference *)
 
-(** dereference strings for a dangling pointer dereference *)
 val deref_str_dangling : PredSymb.dangling_kind option -> deref_str
+(** dereference strings for a dangling pointer dereference *)
 
-(** dereference strings for an array out of bound access *)
 val deref_str_array_bound : IntLit.t option -> IntLit.t option -> deref_str
+(** dereference strings for an array out of bound access *)
 
-(** dereference strings for an uninitialized access whose lhs has the given attribute *)
 val deref_str_uninitialized : Sil.atom option -> deref_str
+(** dereference strings for an uninitialized access whose lhs has the given attribute *)
 
-(** dereference strings for nonterminal nil arguments in c/objc variadic methods *)
 val deref_str_nil_argument_in_variadic_method : Typ.Procname.t -> int -> int -> deref_str
+(** dereference strings for nonterminal nil arguments in c/objc variadic methods *)
 
-(** dereference strings for a pointer size mismatch *)
 val deref_str_pointer_size_mismatch : Typ.t -> Typ.t -> deref_str
+(** dereference strings for a pointer size mismatch *)
 
 (** type of access *)
 type access =
-  | Last_assigned of int * bool (* line, null_case_flag *)
+  | Last_assigned of int * bool
-  | Last_accessed of int * bool (* line, is_nullable flag *)
+  (* line, null_case_flag *)
+  | Last_accessed of int * bool
+  (* line, is_nullable flag *)
   | Initialized_automatically
   | Returned_from_call of int
 
@@ -233,7 +313,8 @@ val is_field_not_null_checked_desc : error_desc -> bool
 val is_parameter_field_not_null_checked_desc : error_desc -> bool
 
 val desc_allocation_mismatch :
-  Typ.Procname.t * Typ.Procname.t * Location.t -> Typ.Procname.t * Typ.Procname.t * Location.t -> error_desc
+  Typ.Procname.t * Typ.Procname.t * Location.t -> Typ.Procname.t * Typ.Procname.t * Location.t
+  -> error_desc
 
 val desc_class_cast_exception :
   Typ.Procname.t option -> string -> string -> string option -> Location.t -> error_desc
@@ -263,8 +344,8 @@ val is_empty_vector_access_desc : error_desc -> bool
 val desc_frontend_warning : string -> string option -> Location.t -> error_desc
 
 val desc_leak :
-  Exp.t option -> string option -> PredSymb.resource option -> PredSymb.res_action option ->
+  Exp.t option -> string option -> PredSymb.resource option -> PredSymb.res_action option
-  Location.t -> string option -> error_desc
+  -> Location.t -> string option -> error_desc
 
 val desc_buffer_overrun : string -> string -> error_desc
 
@@ -273,27 +354,24 @@ val desc_null_test_after_dereference : string -> int -> Location.t -> error_desc
 val java_unchecked_exn_desc : Typ.Procname.t -> Typ.Name.t -> string -> error_desc
 
 val desc_context_leak :
-  Typ.Procname.t -> Typ.t -> Typ.Fieldname.t ->
+  Typ.Procname.t -> Typ.t -> Typ.Fieldname.t -> (Typ.Fieldname.t option * Typ.t) list -> error_desc
-  (Typ.Fieldname.t option * Typ.t) list -> error_desc
 
-val desc_fragment_retains_view :
+val desc_fragment_retains_view : Typ.t -> Typ.Fieldname.t -> Typ.t -> Typ.Procname.t -> error_desc
-  Typ.t -> Typ.Fieldname.t -> Typ.t -> Typ.Procname.t -> error_desc
 
 (* Create human-readable error description for assertion failures *)
+
 val desc_custom_error : Location.t -> error_desc
 
 (** kind of precondition not met *)
-type pnm_kind =
+type pnm_kind = Pnm_bounds | Pnm_dangling
-  | Pnm_bounds
-  | Pnm_dangling
 
 val desc_precondition_not_met : pnm_kind option -> Typ.Procname.t -> Location.t -> error_desc
 
 val desc_return_expression_required : string -> Location.t -> error_desc
 
 val desc_retain_cycle :
-  ((Sil.strexp * Typ.t) * Typ.Fieldname.t * Sil.strexp) list ->
+  ((Sil.strexp * Typ.t) * Typ.Fieldname.t * Sil.strexp) list -> Location.t -> string option
-  Location.t -> string option -> error_desc
+  -> error_desc
 
 val registered_observer_being_deallocated_str : string -> string
 

infer/src/IR/Location.ml

@@ -0,0 +1,40 @@
+(*
+ * 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
+module F = Format
+module L = Logging
+
+(** Location in the original source file *)
+type t =
+  { line: int  (** The line number. -1 means "do not know" *)
+  ; col: int  (** The column number. -1 means "do not know" *)
+  ; file: SourceFile.t  (** The name of the source file *) }
+  [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+(** Dump a location *)
+let d (loc: t) = L.add_print_action (L.PTloc, Obj.repr loc)
+
+let none file = {line= -1; col= -1; file}
+
+let dummy = none (SourceFile.invalid __FILE__)
+
+(** Pretty print a location *)
+let pp f (loc: t) = F.fprintf f "[line %d]" loc.line
+
+let to_string loc =
+  let s = string_of_int loc.line in
+  if loc.col <> -1 then s ^ ":" ^ string_of_int loc.col else s
+
+(** Pretty print a file-position of a location *)
+let pp_file_pos f (loc: t) =
+  let fname = SourceFile.to_string loc.file in
+  let pos = to_string loc in
+  F.fprintf f "%s:%s" fname pos

infer/src/IR/Location.mli

@@ -0,0 +1,44 @@
+(*
+ * 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
+
+(** Location in the original source file *)
+
+type t =
+  { line: int  (** The line number. -1 means "do not know" *)
+  ; col: int  (** The column number. -1 means "do not know" *)
+  ; file: SourceFile.t  (** The name of the source file *) }
+  [@@deriving compare]
+
+val equal : t -> t -> bool
+
+(** Dump a location. *)
+
+val d : t -> unit
+
+(** Dummy source location for the given file *)
+
+val none : SourceFile.t -> t
+
+(** Dummy location with no source file *)
+
+val dummy : t
+
+(** Pretty print a location. *)
+
+val pp : Format.formatter -> t -> unit
+
+(** String representation of a location. *)
+
+val to_string : t -> string
+
+(** Pretty print a file-position of a location *)
+
+val pp_file_pos : Format.formatter -> t -> unit

infer/src/IR/Location.re

@@ -1,53 +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;
-
-module F = Format;
-
-module L = Logging;
-
-
-/** Location in the original source file */
-type t = {
-  line: int, /** The line number. -1 means "do not know" */
-  col: int, /** The column number. -1 means "do not know" */
-  file: SourceFile.t /** The name of the source file */
-}
-[@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-
-/** Dump a location */
-let d (loc: t) => L.add_print_action (L.PTloc, Obj.repr loc);
-
-let none file => {line: (-1), col: (-1), file};
-
-let dummy = none (SourceFile.invalid __FILE__);
-
-
-/** Pretty print a location */
-let pp f (loc: t) => F.fprintf f "[line %d]" loc.line;
-
-let to_string loc => {
-  let s = string_of_int loc.line;
-  if (loc.col != (-1)) {
-    s ^ ":" ^ string_of_int loc.col
-  } else {
-    s
-  }
-};
-
-
-/** Pretty print a file-position of a location */
-let pp_file_pos f (loc: t) => {
-  let fname = SourceFile.to_string loc.file;
-  let pos = to_string loc;
-  F.fprintf f "%s:%s" fname pos
-};

infer/src/IR/Location.rei

@@ -1,44 +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;
-
-
-/** Location in the original source file */
-type t = {
-  line: int, /** The line number. -1 means "do not know" */
-  col: int, /** The column number. -1 means "do not know" */
-  file: SourceFile.t /** The name of the source file */
-}
-[@@deriving compare];
-
-let equal: t => t => bool;
-
-
-/** Dump a location. */
-let d: t => unit;
-
-
-/** Dummy source location for the given file */
-let none: SourceFile.t => t;
-
-
-/** Dummy location with no source file */
-let dummy: t;
-
-
-/** Pretty print a location. */
-let pp: Format.formatter => t => unit;
-
-
-/** String representation of a location. */
-let to_string: t => string;
-
-
-/** Pretty print a file-position of a location */
-let pp_file_pos: Format.formatter => t => unit;

infer/src/IR/Mangled.ml

@@ -0,0 +1,48 @@
+(*
+ * 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 Mangled Names *)
+open! IStd
+module F = Format
+
+type t = {plain: string; mangled: string option} [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+(** Convert a string to a mangled name *)
+let from_string (s: string) = {plain= s; mangled= None}
+
+(** Create a mangled name from a plain and mangled string *)
+let mangled (plain: string) (mangled: string) = {plain; mangled= Some (plain ^ "{" ^ mangled ^ "}")}
+
+(** Convert a mangled name to a string *)
+let to_string (pn: t) = pn.plain
+
+(** Convert a full mangled name to a string *)
+let to_string_full (pn: t) =
+  match pn.mangled with Some mangled -> pn.plain ^ "{" ^ mangled ^ "}" | None -> pn.plain
+
+(** Get mangled string if given *)
+let get_mangled pn = match pn.mangled with Some s -> s | None -> pn.plain
+
+(** Pretty print a mangled name *)
+let pp f pn = F.fprintf f "%s" (to_string pn)
+
+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)

infer/src/IR/Mangled.mli

@@ -0,0 +1,53 @@
+(*
+ * 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 Mangled Names *)
+
+(** Type of mangled names *)
+
+type t [@@deriving compare]
+
+(** Equality for mangled names *)
+
+val equal : t -> t -> bool
+
+(** Convert a string to a mangled name *)
+
+val from_string : string -> t
+
+(** Create a mangled name from a plain and mangled string *)
+
+val mangled : string -> string -> t
+
+(** Convert a mangled name to a string *)
+
+val to_string : t -> string
+
+(** Convert a full mangled name to a string *)
+
+val to_string_full : t -> string
+
+(** Get mangled string if given *)
+
+val get_mangled : t -> string
+
+(** Pretty print a mangled name *)
+
+val pp : Format.formatter -> t -> unit
+
+(** Set of Mangled. *)
+
+module Set : Caml.Set.S with type elt = t
+
+(** Map with Mangled as key *)
+
+module Map : Caml.Map.S with type key = t

infer/src/IR/Mangled.re

@@ -1,65 +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 Mangled Names */
-module F = Format;
-
-type t = {plain: string, mangled: option string} [@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-
-/** Convert a string to a mangled name */
-let from_string (s: string) => {plain: s, mangled: None};
-
-
-/** Create a mangled name from a plain and mangled string */
-let mangled (plain: string) (mangled: string) => {
-  plain,
-  mangled: Some (plain ^ "{" ^ mangled ^ "}")
-};
-
-
-/** Convert a mangled name to a string */
-let to_string (pn: t) => pn.plain;
-
-
-/** Convert a full mangled name to a string */
-let to_string_full (pn: t) =>
-  switch pn.mangled {
-  | Some mangled => pn.plain ^ "{" ^ mangled ^ "}"
-  | None => pn.plain
-  };
-
-
-/** Get mangled string if given */
-let get_mangled pn =>
-  switch pn.mangled {
-  | Some s => s
-  | None => pn.plain
-  };
-
-
-/** Pretty print a mangled name */
-let pp f pn => F.fprintf f "%s" (to_string pn);
-
-module Set =
-  Caml.Set.Make {
-    type nonrec t = t;
-    let compare = compare;
-  };
-
-module Map =
-  Caml.Map.Make {
-    type nonrec t = t;
-    let compare = compare;
-  };

infer/src/IR/Mangled.rei

@@ -1,52 +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 Mangled Names */
-
-/** Type of mangled names */
-type t [@@deriving compare];
-
-
-/** Equality for mangled names */
-let equal: t => t => bool;
-
-
-/** Convert a string to a mangled name */
-let from_string: string => t;
-
-
-/** Create a mangled name from a plain and mangled string */
-let mangled: string => string => t;
-
-
-/** Convert a mangled name to a string */
-let to_string: t => string;
-
-
-/** Convert a full mangled name to a string */
-let to_string_full: t => string;
-
-
-/** Get mangled string if given */
-let get_mangled: t => string;
-
-
-/** Pretty print a mangled name */
-let pp: Format.formatter => t => unit;
-
-
-/** Set of Mangled. */
-module Set: Caml.Set.S with type elt = t;
-
-
-/** Map with Mangled as key */
-module Map: Caml.Map.S with type key = t;

infer/src/IR/Mleak_buckets.ml

@@ -17,57 +17,42 @@ let objc_arc_flag = "objc_arc"
 
 let bucket_to_message bucket =
   match bucket with
-  | `MLeak_cf -> "[CF]"
+  | `MLeak_cf
-  | `MLeak_arc -> "[ARC]"
+   -> "[CF]"
-  | `MLeak_no_arc -> "[NO ARC]"
+  | `MLeak_arc
-  | `MLeak_cpp -> "[CPP]"
+   -> "[ARC]"
-  | `MLeak_unknown -> "[UNKNOWN ORIGIN]"
+  | `MLeak_no_arc
+   -> "[NO ARC]"
+  | `MLeak_cpp
+   -> "[CPP]"
+  | `MLeak_unknown
+   -> "[UNKNOWN ORIGIN]"
 
-let contains_all =
+let contains_all = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_all
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_all
 
-let contains_cf =
+let contains_cf = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_cf
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_cf
 
-let contains_arc =
+let contains_arc = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_arc
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_arc
 
-let contains_narc =
+let contains_narc = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_no_arc
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_no_arc
 
-let contains_cpp =
+let contains_cpp = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_cpp
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_cpp
 
-let contains_unknown_origin =
+let contains_unknown_origin = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_unknown
-  List.mem ~equal:PVariant.(=) Config.ml_buckets `MLeak_unknown
 
-let should_raise_leak_cf typ =
+let should_raise_leak_cf typ = if contains_cf then Objc_models.is_core_lib_type typ else false
-  if contains_cf then
-    Objc_models.is_core_lib_type typ
-  else false
 
-let should_raise_leak_arc () =
+let should_raise_leak_arc () = if contains_arc then !Config.arc_mode else false
-  if contains_arc then
-    !Config.arc_mode
-  else false
 
-let should_raise_leak_no_arc () =
+let should_raise_leak_no_arc () = if contains_narc then not !Config.arc_mode else false
-  if contains_narc then
-    not (!Config.arc_mode)
-  else false
 
-let should_raise_leak_unknown_origin =
+let should_raise_leak_unknown_origin = contains_unknown_origin
-  contains_unknown_origin
 
-let ml_bucket_unknown_origin =
+let ml_bucket_unknown_origin = bucket_to_message `MLeak_unknown
-  bucket_to_message `MLeak_unknown
 
 (* Returns whether a memory leak should be raised for a C++ object.*)
 (* If ml_buckets contains cpp, then check leaks from C++ objects. *)
-let should_raise_cpp_leak =
+let should_raise_cpp_leak = if contains_cpp then Some (bucket_to_message `MLeak_cpp) else None
-  if contains_cpp then
-    Some (bucket_to_message `MLeak_cpp)
-  else None
 
 (* Returns whether a memory leak should be raised. *)
 (* If cf is passed, then check leaks from Core Foundation. *)

infer/src/IR/Mleak_buckets.mli

@@ -17,10 +17,12 @@ val objc_arc_flag : string
 (* If cf is passed, then check leaks from Core Foundation. *)
 (* If arc is passed, check leaks from code that compiles with arc*)
 (* If no arc is passed check the leaks from code that compiles without arc *)
+
 val should_raise_objc_leak : Typ.t -> string option
 
 (* Returns whether a memory leak should be raised for a C++ object.*)
 (* If ml_buckets contains cpp, then check leaks from C++ objects. *)
+
 val should_raise_cpp_leak : string option
 
 val should_raise_leak_unknown_origin : bool

infer/src/IR/Objc_models.ml

@@ -14,168 +14,144 @@ open! IStd
 (** This module models special c struct types from the Apple's Core Foundation libraries
     for which there are particular rules for memory management. *)
 
-module Core_foundation_model =
+module Core_foundation_model = struct
-struct
+  let core_foundation =
-
+    [ "__CFArray"
-  let core_foundation = [
+    ; "__CFAttributedString"
-    "__CFArray";
+    ; "__CFBag"
-    "__CFAttributedString";
+    ; "__CFNull"
-    "__CFBag";
+    ; "__CFAllocator"
-    "__CFNull";
+    ; "__CFBinaryHeap"
-    "__CFAllocator";
+    ; "__CFBitVector"
-    "__CFBinaryHeap";
+    ; "__CFBundle"
-    "__CFBitVector";
+    ; "__CFCalendar"
-    "__CFBundle";
+    ; "__CFCharacterSet"
-    "__CFCalendar";
+    ; "__CFDate"
-    "__CFCharacterSet";
+    ; "__CFDateFormatter"
-    "__CFDate";
+    ; "__CFDictionary"
-    "__CFDateFormatter";
+    ; "__CFError"
-    "__CFDictionary";
+    ; "__CFFileDescriptor"
-    "__CFError";
+    ; "__CFFileSecurity"
-    "__CFFileDescriptor";
+    ; "__CFLocale"
-    "__CFFileSecurity";
+    ; "__CFMachPort"
-    "__CFLocale";
+    ; "__CFMessagePort"
-    "__CFMachPort";
+    ; "__CFNotificationCenter"
-    "__CFMessagePort";
+    ; "__CFBoolean"
-    "__CFNotificationCenter";
+    ; "__CFNumber"
-    "__CFBoolean";
+    ; "__CFNumberFormatter"
-    "__CFNumber";
+    ; "__CFPlugInInstance"
-    "__CFNumberFormatter";
+    ; "__CFReadStream"
-    "__CFPlugInInstance";
+    ; "__CFWriteStream"
-    "__CFReadStream";
+    ; "__CFRunLoop"
-    "__CFWriteStream";
+    ; "__CFRunLoopSource"
-    "__CFRunLoop";
+    ; "__CFRunLoopObserver"
-    "__CFRunLoopSource";
+    ; "__CFRunLoopTimer"
-    "__CFRunLoopObserver";
+    ; "__CFSet"
-    "__CFRunLoopTimer";
+    ; "__CFStringTokenizer"
-    "__CFSet";
+    ; "__CFSocket"
-    "__CFStringTokenizer";
+    ; "__CFReadStream"
-    "__CFSocket";
+    ; "__CFWriteStream"
-    "__CFReadStream";
+    ; "__CFTimeZone"
-    "__CFWriteStream";
+    ; "__CFTree"
-    "__CFTimeZone";
+    ; "__CFURLEnumerator"
-    "__CFTree";
+    ; "__CFUUID" ]
-    "__CFURLEnumerator";
+
-    "__CFUUID"
+  let cf_network =
-  ]
+    [ "_CFHTTPAuthentication"
-
+    ; "__CFHTTPMessage"
-  let cf_network = [
+    ; "__CFHost"
-    "_CFHTTPAuthentication";
+    ; "__CFNetDiagnostic"
-    "__CFHTTPMessage";
+    ; "__CFNetService"
-    "__CFHost";
+    ; "__CFNetServiceMonitor"
-    "__CFNetDiagnostic";
+    ; "__CFNetServiceBrowser" ]
-    "__CFNetService";
+
-    "__CFNetServiceMonitor";
+  let core_media =
-    "__CFNetServiceBrowser"
+    [ "OpaqueCMBlockBuffer"
-  ]
+    ; "opaqueCMBufferQueue"
-
+    ; "opaqueCMBufferQueueTriggerToken"
-  let core_media = [
+    ; "opaqueCMFormatDescription"
-    "OpaqueCMBlockBuffer";
+    ; "OpaqueCMMemoryPool"
-    "opaqueCMBufferQueue";
+    ; "opaqueCMSampleBuffer"
-    "opaqueCMBufferQueueTriggerToken";
+    ; "opaqueCMSimpleQueue"
-    "opaqueCMFormatDescription";
+    ; "OpaqueCMClock"
-    "OpaqueCMMemoryPool";
+    ; "OpaqueCMTimebase" ]
-    "opaqueCMSampleBuffer";
+
-    "opaqueCMSimpleQueue";
+  let core_text =
-    "OpaqueCMClock";
+    [ "__CTFont"
-    "OpaqueCMTimebase"
+    ; "__CTFontCollection"
-  ]
+    ; "__CTFontDescriptor"
-
+    ; "__CTFrame"
-  let core_text = [
+    ; "__CTFramesetter"
-    "__CTFont";
+    ; "__CTGlyphInfo"
-    "__CTFontCollection";
+    ; "__CTLine"
-    "__CTFontDescriptor";
+    ; "__CTParagraphStyle"
-    "__CTFrame";
+    ; "__CTRubyAnnotation"
-    "__CTFramesetter";
+    ; "__CTRun"
-    "__CTGlyphInfo";
+    ; "__CTRunDelegate"
-    "__CTLine";
+    ; "__CTTextTab"
-    "__CTParagraphStyle";
+    ; "__CTTypesetter" ]
-    "__CTRubyAnnotation";
+
-    "__CTRun";
+  let core_video =
-    "__CTRunDelegate";
+    ["__CVBuffer"; "__CVMetalTextureCache"; "__CVOpenGLESTextureCache"; "__CVPixelBufferPool"]
-    "__CTTextTab";
+
-    "__CTTypesetter"
+  let image_io = ["CGImageDestination"; "CGImageMetadata"; "CGImageMetadataTag"; "CGImageSource"]
-  ]
+
-
+  let security =
-  let core_video = [
+    [ "__SecCertificate"
-    "__CVBuffer";
+    ; "__SecIdentity"
-    "__CVMetalTextureCache";
+    ; "__SecKey"
-    "__CVOpenGLESTextureCache";
+    ; "__SecPolicy"
-    "__CVPixelBufferPool"
+    ; "__SecAccessControl"
-  ]
+    ; "__SecRandom"
-
+    ; "__SecCode"
-  let image_io = [
+    ; "__SecTrust"
-    "CGImageDestination";
+    ; "__SecRequirement" ]
-    "CGImageMetadata";
+
-    "CGImageMetadataTag";
+  let system_configuration =
-    "CGImageSource"
+    [ "__SCDynamicStore"
-  ]
+    ; "__SCNetworkInterface"
-
+    ; "__SCBondStatus"
-  let security = [
+    ; "__SCNetworkProtocol"
-    "__SecCertificate";
+    ; "__SCNetworkService"
-    "__SecIdentity";
+    ; "__SCNetworkSet"
-    "__SecKey";
+    ; "__SCNetworkConnection"
-    "__SecPolicy";
+    ; "__SCNetworkReachability"
-    "__SecAccessControl";
+    ; "__SCPreferences" ]
-    "__SecRandom";
+
-    "__SecCode";
+  let core_graphics_types =
-    "__SecTrust";
+    [ "CGAffineTransform"
-    "__SecRequirement"
+    ; "CGBase"
-  ]
+    ; "CGBitmapContext"
-
+    ; "CGColor"
-  let system_configuration = [
+    ; "CGColorSpace"
-    "__SCDynamicStore";
+    ; "CGContext"
-    "__SCNetworkInterface";
+    ; "CGDataConsumer"
-    "__SCBondStatus";
+    ; "CGDataProvider"
-    "__SCNetworkProtocol";
+    ; "CGError"
-    "__SCNetworkService";
+    ; "CGFont"
-    "__SCNetworkSet";
+    ; "CGFunction"
-    "__SCNetworkConnection";
+    ; "CGGeometry"
-    "__SCNetworkReachability";
+    ; "CGGradient"
-    "__SCPreferences"
+    ; "CGImage"
-  ]
+    ; "CGLayer"
-
+    ; "CGPath"
-  let core_graphics_types = [
+    ; "CGPattern"
-    "CGAffineTransform";
+    ; "CGPDFArray"
-    "CGBase";
+    ; "CGPDFContentStream"
-    "CGBitmapContext";
+    ; "CGPDFContext"
-    "CGColor";
+    ; "CGPDFDictionary"
-    "CGColorSpace";
+    ; "CGPDFDocument"
-    "CGContext";
+    ; "CGPDFObject"
-    "CGDataConsumer";
+    ; "CGPDFOperatorTable"
-    "CGDataProvider";
+    ; "CGPDFPage"
-    "CGError";
+    ; "CGPDFScanner"
-    "CGFont";
+    ; "CGPDFStream"
-    "CGFunction";
+    ; "CGPDFString"
-    "CGGeometry";
+    ; "CGShading" ]
-    "CGGradient";
-    "CGImage";
-    "CGLayer";
-    "CGPath";
-    "CGPattern";
-    "CGPDFArray";
-    "CGPDFContentStream";
-    "CGPDFContext";
-    "CGPDFDictionary";
-    "CGPDFDocument";
-    "CGPDFObject";
-    "CGPDFOperatorTable";
-    "CGPDFPage";
-    "CGPDFScanner";
-    "CGPDFStream";
-    "CGPDFString";
-    "CGShading"
-  ]
 
   let core_foundation_types =
-    core_foundation @
+    core_foundation @ cf_network @ core_media @ core_text @ core_video @ image_io @ security
-    cf_network @
+    @ system_configuration
-    core_media @
-    core_text @
-    core_video @
-    image_io @
-    security @
-    system_configuration
 
   let copy = "Copy"
 
@@ -191,56 +167,49 @@ struct
 
   let cf_type = "CFTypeRef"
 
-  type core_lib =
+  type core_lib = Core_foundation | Core_graphics
-    | Core_foundation
-    | Core_graphics
 
   let core_lib_to_type_list lib =
     match lib with
-    | Core_foundation -> core_foundation_types
+    | Core_foundation
-    | Core_graphics -> core_graphics_types
+     -> core_foundation_types
+    | Core_graphics
+     -> core_graphics_types
 
   let is_objc_memory_model_controlled o =
-    List.mem ~equal:String.equal core_foundation_types o ||
+    List.mem ~equal:String.equal core_foundation_types o
-    List.mem ~equal:String.equal core_graphics_types o
+    || List.mem ~equal:String.equal core_graphics_types o
 
   let rec is_core_lib lib typ =
     match typ.Typ.desc with
-    | Typ.Tptr (styp, _ ) ->
+    | Typ.Tptr (styp, _)
-        is_core_lib lib styp
+     -> is_core_lib lib styp
-    | Typ.Tstruct name ->
+    | Typ.Tstruct name
-        let core_lib_types = core_lib_to_type_list lib in
+     -> let core_lib_types = core_lib_to_type_list lib in
         List.mem ~equal:String.equal core_lib_types (Typ.Name.name name)
-    | _ -> false
+    | _
+     -> false
 
-  let is_core_foundation_type typ =
+  let is_core_foundation_type typ = is_core_lib Core_foundation typ
-    is_core_lib Core_foundation typ
 
-  let is_core_graphics_type typ =
+  let is_core_graphics_type typ = is_core_lib Core_graphics typ
-    is_core_lib Core_graphics typ
 
-  let is_core_lib_type typ =
+  let is_core_lib_type typ = is_core_foundation_type typ || is_core_graphics_type typ
-    is_core_foundation_type typ ||
-    is_core_graphics_type typ
 
   let is_core_lib_create typ funct =
-    is_core_lib_type typ &&
+    is_core_lib_type typ
-    ((String.is_substring ~substring:create funct) ||
+    && (String.is_substring ~substring:create funct || String.is_substring ~substring:copy funct)
-     (String.is_substring ~substring:copy funct ))
 
-  let function_arg_is_cftype typ =
+  let function_arg_is_cftype typ = String.is_substring ~substring:cf_type typ
-    (String.is_substring ~substring:cf_type typ)
 
-  let is_core_lib_retain typ funct =
+  let is_core_lib_retain typ funct = function_arg_is_cftype typ && String.equal funct cf_retain
-    function_arg_is_cftype typ && String.equal funct cf_retain
 
-  let is_core_lib_release typ funct =
+  let is_core_lib_release typ funct = function_arg_is_cftype typ && String.equal funct cf_release
-    function_arg_is_cftype typ && String.equal funct cf_release
 
   let is_core_graphics_release typ funct =
     let f lib =
-      String.equal funct (lib ^ upper_release) &&
+      String.equal funct (lib ^ upper_release) && String.is_substring ~substring:(lib ^ ref) typ
-      String.is_substring ~substring:(lib ^ ref) typ in
+    in
     List.exists ~f core_graphics_types
 
   (*
@@ -250,5 +219,4 @@ struct
 *)
 end
 
-let is_core_lib_type typ =
+let is_core_lib_type typ = Core_foundation_model.is_core_lib_type typ
-  Core_foundation_model.is_core_lib_type typ

infer/src/IR/Objc_models.mli

@@ -15,9 +15,7 @@ open! IStd
 (** This module models special c struct types from the Apple's Core Foundation libraries
     for which there are particular rules for memory management. *)
 
-module Core_foundation_model :
+module Core_foundation_model : sig
-sig
-
   val is_core_lib_release : string -> string -> bool
 
   val is_core_lib_create : Typ.t -> string -> bool
@@ -27,8 +25,6 @@ sig
   val is_core_graphics_release : string -> string -> bool
 
   val is_objc_memory_model_controlled : string -> bool
-
-
 end
 
 val is_core_lib_type : Typ.t -> bool

infer/src/IR/PredSymb.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: Predicate Symbols *)
+open! IStd
+module L = Logging
+module F = Format
+
+type func_attribute =
+  | FA_sentinel of int * int  (** __attribute__((sentinel(int, int))) *)
+  [@@deriving compare]
+
+(** Visibility modifiers. *)
+type access = Default | Public | Private | Protected [@@deriving compare]
+
+let equal_access = [%compare.equal : access]
+
+(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *)
+let get_sentinel_func_attribute_value attr_list =
+  match attr_list with
+  | (FA_sentinel (sentinel, null_pos)) :: _
+   -> Some (sentinel, null_pos)
+  | []
+   -> None
+
+type mem_kind =
+  | Mmalloc  (** memory allocated with malloc *)
+  | Mnew  (** memory allocated with new *)
+  | Mnew_array  (** memory allocated with new[] *)
+  | Mobjc  (** memory allocated with objective-c alloc *)
+  [@@deriving compare]
+
+(** resource that can be allocated *)
+type resource = Rmemory of mem_kind | Rfile | Rignore | Rlock [@@deriving compare]
+
+(** kind of resource action *)
+type res_act_kind = Racquire | Rrelease [@@deriving compare]
+
+let equal_res_act_kind = [%compare.equal : res_act_kind]
+
+(** kind of dangling pointers *)
+type dangling_kind =
+  (** pointer is dangling because it is uninitialized *)
+  | DAuninit
+      (** pointer is dangling because it is the address
+      of a stack variable which went out of scope *)
+  | DAaddr_stack_var  (** pointer is -1 *)
+  | DAminusone
+  [@@deriving compare]
+
+(** position in a path: proc name, node id *)
+type path_pos = Typ.Procname.t * int [@@deriving compare]
+
+let equal_path_pos = [%compare.equal : path_pos]
+
+type taint_kind =
+  | Tk_unverified_SSL_socket
+  | Tk_shared_preferences_data
+  | Tk_privacy_annotation
+  | Tk_integrity_annotation
+  | Tk_unknown
+  [@@deriving compare]
+
+type taint_info = {taint_source: Typ.Procname.t; taint_kind: taint_kind} [@@deriving compare]
+
+(** acquire/release action on a resource *)
+type res_action =
+  { ra_kind: res_act_kind  (** kind of action *)
+  ; ra_res: resource  (** kind of resource *)
+  ; ra_pname: Typ.Procname.t  (** name of the procedure used to acquire/release the resource *)
+  ; ra_loc: Location.t  (** location of the acquire/release *)
+  ; ra_vpath: DecompiledExp.vpath  (** vpath of the resource value *) }
+
+(* ignore other values beside resources: arbitrary merging into one *)
+let compare_res_action {ra_kind= k1; ra_res= r1} {ra_kind= k2; ra_res= r2} =
+  [%compare : res_act_kind * resource] (k1, r1) (k2, r2)
+
+(* type aliases for components of t values that compare should ignore *)
+type _annot_item = Annot.Item.t
+
+let compare__annot_item _ _ = 0
+
+type _location = Location.t
+
+let compare__location _ _ = 0
+
+type _path_pos = path_pos
+
+let compare__path_pos _ _ = 0
+
+(** Attributes are nary function symbols that are applied to expression arguments in Apred and
+    Anpred atomic formulas.  Many operations don't make much sense for nullary predicates, and are
+    generally treated as no-ops.  The first argument is treated specially, as the "anchor" of the
+    predicate application.  For example, adding or removing an attribute uses the anchor to identify
+    the atom to operate on.  Also, abstraction and normalization operations treat the anchor
+    specially and maintain more information on it than other arguments.  Therefore when attaching an
+    attribute to an expression, that expression should be the first argument, optionally followed by
+    additional related expressions. *)
+type t =
+  | Aresource of res_action  (** resource acquire/release *)
+  | Aautorelease
+  | Adangling of dangling_kind  (** dangling pointer *)
+  (** undefined value obtained by calling the given procedure, plus its return value annots *)
+  | Aundef of Typ.Procname.t * _annot_item * _location * _path_pos
+  | Ataint of taint_info
+  | Auntaint of taint_info
+  | Alocked
+  | Aunlocked  (** value appeared in second argument of division at given path position *)
+  | Adiv0 of path_pos
+      (** attributed exp is null due to a call to a method with given path as null receiver *)
+  | Aobjc_null
+      (** value was returned from a call to the given procedure, plus the annots of the return value *)
+  | Aretval of Typ.Procname.t * Annot.Item.t
+      (** denotes an object registered as an observers to a notification center *)
+  | Aobserver  (** denotes an object unsubscribed from observers of a notification center *)
+  | Aunsubscribed_observer
+  [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+(** name of the allocation function for the given memory kind *)
+let mem_alloc_pname = function
+  | Mmalloc
+   -> Typ.Procname.from_string_c_fun "malloc"
+  | Mnew
+   -> Typ.Procname.from_string_c_fun "new"
+  | Mnew_array
+   -> Typ.Procname.from_string_c_fun "new[]"
+  | Mobjc
+   -> Typ.Procname.from_string_c_fun "alloc"
+
+(** name of the deallocation function for the given memory kind *)
+let mem_dealloc_pname = function
+  | Mmalloc
+   -> Typ.Procname.from_string_c_fun "free"
+  | Mnew
+   -> Typ.Procname.from_string_c_fun "delete"
+  | Mnew_array
+   -> Typ.Procname.from_string_c_fun "delete[]"
+  | Mobjc
+   -> Typ.Procname.from_string_c_fun "dealloc"
+
+(** Categories of attributes *)
+type category =
+  | ACresource
+  | ACautorelease
+  | ACtaint
+  | AClock
+  | ACdiv0
+  | ACobjc_null
+  | ACundef
+  | ACretval
+  | ACobserver
+  [@@deriving compare]
+
+let equal_category = [%compare.equal : category]
+
+let to_category att =
+  match att with
+  | Aresource _ | Adangling _
+   -> ACresource
+  | Ataint _ | Auntaint _
+   -> ACtaint
+  | Alocked | Aunlocked
+   -> AClock
+  | Aautorelease
+   -> ACautorelease
+  | Adiv0 _
+   -> ACdiv0
+  | Aobjc_null
+   -> ACobjc_null
+  | Aretval _
+   -> ACretval
+  | Aundef _
+   -> ACundef
+  | Aobserver | Aunsubscribed_observer
+   -> ACobserver
+
+let is_undef = function Aundef _ -> true | _ -> false
+
+(** convert the attribute to a string *)
+let to_string pe = function
+  | Aresource ra
+   -> let mk_name = function
+        | Mmalloc
+         -> "ma"
+        | Mnew
+         -> "ne"
+        | Mnew_array
+         -> "na"
+        | Mobjc
+         -> "oc"
+      in
+      let name =
+        match (ra.ra_kind, ra.ra_res) with
+        | Racquire, Rmemory mk
+         -> "MEM" ^ mk_name mk
+        | Racquire, Rfile
+         -> "FILE"
+        | Rrelease, Rmemory mk
+         -> "FREED" ^ mk_name mk
+        | Rrelease, Rfile
+         -> "CLOSED"
+        | _, Rignore
+         -> "IGNORE"
+        | Racquire, Rlock
+         -> "LOCKED"
+        | Rrelease, Rlock
+         -> "UNLOCKED"
+      in
+      let str_vpath =
+        if Config.trace_error then F.asprintf "%a" (DecompiledExp.pp_vpath pe) ra.ra_vpath else ""
+      in
+      name ^ Binop.str pe Lt ^ Typ.Procname.to_string ra.ra_pname ^ ":"
+      ^ string_of_int ra.ra_loc.Location.line ^ Binop.str pe Gt ^ str_vpath
+  | Aautorelease
+   -> "AUTORELEASE"
+  | Adangling dk
+   -> let dks =
+        match dk with
+        | DAuninit
+         -> "UNINIT"
+        | DAaddr_stack_var
+         -> "ADDR_STACK"
+        | DAminusone
+         -> "MINUS1"
+      in
+      "DANGL" ^ Binop.str pe Lt ^ dks ^ Binop.str pe Gt
+  | Aundef (pn, _, loc, _)
+   -> "UND" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":"
+      ^ string_of_int loc.Location.line
+  | Ataint {taint_source}
+   -> "TAINTED[" ^ Typ.Procname.to_string taint_source ^ "]"
+  | Auntaint _
+   -> "UNTAINTED"
+  | Alocked
+   -> "LOCKED"
+  | Aunlocked
+   -> "UNLOCKED"
+  | Adiv0 (_, _)
+   -> "DIV0"
+  | Aobjc_null
+   -> "OBJC_NULL"
+  | Aretval (pn, _)
+   -> "RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt
+  | Aobserver
+   -> "OBSERVER"
+  | Aunsubscribed_observer
+   -> "UNSUBSCRIBED_OBSERVER"
+
+(** dump an attribute *)
+let d_attribute (a: t) = L.add_print_action (L.PTattribute, Obj.repr a)

infer/src/IR/PredSymb.mli

@@ -0,0 +1,147 @@
+(*
+ * 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: Predicate Symbols *)
+open! IStd
+module L = Logging
+module F = Format
+
+(** {2 Programs and Types} *)
+
+type func_attribute = FA_sentinel of int * int [@@deriving compare]
+
+(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *)
+
+val get_sentinel_func_attribute_value : func_attribute list -> (int * int) option
+
+(** Visibility modifiers. *)
+
+type access = Default | Public | Private | Protected [@@deriving compare]
+
+val equal_access : access -> access -> bool
+
+type mem_kind =
+  | Mmalloc  (** memory allocated with malloc *)
+  | Mnew  (** memory allocated with new *)
+  | Mnew_array  (** memory allocated with new[] *)
+  | Mobjc  (** memory allocated with objective-c alloc *)
+  [@@deriving compare]
+
+(** resource that can be allocated *)
+
+type resource = Rmemory of mem_kind | Rfile | Rignore | Rlock [@@deriving compare]
+
+(** kind of resource action *)
+
+type res_act_kind = Racquire | Rrelease [@@deriving compare]
+
+val equal_res_act_kind : res_act_kind -> res_act_kind -> bool
+
+(** kind of dangling pointers *)
+
+type dangling_kind =
+  (** pointer is dangling because it is uninitialized *)
+  | DAuninit
+      (** pointer is dangling because it is the address of a stack variable which went out of scope *)
+  | DAaddr_stack_var  (** pointer is -1 *)
+  | DAminusone
+
+(** position in a path: proc name, node id *)
+
+type path_pos = Typ.Procname.t * int [@@deriving compare]
+
+val equal_path_pos : path_pos -> path_pos -> bool
+
+type taint_kind =
+  | Tk_unverified_SSL_socket
+  | Tk_shared_preferences_data
+  | Tk_privacy_annotation
+  | Tk_integrity_annotation
+  | Tk_unknown
+
+type taint_info = {taint_source: Typ.Procname.t; taint_kind: taint_kind}
+
+(** acquire/release action on a resource *)
+
+type res_action =
+  { ra_kind: res_act_kind  (** kind of action *)
+  ; ra_res: resource  (** kind of resource *)
+  ; ra_pname: Typ.Procname.t  (** name of the procedure used to acquire/release the resource *)
+  ; ra_loc: Location.t  (** location of the acquire/release *)
+  ; ra_vpath: DecompiledExp.vpath  (** vpath of the resource value *) }
+
+(** Attributes are nary function symbols that are applied to expression arguments in Apred and
+    Anpred atomic formulas.  Many operations don't make much sense for nullary predicates, and are
+    generally treated as no-ops.  The first argument is treated specially, as the "anchor" of the
+    predicate application.  For example, adding or removing an attribute uses the anchor to identify
+    the atom to operate on.  Also, abstraction and normalization operations treat the anchor
+    specially and maintain more information on it than other arguments.  Therefore when attaching an
+    attribute to an expression, that expression should be the first argument, optionally followed by
+    additional related expressions. *)
+
+type t =
+  | Aresource of res_action  (** resource acquire/release *)
+  | Aautorelease
+  | Adangling of dangling_kind  (** dangling pointer *)
+  (** undefined value obtained by calling the given procedure, plus its return value annots *)
+  | Aundef of Typ.Procname.t * Annot.Item.t * Location.t * path_pos
+  | Ataint of taint_info
+  | Auntaint of taint_info
+  | Alocked
+  | Aunlocked  (** value appeared in second argument of division at given path position *)
+  | Adiv0 of path_pos
+      (** attributed exp is null due to a call to a method with given path as null receiver *)
+  | Aobjc_null
+      (** value was returned from a call to the given procedure, plus the annots of the return value *)
+  | Aretval of Typ.Procname.t * Annot.Item.t
+      (** denotes an object registered as an observers to a notification center *)
+  | Aobserver  (** denotes an object unsubscribed from observers of a notification center *)
+  | Aunsubscribed_observer
+  [@@deriving compare]
+
+val equal : t -> t -> bool
+
+(** name of the allocation function for the given memory kind *)
+
+val mem_alloc_pname : mem_kind -> Typ.Procname.t
+
+(** name of the deallocation function for the given memory kind *)
+
+val mem_dealloc_pname : mem_kind -> Typ.Procname.t
+
+(** Categories of attributes *)
+
+type category =
+  | ACresource
+  | ACautorelease
+  | ACtaint
+  | AClock
+  | ACdiv0
+  | ACobjc_null
+  | ACundef
+  | ACretval
+  | ACobserver
+  [@@deriving compare]
+
+val equal_category : category -> category -> bool
+
+(**  Return the category to which the attribute belongs. *)
+
+val to_category : t -> category
+
+val is_undef : t -> bool
+
+(** convert the attribute to a string *)
+
+val to_string : Pp.env -> t -> string
+
+(** Dump an attribute. *)
+
+val d_attribute : t -> unit

infer/src/IR/PredSymb.re

@@ -1,269 +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: Predicate Symbols */
-module L = Logging;
-
-module F = Format;
-
-type func_attribute =
-  | FA_sentinel int int /** __attribute__((sentinel(int, int))) */
-[@@deriving compare];
-
-
-/** Visibility modifiers. */
-type access =
-  | Default
-  | Public
-  | Private
-  | Protected
-[@@deriving compare];
-
-let equal_access = [%compare.equal : access];
-
-
-/** Return the value of the FA_sentinel attribute in [attr_list] if it is found */
-let get_sentinel_func_attribute_value attr_list =>
-  switch attr_list {
-  | [FA_sentinel sentinel null_pos, ..._] => Some (sentinel, null_pos)
-  | [] => None
-  };
-
-type mem_kind =
-  | Mmalloc /** memory allocated with malloc */
-  | Mnew /** memory allocated with new */
-  | Mnew_array /** memory allocated with new[] */
-  | Mobjc /** memory allocated with objective-c alloc */
-[@@deriving compare];
-
-
-/** resource that can be allocated */
-type resource =
-  | Rmemory mem_kind
-  | Rfile
-  | Rignore
-  | Rlock
-[@@deriving compare];
-
-
-/** kind of resource action */
-type res_act_kind =
-  | Racquire
-  | Rrelease
-[@@deriving compare];
-
-let equal_res_act_kind = [%compare.equal : res_act_kind];
-
-
-/** kind of dangling pointers */
-type dangling_kind =
-  /** pointer is dangling because it is uninitialized */
-  | DAuninit
-  /** pointer is dangling because it is the address
-      of a stack variable which went out of scope */
-  | DAaddr_stack_var
-  /** pointer is -1 */
-  | DAminusone
-[@@deriving compare];
-
-
-/** position in a path: proc name, node id */
-type path_pos = (Typ.Procname.t, int) [@@deriving compare];
-
-let equal_path_pos = [%compare.equal : path_pos];
-
-type taint_kind =
-  | Tk_unverified_SSL_socket
-  | Tk_shared_preferences_data
-  | Tk_privacy_annotation
-  | Tk_integrity_annotation
-  | Tk_unknown
-[@@deriving compare];
-
-type taint_info = {taint_source: Typ.Procname.t, taint_kind} [@@deriving compare];
-
-
-/** acquire/release action on a resource */
-type res_action = {
-  ra_kind: res_act_kind, /** kind of action */
-  ra_res: resource, /** kind of resource */
-  ra_pname: Typ.Procname.t, /** name of the procedure used to acquire/release the resource */
-  ra_loc: Location.t, /** location of the acquire/release */
-  ra_vpath: DecompiledExp.vpath /** vpath of the resource value */
-};
-
-/* ignore other values beside resources: arbitrary merging into one */
-let compare_res_action {ra_kind: k1, ra_res: r1} {ra_kind: k2, ra_res: r2} =>
-  [%compare : (res_act_kind, resource)] (k1, r1) (k2, r2);
-
-/* type aliases for components of t values that compare should ignore */
-type _annot_item = Annot.Item.t;
-
-let compare__annot_item _ _ => 0;
-
-type _location = Location.t;
-
-let compare__location _ _ => 0;
-
-type _path_pos = path_pos;
-
-let compare__path_pos _ _ => 0;
-
-
-/** Attributes are nary function symbols that are applied to expression arguments in Apred and
-    Anpred atomic formulas.  Many operations don't make much sense for nullary predicates, and are
-    generally treated as no-ops.  The first argument is treated specially, as the "anchor" of the
-    predicate application.  For example, adding or removing an attribute uses the anchor to identify
-    the atom to operate on.  Also, abstraction and normalization operations treat the anchor
-    specially and maintain more information on it than other arguments.  Therefore when attaching an
-    attribute to an expression, that expression should be the first argument, optionally followed by
-    additional related expressions. */
-type t =
-  | Aresource res_action /** resource acquire/release */
-  | Aautorelease
-  | Adangling dangling_kind /** dangling pointer */
-  /** undefined value obtained by calling the given procedure, plus its return value annots */
-  | Aundef Typ.Procname.t _annot_item _location _path_pos
-  | Ataint taint_info
-  | Auntaint taint_info
-  | Alocked
-  | Aunlocked
-  /** value appeared in second argument of division at given path position */
-  | Adiv0 path_pos
-  /** attributed exp is null due to a call to a method with given path as null receiver */
-  | Aobjc_null
-  /** value was returned from a call to the given procedure, plus the annots of the return value */
-  | Aretval Typ.Procname.t Annot.Item.t
-  /** denotes an object registered as an observers to a notification center */
-  | Aobserver
-  /** denotes an object unsubscribed from observers of a notification center */
-  | Aunsubscribed_observer
-[@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-
-/** name of the allocation function for the given memory kind */
-let mem_alloc_pname =
-  fun
-  | Mmalloc => Typ.Procname.from_string_c_fun "malloc"
-  | Mnew => Typ.Procname.from_string_c_fun "new"
-  | Mnew_array => Typ.Procname.from_string_c_fun "new[]"
-  | Mobjc => Typ.Procname.from_string_c_fun "alloc";
-
-
-/** name of the deallocation function for the given memory kind */
-let mem_dealloc_pname =
-  fun
-  | Mmalloc => Typ.Procname.from_string_c_fun "free"
-  | Mnew => Typ.Procname.from_string_c_fun "delete"
-  | Mnew_array => Typ.Procname.from_string_c_fun "delete[]"
-  | Mobjc => Typ.Procname.from_string_c_fun "dealloc";
-
-
-/** Categories of attributes */
-type category =
-  | ACresource
-  | ACautorelease
-  | ACtaint
-  | AClock
-  | ACdiv0
-  | ACobjc_null
-  | ACundef
-  | ACretval
-  | ACobserver
-[@@deriving compare];
-
-let equal_category = [%compare.equal : category];
-
-let to_category att =>
-  switch att {
-  | Aresource _
-  | Adangling _ => ACresource
-  | Ataint _
-  | Auntaint _ => ACtaint
-  | Alocked
-  | Aunlocked => AClock
-  | Aautorelease => ACautorelease
-  | Adiv0 _ => ACdiv0
-  | Aobjc_null => ACobjc_null
-  | Aretval _ => ACretval
-  | Aundef _ => ACundef
-  | Aobserver
-  | Aunsubscribed_observer => ACobserver
-  };
-
-let is_undef =
-  fun
-  | Aundef _ => true
-  | _ => false;
-
-
-/** convert the attribute to a string */
-let to_string pe =>
-  fun
-  | Aresource ra => {
-      let mk_name = (
-        fun
-        | Mmalloc => "ma"
-        | Mnew => "ne"
-        | Mnew_array => "na"
-        | Mobjc => "oc"
-      );
-      let name =
-        switch (ra.ra_kind, ra.ra_res) {
-        | (Racquire, Rmemory mk) => "MEM" ^ mk_name mk
-        | (Racquire, Rfile) => "FILE"
-        | (Rrelease, Rmemory mk) => "FREED" ^ mk_name mk
-        | (Rrelease, Rfile) => "CLOSED"
-        | (_, Rignore) => "IGNORE"
-        | (Racquire, Rlock) => "LOCKED"
-        | (Rrelease, Rlock) => "UNLOCKED"
-        };
-      let str_vpath =
-        if Config.trace_error {
-          F.asprintf "%a" (DecompiledExp.pp_vpath pe) ra.ra_vpath
-        } else {
-          ""
-        };
-      name ^
-      Binop.str pe Lt ^
-      Typ.Procname.to_string ra.ra_pname ^
-      ":" ^ string_of_int ra.ra_loc.Location.line ^ Binop.str pe Gt ^ str_vpath
-    }
-  | Aautorelease => "AUTORELEASE"
-  | Adangling dk => {
-      let dks =
-        switch dk {
-        | DAuninit => "UNINIT"
-        | DAaddr_stack_var => "ADDR_STACK"
-        | DAminusone => "MINUS1"
-        };
-      "DANGL" ^ Binop.str pe Lt ^ dks ^ Binop.str pe Gt
-    }
-  | Aundef pn _ loc _ =>
-    "UND" ^
-    Binop.str pe Lt ^
-    Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":" ^ string_of_int loc.Location.line
-  | Ataint {taint_source} => "TAINTED[" ^ Typ.Procname.to_string taint_source ^ "]"
-  | Auntaint _ => "UNTAINTED"
-  | Alocked => "LOCKED"
-  | Aunlocked => "UNLOCKED"
-  | Adiv0 (_, _) => "DIV0"
-  | Aobjc_null => "OBJC_NULL"
-  | Aretval pn _ => "RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt
-  | Aobserver => "OBSERVER"
-  | Aunsubscribed_observer => "UNSUBSCRIBED_OBSERVER";
-
-
-/** dump an attribute */
-let d_attribute (a: t) => L.add_print_action (L.PTattribute, Obj.repr a);

infer/src/IR/PredSymb.rei

@@ -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: Predicate Symbols */
-module L = Logging;
-
-module F = Format;
-
-
-/** {2 Programs and Types} */
-type func_attribute =
-  | FA_sentinel int int
-[@@deriving compare];
-
-
-/** Return the value of the FA_sentinel attribute in [attr_list] if it is found */
-let get_sentinel_func_attribute_value: list func_attribute => option (int, int);
-
-
-/** Visibility modifiers. */
-type access =
-  | Default
-  | Public
-  | Private
-  | Protected
-[@@deriving compare];
-
-let equal_access: access => access => bool;
-
-type mem_kind =
-  | Mmalloc /** memory allocated with malloc */
-  | Mnew /** memory allocated with new */
-  | Mnew_array /** memory allocated with new[] */
-  | Mobjc /** memory allocated with objective-c alloc */
-[@@deriving compare];
-
-
-/** resource that can be allocated */
-type resource =
-  | Rmemory mem_kind
-  | Rfile
-  | Rignore
-  | Rlock
-[@@deriving compare];
-
-
-/** kind of resource action */
-type res_act_kind =
-  | Racquire
-  | Rrelease
-[@@deriving compare];
-
-let equal_res_act_kind: res_act_kind => res_act_kind => bool;
-
-
-/** kind of dangling pointers */
-type dangling_kind =
-  /** pointer is dangling because it is uninitialized */
-  | DAuninit
-  /** pointer is dangling because it is the address of a stack variable which went out of scope */
-  | DAaddr_stack_var
-  /** pointer is -1 */
-  | DAminusone;
-
-
-/** position in a path: proc name, node id */
-type path_pos = (Typ.Procname.t, int) [@@deriving compare];
-
-let equal_path_pos: path_pos => path_pos => bool;
-
-type taint_kind =
-  | Tk_unverified_SSL_socket
-  | Tk_shared_preferences_data
-  | Tk_privacy_annotation
-  | Tk_integrity_annotation
-  | Tk_unknown;
-
-type taint_info = {taint_source: Typ.Procname.t, taint_kind};
-
-
-/** acquire/release action on a resource */
-type res_action = {
-  ra_kind: res_act_kind, /** kind of action */
-  ra_res: resource, /** kind of resource */
-  ra_pname: Typ.Procname.t, /** name of the procedure used to acquire/release the resource */
-  ra_loc: Location.t, /** location of the acquire/release */
-  ra_vpath: DecompiledExp.vpath /** vpath of the resource value */
-};
-
-
-/** Attributes are nary function symbols that are applied to expression arguments in Apred and
-    Anpred atomic formulas.  Many operations don't make much sense for nullary predicates, and are
-    generally treated as no-ops.  The first argument is treated specially, as the "anchor" of the
-    predicate application.  For example, adding or removing an attribute uses the anchor to identify
-    the atom to operate on.  Also, abstraction and normalization operations treat the anchor
-    specially and maintain more information on it than other arguments.  Therefore when attaching an
-    attribute to an expression, that expression should be the first argument, optionally followed by
-    additional related expressions. */
-type t =
-  | Aresource res_action /** resource acquire/release */
-  | Aautorelease
-  | Adangling dangling_kind /** dangling pointer */
-  /** undefined value obtained by calling the given procedure, plus its return value annots */
-  | Aundef Typ.Procname.t Annot.Item.t Location.t path_pos
-  | Ataint taint_info
-  | Auntaint taint_info
-  | Alocked
-  | Aunlocked
-  /** value appeared in second argument of division at given path position */
-  | Adiv0 path_pos
-  /** attributed exp is null due to a call to a method with given path as null receiver */
-  | Aobjc_null
-  /** value was returned from a call to the given procedure, plus the annots of the return value */
-  | Aretval Typ.Procname.t Annot.Item.t
-  /** denotes an object registered as an observers to a notification center */
-  | Aobserver
-  /** denotes an object unsubscribed from observers of a notification center */
-  | Aunsubscribed_observer
-[@@deriving compare];
-
-let equal: t => t => bool;
-
-
-/** name of the allocation function for the given memory kind */
-let mem_alloc_pname: mem_kind => Typ.Procname.t;
-
-
-/** name of the deallocation function for the given memory kind */
-let mem_dealloc_pname: mem_kind => Typ.Procname.t;
-
-
-/** Categories of attributes */
-type category =
-  | ACresource
-  | ACautorelease
-  | ACtaint
-  | AClock
-  | ACdiv0
-  | ACobjc_null
-  | ACundef
-  | ACretval
-  | ACobserver
-[@@deriving compare];
-
-let equal_category: category => category => bool;
-
-
-/**  Return the category to which the attribute belongs. */
-let to_category: t => category;
-
-let is_undef: t => bool;
-
-
-/** convert the attribute to a string */
-let to_string: Pp.env => t => string;
-
-
-/** Dump an attribute. */
-let d_attribute: t => unit;

infer/src/IR/ProcAttributes.ml

@@ -0,0 +1,98 @@
+(*
+ * 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.
+ *)
+
+(** Attributes of a procedure. *)
+open! IStd
+module Hashtbl = Caml.Hashtbl
+module L = Logging
+module F = Format
+
+(** flags for a procedure *)
+type proc_flags = (string, string) Hashtbl.t
+
+let compare_proc_flags x y =
+  let bindings x = Hashtbl.fold (fun k d l -> (k, d) :: l) x [] in
+  [%compare : (string * string) list] (bindings x) (bindings y)
+
+let proc_flags_empty () : proc_flags = Hashtbl.create 1
+
+let proc_flag_skip = "skip"
+
+let proc_flag_ignore_return = "ignore_return"
+
+let proc_flags_add proc_flags key value = Hashtbl.replace proc_flags key value
+
+let proc_flags_find proc_flags key = Hashtbl.find proc_flags key
+
+(** Type for ObjC accessors *)
+type objc_accessor_type =
+  | Objc_getter of Typ.Fieldname.t
+  | Objc_setter of Typ.Fieldname.t
+  [@@deriving compare]
+
+type t =
+  { access: PredSymb.access  (** visibility access *)
+  ; captured: (Mangled.t * Typ.t) list  (** name and type of variables captured in blocks *)
+  ; mutable changed: bool  (** true if proc has changed since last analysis *)
+  ; mutable did_preanalysis: bool  (** true if we performed preanalysis on the CFG for this proc *)
+  ; err_log: Errlog.t  (** Error log for the procedure *)
+  ; exceptions: string list  (** exceptions thrown by the procedure *)
+  ; formals: (Mangled.t * Typ.t) list  (** name and type of formal parameters *)
+  ; const_formals: int list  (** list of indices of formals that are const-qualified *)
+  ; func_attributes: PredSymb.func_attribute list
+  ; is_abstract: bool  (** the procedure is abstract *)
+  ; is_bridge_method: bool  (** the procedure is a bridge method *)
+  ; is_defined: bool  (** true if the procedure is defined, and not just declared *)
+  ; is_objc_instance_method: bool  (** the procedure is an objective-C instance method *)
+  ; is_cpp_instance_method: bool  (** the procedure is an C++ instance method *)
+  ; is_cpp_noexcept_method: bool  (** the procedure is an C++ method annotated with "noexcept" *)
+  ; is_java_synchronized_method: bool  (** the procedure is a Java synchronized method *)
+  ; is_model: bool  (** the procedure is a model *)
+  ; is_synthetic_method: bool  (** the procedure is a synthetic method *)
+  ; language: Config.language  (** language of the procedure *)
+  ; loc: Location.t  (** location of this procedure in the source code *)
+  ; translation_unit: SourceFile.t option  (** translation unit to which the procedure belongs *)
+  ; mutable locals: (Mangled.t * Typ.t) list  (** name and type of local variables *)
+  ; method_annotation: Annot.Method.t  (** annotations for java methods *)
+  ; objc_accessor: objc_accessor_type option  (** type of ObjC accessor, if any *)
+  ; proc_flags: proc_flags  (** flags of the procedure *)
+  ; proc_name: Typ.Procname.t  (** name of the procedure *)
+  ; ret_type: Typ.t  (** return type *)
+  ; source_file_captured: SourceFile.t  (** source file where the procedure was captured *) }
+  [@@deriving compare]
+
+let default proc_name language =
+  { access= PredSymb.Default
+  ; captured= []
+  ; changed= true
+  ; did_preanalysis= false
+  ; err_log= Errlog.empty ()
+  ; exceptions= []
+  ; formals= []
+  ; const_formals= []
+  ; func_attributes= []
+  ; is_abstract= false
+  ; is_bridge_method= false
+  ; is_cpp_instance_method= false
+  ; is_cpp_noexcept_method= false
+  ; is_java_synchronized_method= false
+  ; is_defined= false
+  ; is_objc_instance_method= false
+  ; is_model= false
+  ; is_synthetic_method= false
+  ; language
+  ; loc= Location.dummy
+  ; translation_unit= None
+  ; locals= []
+  ; method_annotation= Annot.Method.empty
+  ; objc_accessor= None
+  ; proc_flags= proc_flags_empty ()
+  ; proc_name
+  ; ret_type= Typ.mk Typ.Tvoid
+  ; source_file_captured= SourceFile.invalid __FILE__ }

infer/src/IR/ProcAttributes.mli

@@ -0,0 +1,78 @@
+(*
+ * 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
+
+(** Attributes of a procedure. *)
+
+(** flags for a procedure *)
+
+type proc_flags = (string, string) Caml.Hashtbl.t [@@deriving compare]
+
+(** keys for proc_flags *)
+
+val proc_flag_skip : string
+
+(** key to specify that a function should be treated as a skip function *)
+
+val proc_flag_ignore_return : string
+
+(** key to specify that it is OK to ignore the return value *)
+
+(** empty proc flags *)
+
+val proc_flags_empty : unit -> proc_flags
+
+(** add a key value pair to a proc flags *)
+
+val proc_flags_add : proc_flags -> string -> string -> unit
+
+(** find a value for a key in the proc flags *)
+
+val proc_flags_find : proc_flags -> string -> string
+
+type objc_accessor_type =
+  | Objc_getter of Typ.Fieldname.t
+  | Objc_setter of Typ.Fieldname.t
+  [@@deriving compare]
+
+type t =
+  { access: PredSymb.access  (** visibility access *)
+  ; captured: (Mangled.t * Typ.t) list  (** name and type of variables captured in blocks *)
+  ; mutable changed: bool  (** true if proc has changed since last analysis *)
+  ; mutable did_preanalysis: bool  (** true if we performed preanalysis on the CFG for this proc *)
+  ; err_log: Errlog.t  (** Error log for the procedure *)
+  ; exceptions: string list  (** exceptions thrown by the procedure *)
+  ; formals: (Mangled.t * Typ.t) list  (** name and type of formal parameters *)
+  ; const_formals: int list  (** list of indices of formals that are const-qualified *)
+  ; func_attributes: PredSymb.func_attribute list
+  ; is_abstract: bool  (** the procedure is abstract *)
+  ; is_bridge_method: bool  (** the procedure is a bridge method *)
+  ; is_defined: bool  (** true if the procedure is defined, and not just declared *)
+  ; is_objc_instance_method: bool  (** the procedure is an objective-C instance method *)
+  ; is_cpp_instance_method: bool  (** the procedure is an C++ instance method *)
+  ; is_cpp_noexcept_method: bool  (** the procedure is an C++ method annotated with "noexcept" *)
+  ; is_java_synchronized_method: bool  (** the procedure is a Java synchronized method *)
+  ; is_model: bool  (** the procedure is a model *)
+  ; is_synthetic_method: bool  (** the procedure is a synthetic method *)
+  ; language: Config.language  (** language of the procedure *)
+  ; loc: Location.t  (** location of this procedure in the source code *)
+  ; translation_unit: SourceFile.t option  (** translation unit to which the procedure belongs *)
+  ; mutable locals: (Mangled.t * Typ.t) list  (** name and type of local variables *)
+  ; method_annotation: Annot.Method.t  (** annotations for java methods *)
+  ; objc_accessor: objc_accessor_type option  (** type of ObjC accessor, if any *)
+  ; proc_flags: proc_flags  (** flags of the procedure *)
+  ; proc_name: Typ.Procname.t  (** name of the procedure *)
+  ; ret_type: Typ.t  (** return type *)
+  ; source_file_captured: SourceFile.t  (** source file where the procedure was captured *) }
+  [@@deriving compare]
+
+(** Create a proc_attributes with default values. *)
+
+val default : Typ.Procname.t -> Config.language -> t

infer/src/IR/ProcAttributes.re

@@ -1,106 +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;
-
-module Hashtbl = Caml.Hashtbl;
-
-
-/** Attributes of a procedure. */
-module L = Logging;
-
-module F = Format;
-
-
-/** flags for a procedure */
-type proc_flags = Hashtbl.t string string;
-
-let compare_proc_flags x y => {
-  let bindings x => Hashtbl.fold (fun k d l => [(k, d), ...l]) x [];
-  [%compare : list (string, string)] (bindings x) (bindings y)
-};
-
-let proc_flags_empty () :proc_flags => Hashtbl.create 1;
-
-let proc_flag_skip = "skip";
-
-let proc_flag_ignore_return = "ignore_return";
-
-let proc_flags_add proc_flags key value => Hashtbl.replace proc_flags key value;
-
-let proc_flags_find proc_flags key => Hashtbl.find proc_flags key;
-
-
-/** Type for ObjC accessors */
-type objc_accessor_type =
-  | Objc_getter Typ.Fieldname.t
-  | Objc_setter Typ.Fieldname.t
-[@@deriving compare];
-
-type t = {
-  access: PredSymb.access, /** visibility access */
-  captured: list (Mangled.t, Typ.t), /** name and type of variables captured in blocks */
-  mutable changed: bool, /** true if proc has changed since last analysis */
-  mutable did_preanalysis: bool, /** true if we performed preanalysis on the CFG for this proc */
-  err_log: Errlog.t, /** Error log for the procedure */
-  exceptions: list string, /** exceptions thrown by the procedure */
-  formals: list (Mangled.t, Typ.t), /** name and type of formal parameters */
-  const_formals: list int, /** list of indices of formals that are const-qualified */
-  func_attributes: list PredSymb.func_attribute,
-  is_abstract: bool, /** the procedure is abstract */
-  is_bridge_method: bool, /** the procedure is a bridge method */
-  is_defined: bool, /** true if the procedure is defined, and not just declared */
-  is_objc_instance_method: bool, /** the procedure is an objective-C instance method */
-  is_cpp_instance_method: bool, /** the procedure is an C++ instance method */
-  is_cpp_noexcept_method: bool, /** the procedure is an C++ method annotated with "noexcept" */
-  is_java_synchronized_method: bool, /** the procedure is a Java synchronized method */
-  is_model: bool, /** the procedure is a model */
-  is_synthetic_method: bool, /** the procedure is a synthetic method */
-  language: Config.language, /** language of the procedure */
-  loc: Location.t, /** location of this procedure in the source code */
-  translation_unit: option SourceFile.t, /** translation unit to which the procedure belongs */
-  mutable locals: list (Mangled.t, Typ.t), /** name and type of local variables */
-  method_annotation: Annot.Method.t, /** annotations for java methods */
-  objc_accessor: option objc_accessor_type, /** type of ObjC accessor, if any */
-  proc_flags, /** flags of the procedure */
-  proc_name: Typ.Procname.t, /** name of the procedure */
-  ret_type: Typ.t, /** return type */
-  source_file_captured: SourceFile.t /** source file where the procedure was captured */
-}
-[@@deriving compare];
-
-let default proc_name language => {
-  access: PredSymb.Default,
-  captured: [],
-  changed: true,
-  did_preanalysis: false,
-  err_log: Errlog.empty (),
-  exceptions: [],
-  formals: [],
-  const_formals: [],
-  func_attributes: [],
-  is_abstract: false,
-  is_bridge_method: false,
-  is_cpp_instance_method: false,
-  is_cpp_noexcept_method: false,
-  is_java_synchronized_method: false,
-  is_defined: false,
-  is_objc_instance_method: false,
-  is_model: false,
-  is_synthetic_method: false,
-  language,
-  loc: Location.dummy,
-  translation_unit: None,
-  locals: [],
-  method_annotation: Annot.Method.empty,
-  objc_accessor: None,
-  proc_flags: proc_flags_empty (),
-  proc_name,
-  ret_type: Typ.mk Typ.Tvoid,
-  source_file_captured: SourceFile.invalid __FILE__
-};

infer/src/IR/ProcAttributes.rei

@@ -1,74 +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;
-
-
-/** Attributes of a procedure. */
-
-/** flags for a procedure */
-type proc_flags = Caml.Hashtbl.t string string [@@deriving compare];
-
-
-/** keys for proc_flags */
-let proc_flag_skip: string; /** key to specify that a function should be treated as a skip function */
-
-let proc_flag_ignore_return: string; /** key to specify that it is OK to ignore the return value */
-
-
-/** empty proc flags */
-let proc_flags_empty: unit => proc_flags;
-
-
-/** add a key value pair to a proc flags */
-let proc_flags_add: proc_flags => string => string => unit;
-
-
-/** find a value for a key in the proc flags */
-let proc_flags_find: proc_flags => string => string;
-
-type objc_accessor_type =
-  | Objc_getter Typ.Fieldname.t
-  | Objc_setter Typ.Fieldname.t
-[@@deriving compare];
-
-type t = {
-  access: PredSymb.access, /** visibility access */
-  captured: list (Mangled.t, Typ.t), /** name and type of variables captured in blocks */
-  mutable changed: bool, /** true if proc has changed since last analysis */
-  mutable did_preanalysis: bool, /** true if we performed preanalysis on the CFG for this proc */
-  err_log: Errlog.t, /** Error log for the procedure */
-  exceptions: list string, /** exceptions thrown by the procedure */
-  formals: list (Mangled.t, Typ.t), /** name and type of formal parameters */
-  const_formals: list int, /** list of indices of formals that are const-qualified */
-  func_attributes: list PredSymb.func_attribute,
-  is_abstract: bool, /** the procedure is abstract */
-  is_bridge_method: bool, /** the procedure is a bridge method */
-  is_defined: bool, /** true if the procedure is defined, and not just declared */
-  is_objc_instance_method: bool, /** the procedure is an objective-C instance method */
-  is_cpp_instance_method: bool, /** the procedure is an C++ instance method */
-  is_cpp_noexcept_method: bool, /** the procedure is an C++ method annotated with "noexcept" */
-  is_java_synchronized_method: bool, /** the procedure is a Java synchronized method */
-  is_model: bool, /** the procedure is a model */
-  is_synthetic_method: bool, /** the procedure is a synthetic method */
-  language: Config.language, /** language of the procedure */
-  loc: Location.t, /** location of this procedure in the source code */
-  translation_unit: option SourceFile.t, /** translation unit to which the procedure belongs */
-  mutable locals: list (Mangled.t, Typ.t), /** name and type of local variables */
-  method_annotation: Annot.Method.t, /** annotations for java methods */
-  objc_accessor: option objc_accessor_type, /** type of ObjC accessor, if any */
-  proc_flags, /** flags of the procedure */
-  proc_name: Typ.Procname.t, /** name of the procedure */
-  ret_type: Typ.t, /** return type */
-  source_file_captured: SourceFile.t /** source file where the procedure was captured */
-}
-[@@deriving compare];
-
-
-/** Create a proc_attributes with default values. */
-let default: Typ.Procname.t => Config.language => t;

infer/src/IR/Procdesc.ml

@@ -0,0 +1,505 @@
+(*
+ * 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 L = Logging
+module F = Format
+
+(* =============== START of module Node =============== *)
+module Node = struct
+  type id = int [@@deriving compare]
+
+  let equal_id = [%compare.equal : id]
+
+  type nodekind =
+    | Start_node of Typ.Procname.t
+    | Exit_node of Typ.Procname.t
+    | Stmt_node of string
+    | Join_node
+    | Prune_node of bool * Sil.if_kind * string  (** (true/false branch, if_kind, comment) *)
+    | Skip_node of string
+    [@@deriving compare]
+
+  let equal_nodekind = [%compare.equal : nodekind]
+
+  (** a node *)
+  type t =
+    { (** unique id of the node *)
+    id: id  (** distance to the exit node *)
+    ; mutable dist_exit: int option  (** exception nodes in the cfg *)
+    ; mutable exn: t list  (** instructions for symbolic execution *)
+    ; mutable instrs: Sil.instr list  (** kind of node *)
+    ; kind: nodekind  (** location in the source code *)
+    ; loc: Location.t  (** predecessor nodes in the cfg *)
+    ; mutable preds: t list  (** name of the procedure the node belongs to *)
+    ; pname_opt: Typ.Procname.t option  (** successor nodes in the cfg *)
+    ; mutable succs: t list }
+
+  let exn_handler_kind = Stmt_node "exception handler"
+
+  let exn_sink_kind = Stmt_node "exceptions sink"
+
+  let throw_kind = Stmt_node "throw"
+
+  let dummy pname_opt =
+    { id= 0
+    ; dist_exit= None
+    ; instrs= []
+    ; kind= Skip_node "dummy"
+    ; loc= Location.dummy
+    ; pname_opt
+    ; succs= []
+    ; preds= []
+    ; exn= [] }
+
+  let compare node1 node2 = Int.compare node1.id node2.id
+
+  let hash node = Hashtbl.hash node.id
+
+  let equal = [%compare.equal : t]
+
+  (** Get the unique id of the node *)
+  let get_id node = node.id
+
+  let get_succs node = node.succs
+
+  type node = t
+
+  module NodeSet = Caml.Set.Make (struct
+    type t = node
+
+    let compare = compare
+  end)
+
+  module IdMap = Caml.Map.Make (struct
+    type t = id
+
+    let compare = compare_id
+  end)
+
+  let get_sliced_succs node f =
+    let visited = ref NodeSet.empty in
+    let rec slice_nodes nodes : NodeSet.t =
+      let do_node acc n =
+        visited := NodeSet.add n !visited ;
+        if f n then NodeSet.singleton n
+        else
+          NodeSet.union acc
+            (slice_nodes (List.filter ~f:(fun s -> not (NodeSet.mem s !visited)) n.succs))
+      in
+      List.fold ~f:do_node ~init:NodeSet.empty nodes
+    in
+    NodeSet.elements (slice_nodes node.succs)
+
+  let get_sliced_preds node f =
+    let visited = ref NodeSet.empty in
+    let rec slice_nodes nodes : NodeSet.t =
+      let do_node acc n =
+        visited := NodeSet.add n !visited ;
+        if f n then NodeSet.singleton n
+        else
+          NodeSet.union acc
+            (slice_nodes (List.filter ~f:(fun s -> not (NodeSet.mem s !visited)) n.preds))
+      in
+      List.fold ~f:do_node ~init:NodeSet.empty nodes
+    in
+    NodeSet.elements (slice_nodes node.preds)
+
+  let get_exn node = node.exn
+
+  (** Get the name of the procedure the node belongs to *)
+  let get_proc_name node =
+    match node.pname_opt with
+    | None
+     -> L.internal_error "get_proc_name: at node %d@\n" node.id ;
+        assert false
+    | Some pname
+     -> pname
+
+  (** Get the predecessors of the node *)
+  let get_preds node = node.preds
+
+  (** Generates a list of nodes starting at a given node
+      and recursively adding the results of the generator *)
+  let get_generated_slope start_node generator =
+    let visited = ref NodeSet.empty in
+    let rec nodes n =
+      visited := NodeSet.add n !visited ;
+      let succs = List.filter ~f:(fun n -> not (NodeSet.mem n !visited)) (generator n) in
+      match succs with [hd] -> n :: nodes hd | _ -> [n]
+    in
+    nodes start_node
+
+  (** Get the node kind *)
+  let get_kind node = node.kind
+
+  (** Get the instructions to be executed *)
+  let get_instrs node = node.instrs
+
+  (** Get the list of callee procnames from the node *)
+  let get_callees node =
+    let collect callees instr =
+      match instr with
+      | Sil.Call (_, exp, _, _, _) -> (
+        match exp with Exp.Const Const.Cfun procname -> procname :: callees | _ -> callees )
+      | _
+       -> callees
+    in
+    List.fold ~f:collect ~init:[] (get_instrs node)
+
+  (** Get the location of the node *)
+  let get_loc n = n.loc
+
+  (** Get the source location of the last instruction in the node *)
+  let get_last_loc n =
+    match List.rev (get_instrs n) with instr :: _ -> Sil.instr_get_loc instr | [] -> n.loc
+
+  let pp_id f id = F.fprintf f "%d" id
+
+  let pp f node = pp_id f (get_id node)
+
+  let get_distance_to_exit node = node.dist_exit
+
+  (** Append the instructions to the list of instructions to execute *)
+  let append_instrs node instrs = node.instrs <- node.instrs @ instrs
+
+  (** Add the instructions at the beginning of the list of instructions to execute *)
+  let prepend_instrs node instrs = node.instrs <- instrs @ node.instrs
+
+  (** Replace the instructions to be executed. *)
+  let replace_instrs node instrs = node.instrs <- instrs
+
+  (** Add declarations for local variables and return variable to the node *)
+  let add_locals_ret_declaration node (proc_attributes: ProcAttributes.t) locals =
+    let loc = get_loc node in
+    let pname = proc_attributes.proc_name in
+    let ret_var =
+      let ret_type = proc_attributes.ret_type in
+      (Pvar.get_ret_pvar pname, ret_type)
+    in
+    let construct_decl (x, typ) = (Pvar.mk x pname, typ) in
+    let ptl = ret_var :: List.map ~f:construct_decl locals in
+    let instr = Sil.Declare_locals (ptl, loc) in
+    prepend_instrs node [instr]
+
+  (** Print extended instructions for the node,
+      highlighting the given subinstruction if present *)
+  let pp_instrs pe0 ~sub_instrs instro fmt node =
+    let pe =
+      match instro with None -> pe0 | Some instr -> Pp.extend_colormap pe0 (Obj.repr instr) Red
+    in
+    let instrs = get_instrs node in
+    let pp_loc fmt () = F.fprintf fmt " %a " Location.pp (get_loc node) in
+    let print_sub_instrs () = F.fprintf fmt "%a" (Sil.pp_instr_list pe) instrs in
+    match get_kind node with
+    | Stmt_node s
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "statements (%s) %a" s pp_loc ()
+    | Prune_node (_, _, descr)
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "assume %s %a" descr pp_loc ()
+    | Exit_node _
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "exit %a" pp_loc ()
+    | Skip_node s
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "skip (%s) %a" s pp_loc ()
+    | Start_node _
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "start %a" pp_loc ()
+    | Join_node
+     -> if sub_instrs then print_sub_instrs () else F.fprintf fmt "join %a" pp_loc ()
+
+  (** Dump extended instructions for the node *)
+  let d_instrs ~(sub_instrs: bool) (curr_instr: Sil.instr option) (node: t) =
+    L.add_print_action (L.PTnode_instrs, Obj.repr (sub_instrs, curr_instr, node))
+
+  (** Return a description of the cfg node *)
+  let get_description pe node =
+    let str =
+      match get_kind node with
+      | Stmt_node _
+       -> "Instructions"
+      | Prune_node (_, _, descr)
+       -> "Conditional" ^ " " ^ descr
+      | Exit_node _
+       -> "Exit"
+      | Skip_node _
+       -> "Skip"
+      | Start_node _
+       -> "Start"
+      | Join_node
+       -> "Join"
+    in
+    let pp fmt = F.fprintf fmt "%s@\n%a@?" str (pp_instrs pe None ~sub_instrs:true) node in
+    F.asprintf "%t" pp
+end
+
+(* =============== END of module Node =============== *)
+
+(** Map over nodes *)
+module NodeMap = Caml.Map.Make (Node)  (** Hash table with nodes as keys. *)
+(** Hash table with nodes as keys. *)
+module NodeHash = Hashtbl.Make (Node)  (** Set of nodes. *)
+(** Set of nodes. *)
+module NodeSet = Node.NodeSet  (** Map with node id keys. *)
+(** Map with node id keys. *)
+module IdMap = Node.IdMap
+
+(** procedure description *)
+type t =
+  { attributes: ProcAttributes.t  (** attributes of the procedure *)
+  ; mutable nodes: Node.t list  (** list of nodes of this procedure *)
+  ; mutable nodes_num: int  (** number of nodes *)
+  ; mutable start_node: Node.t  (** start node of this procedure *)
+  ; mutable exit_node: Node.t  (** exit node of ths procedure *)
+  ; mutable loop_heads: (** loop head nodes of this procedure *) NodeSet.t option }
+  [@@deriving compare]
+
+(** Only call from Cfg *)
+let from_proc_attributes ~called_from_cfg attributes =
+  if not called_from_cfg then assert false ;
+  let pname_opt = Some attributes.ProcAttributes.proc_name in
+  let start_node = Node.dummy pname_opt in
+  let exit_node = Node.dummy pname_opt in
+  {attributes; nodes= []; nodes_num= 0; start_node; exit_node; loop_heads= None}
+
+(** Compute the distance of each node to the exit node, if not computed already *)
+let compute_distance_to_exit_node pdesc =
+  let exit_node = pdesc.exit_node in
+  let rec mark_distance dist nodes =
+    let next_nodes = ref [] in
+    let do_node (node: Node.t) =
+      match node.dist_exit with
+      | Some _
+       -> ()
+      | None
+       -> node.dist_exit <- Some dist ;
+          next_nodes := node.preds @ !next_nodes
+    in
+    List.iter ~f:do_node nodes ;
+    if !next_nodes <> [] then mark_distance (dist + 1) !next_nodes
+  in
+  mark_distance 0 [exit_node]
+
+(** check or indicate if we have performed preanalysis on the CFG *)
+let did_preanalysis pdesc = pdesc.attributes.did_preanalysis
+
+let signal_did_preanalysis pdesc = (pdesc.attributes).did_preanalysis <- true
+
+let get_attributes pdesc = pdesc.attributes
+
+let get_err_log pdesc = pdesc.attributes.err_log
+
+let get_exit_node pdesc = pdesc.exit_node
+
+(** Get flags for the proc desc *)
+let get_flags pdesc = pdesc.attributes.proc_flags
+
+(** Return name and type of formal parameters *)
+let get_formals pdesc = pdesc.attributes.formals
+
+let get_loc pdesc = pdesc.attributes.loc
+
+(** Return name and type of local variables *)
+let get_locals pdesc = pdesc.attributes.locals
+
+(** Return name and type of captured variables *)
+let get_captured pdesc = pdesc.attributes.captured
+
+(** Return the visibility attribute *)
+let get_access pdesc = pdesc.attributes.access
+
+let get_nodes pdesc = pdesc.nodes
+
+let get_proc_name pdesc = pdesc.attributes.proc_name
+
+(** Return the return type of the procedure *)
+let get_ret_type pdesc = pdesc.attributes.ret_type
+
+let get_ret_var pdesc = Pvar.mk Ident.name_return (get_proc_name pdesc)
+
+let get_start_node pdesc = pdesc.start_node
+
+(** List of nodes in the procedure sliced by a predicate up to the first branching *)
+let get_sliced_slope pdesc f =
+  Node.get_generated_slope (get_start_node pdesc) (fun n -> Node.get_sliced_succs n f)
+
+(** List of nodes in the procedure up to the first branching *)
+let get_slope pdesc = Node.get_generated_slope (get_start_node pdesc) Node.get_succs
+
+(** Return [true] iff the procedure is defined, and not just declared *)
+let is_defined pdesc = pdesc.attributes.is_defined
+
+let is_body_empty pdesc = List.is_empty (Node.get_succs (get_start_node pdesc))
+
+let is_java_synchronized pdesc = pdesc.attributes.is_java_synchronized_method
+
+let iter_nodes f pdesc = List.iter ~f (List.rev (get_nodes pdesc))
+
+let fold_calls f acc pdesc =
+  let do_node a node =
+    List.fold
+      ~f:(fun b callee_pname -> f b (callee_pname, Node.get_loc node))
+      ~init:a (Node.get_callees node)
+  in
+  List.fold ~f:do_node ~init:acc (get_nodes pdesc)
+
+(** iterate over the calls from the procedure: (callee,location) pairs *)
+let iter_calls f pdesc = fold_calls (fun _ call -> f call) () pdesc
+
+let iter_instrs f pdesc =
+  let do_node node = List.iter ~f:(fun i -> f node i) (Node.get_instrs node) in
+  iter_nodes do_node pdesc
+
+let fold_nodes f acc pdesc = List.fold ~f ~init:acc (List.rev (get_nodes pdesc))
+
+let fold_instrs f acc pdesc =
+  let fold_node acc node =
+    List.fold ~f:(fun acc instr -> f acc node instr) ~init:acc (Node.get_instrs node)
+  in
+  fold_nodes fold_node acc pdesc
+
+let iter_slope f pdesc =
+  let visited = ref NodeSet.empty in
+  let rec do_node node =
+    visited := NodeSet.add node !visited ;
+    f node ;
+    match Node.get_succs node with
+    | [n]
+     -> if not (NodeSet.mem n !visited) then do_node n
+    | _
+     -> ()
+  in
+  do_node (get_start_node pdesc)
+
+let iter_slope_calls f pdesc =
+  let do_node node = List.iter ~f:(fun callee_pname -> f callee_pname) (Node.get_callees node) in
+  iter_slope do_node pdesc
+
+(** iterate between two nodes or until we reach a branching structure *)
+let iter_slope_range f src_node dst_node =
+  let visited = ref NodeSet.empty in
+  let rec do_node node =
+    visited := NodeSet.add node !visited ;
+    f node ;
+    match Node.get_succs node with
+    | [n]
+     -> if not (NodeSet.mem n !visited) && not (Node.equal node dst_node) then do_node n
+    | _
+     -> ()
+  in
+  do_node src_node
+
+(** Set the exit node of the proc desc *)
+let set_exit_node pdesc node = pdesc.exit_node <- node
+
+(** Set a flag for the proc desc *)
+let set_flag pdesc key value = ProcAttributes.proc_flags_add pdesc.attributes.proc_flags key value
+
+(** Set the start node of the proc desc *)
+let set_start_node pdesc node = pdesc.start_node <- node
+
+(** Append the locals to the list of local variables *)
+let append_locals pdesc new_locals =
+  (pdesc.attributes).locals <- pdesc.attributes.locals @ new_locals
+
+(** Set the successor nodes and exception nodes, and build predecessor links *)
+let set_succs_exn_base (node: Node.t) succs exn =
+  node.succs <- succs ;
+  node.exn <- exn ;
+  List.iter ~f:(fun (n: Node.t) -> n.preds <- node :: n.preds) succs
+
+(** Create a new cfg node *)
+let create_node pdesc loc kind instrs =
+  pdesc.nodes_num <- pdesc.nodes_num + 1 ;
+  let node_id = pdesc.nodes_num in
+  let node =
+    { Node.id= node_id
+    ; dist_exit= None
+    ; instrs
+    ; kind
+    ; loc
+    ; preds= []
+    ; pname_opt= Some pdesc.attributes.proc_name
+    ; succs= []
+    ; exn= [] }
+  in
+  pdesc.nodes <- node :: pdesc.nodes ;
+  node
+
+(** Set the successor and exception nodes.
+    If this is a join node right before the exit node, add an extra node in the middle,
+    otherwise nullify and abstract instructions cannot be added after a conditional. *)
+let node_set_succs_exn pdesc (node: Node.t) succs exn =
+  match (node.kind, succs) with
+  | Join_node, [({Node.kind= Exit_node _} as exit_node)]
+   -> let kind = Node.Stmt_node "between_join_and_exit" in
+      let node' = create_node pdesc node.loc kind node.instrs in
+      set_succs_exn_base node [node'] exn ;
+      set_succs_exn_base node' [exit_node] exn
+  | _
+   -> set_succs_exn_base node succs exn
+
+(** Get loop heads for widening.
+    It collects all target nodes of back-edges in a depth-first
+    traversal.
+    *)
+let get_loop_heads pdesc =
+  let rec set_loop_head_rec visited heads wl =
+    match wl with
+    | []
+     -> heads
+    | (n, ancester) :: wl'
+     -> if NodeSet.mem n visited then
+          if NodeSet.mem n ancester then set_loop_head_rec visited (NodeSet.add n heads) wl'
+          else set_loop_head_rec visited heads wl'
+        else
+          let ancester = NodeSet.add n ancester in
+          let succs = List.append (Node.get_succs n) (Node.get_exn n) in
+          let works = List.map ~f:(fun m -> (m, ancester)) succs in
+          set_loop_head_rec (NodeSet.add n visited) heads (List.append works wl')
+  in
+  let start_wl = [(get_start_node pdesc, NodeSet.empty)] in
+  let lh = set_loop_head_rec NodeSet.empty NodeSet.empty start_wl in
+  pdesc.loop_heads <- Some lh ;
+  lh
+
+let is_loop_head pdesc (node: Node.t) =
+  let lh = match pdesc.loop_heads with Some lh -> lh | None -> get_loop_heads pdesc in
+  NodeSet.mem node lh
+
+let pp_variable_list fmt etl =
+  if List.is_empty etl then Format.fprintf fmt "None"
+  else
+    List.iter
+      ~f:(fun (id, ty) -> Format.fprintf fmt " %a:%a" Mangled.pp id (Typ.pp_full Pp.text) ty)
+      etl
+
+let pp_objc_accessor fmt accessor =
+  match accessor with
+  | Some ProcAttributes.Objc_getter name
+   -> Format.fprintf fmt "Getter of %a, " Typ.Fieldname.pp name
+  | Some ProcAttributes.Objc_setter name
+   -> Format.fprintf fmt "Setter of %a, " Typ.Fieldname.pp name
+  | None
+   -> ()
+
+let pp_signature fmt pdesc =
+  let attributes = get_attributes pdesc in
+  let pname = get_proc_name pdesc in
+  let pname_string = Typ.Procname.to_string pname in
+  let defined_string = match is_defined pdesc with true -> "defined" | false -> "undefined" in
+  Format.fprintf fmt "%s [%s, Return type: %s, %aFormals: %a, Locals: %a" pname_string
+    defined_string
+    (Typ.to_string (get_ret_type pdesc))
+    pp_objc_accessor attributes.ProcAttributes.objc_accessor pp_variable_list (get_formals pdesc)
+    pp_variable_list (get_locals pdesc) ;
+  if not (List.is_empty (get_captured pdesc)) then
+    Format.fprintf fmt ", Captured: %a" pp_variable_list (get_captured pdesc) ;
+  let method_annotation = attributes.ProcAttributes.method_annotation in
+  if not (Annot.Method.is_empty method_annotation) then
+    Format.fprintf fmt ", Annotation: %a" (Annot.Method.pp pname_string) method_annotation ;
+  Format.fprintf fmt "]@\n"

infer/src/IR/Procdesc.mli

@@ -0,0 +1,317 @@
+(*
+ * 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
+
+(** node of the control flow graph *)
+
+module Node : sig
+  (** type of nodes *)
+
+  type t [@@deriving compare]
+
+  (** node id *)
+
+  type id = private int [@@deriving compare]
+
+  val equal_id : id -> id -> bool
+
+  (** kind of cfg node *)
+
+  type nodekind =
+    | Start_node of Typ.Procname.t
+    | Exit_node of Typ.Procname.t
+    | Stmt_node of string
+    | Join_node
+    | Prune_node of bool * Sil.if_kind * string  (** (true/false branch, if_kind, comment) *)
+    | Skip_node of string
+    [@@deriving compare]
+
+  val equal_nodekind : nodekind -> nodekind -> bool
+
+  (** kind of Stmt_node for an exception handler. *)
+
+  val exn_handler_kind : nodekind
+
+  (** kind of Stmt_node for an exceptions sink. *)
+
+  val exn_sink_kind : nodekind
+
+  (** kind of Stmt_node for a throw instruction. *)
+
+  val throw_kind : nodekind
+
+  (** Add declarations for local variables and return variable to the node *)
+
+  val add_locals_ret_declaration : t -> ProcAttributes.t -> (Mangled.t * Typ.t) list -> unit
+
+  (** Append the instructions to the list of instructions to execute *)
+
+  val append_instrs : t -> Sil.instr list -> unit
+
+  (** Dump extended instructions for the node *)
+
+  val d_instrs : sub_instrs:bool -> Sil.instr option -> t -> unit
+
+  (** Create a dummy node *)
+
+  val dummy : Typ.Procname.t option -> t
+
+  (** Check if two nodes are equal *)
+
+  val equal : t -> t -> bool
+
+  (** Get the list of callee procnames from the node *)
+
+  val get_callees : t -> Typ.Procname.t list
+
+  (** Return a description of the node *)
+
+  val get_description : Pp.env -> t -> string
+
+  (** Get the distance to the exit node, if it has been computed *)
+
+  val get_distance_to_exit : t -> int option
+
+  (** Get the exception nodes from the current node *)
+
+  val get_exn : t -> t list
+
+  (** Get a list of unique nodes until the first branch starting
+      from a node with subsequent applications of a generator function *)
+
+  val get_generated_slope : t -> (t -> t list) -> t list
+
+  (** Get the unique id of the node *)
+
+  val get_id : t -> id
+
+  (** Get the instructions to be executed *)
+
+  val get_instrs : t -> Sil.instr list
+
+  (** Get the kind of the current node *)
+
+  val get_kind : t -> nodekind
+
+  (** Get the source location of the last instruction in the node *)
+
+  val get_last_loc : t -> Location.t
+
+  (** Get the source location of the node *)
+
+  val get_loc : t -> Location.t
+
+  (** Get the predecessor nodes of the current node *)
+
+  val get_preds : t -> t list
+
+  (** Get the name of the procedure the node belongs to *)
+
+  val get_proc_name : t -> Typ.Procname.t
+
+  (** Get the predecessor nodes of a node where the given predicate evaluates to true *)
+
+  val get_sliced_preds : t -> (t -> bool) -> t list
+
+  (** Get the successor nodes of a node where the given predicate evaluates to true *)
+
+  val get_sliced_succs : t -> (t -> bool) -> t list
+
+  (** Get the successor nodes of the current node *)
+
+  val get_succs : t -> t list
+
+  (** Hash function for nodes *)
+
+  val hash : t -> int
+
+  (** Pretty print the node *)
+
+  val pp : Format.formatter -> t -> unit
+
+  (** Pretty print a node id *)
+
+  val pp_id : Format.formatter -> id -> unit
+
+  (** Print extended instructions for the node,
+      highlighting the given subinstruction if present *)
+
+  val pp_instrs : Pp.env -> sub_instrs:bool -> Sil.instr option -> Format.formatter -> t -> unit
+
+  (** Replace the instructions to be executed. *)
+
+  val replace_instrs : t -> Sil.instr list -> unit
+end
+
+(** Map with node id keys. *)
+
+module IdMap : Caml.Map.S with type key = Node.id
+
+(** Hash table with nodes as keys. *)
+
+module NodeHash : Caml.Hashtbl.S with type key = Node.t
+
+(** Map over nodes. *)
+
+module NodeMap : Caml.Map.S with type key = Node.t
+
+(** Set of nodes. *)
+
+module NodeSet : Caml.Set.S with type elt = Node.t
+
+(** procedure descriptions *)
+
+(** proc description *)
+
+type t [@@deriving compare]
+
+(** append a list of new local variables to the existing list of local variables *)
+
+val append_locals : t -> (Mangled.t * Typ.t) list -> unit
+
+(** Compute the distance of each node to the exit node, if not computed already *)
+
+val compute_distance_to_exit_node : t -> unit
+
+(** Create a new cfg node with the given location, kind, list of instructions,
+    and add it to the procdesc. *)
+
+val create_node : t -> Location.t -> Node.nodekind -> Sil.instr list -> Node.t
+
+(** true if we ran the preanalysis on the CFG associated with [t] *)
+
+val did_preanalysis : t -> bool
+
+(** fold over the calls from the procedure: (callee, location) pairs *)
+
+val fold_calls : ('a -> Typ.Procname.t * Location.t -> 'a) -> 'a -> t -> 'a
+
+(** fold over all nodes and their instructions *)
+
+val fold_instrs : ('a -> Node.t -> Sil.instr -> 'a) -> 'a -> t -> 'a
+
+(** fold over all nodes *)
+
+val fold_nodes : ('a -> Node.t -> 'a) -> 'a -> t -> 'a
+
+(** Only call from Cfg. *)
+
+val from_proc_attributes : called_from_cfg:bool -> ProcAttributes.t -> t
+
+(** Return the visibility attribute *)
+
+val get_access : t -> PredSymb.access
+
+(** Get the attributes of the procedure. *)
+
+val get_attributes : t -> ProcAttributes.t
+
+(** Return name and type of block's captured variables *)
+
+val get_captured : t -> (Mangled.t * Typ.t) list
+
+val get_err_log : t -> Errlog.t
+
+val get_exit_node : t -> Node.t
+
+(** Get flags for the proc desc *)
+
+val get_flags : t -> ProcAttributes.proc_flags
+
+(** Return name and type of formal parameters *)
+
+val get_formals : t -> (Mangled.t * Typ.t) list
+
+(** Return loc information for the procedure *)
+
+val get_loc : t -> Location.t
+
+(** Return name and type of local variables *)
+
+val get_locals : t -> (Mangled.t * Typ.t) list
+
+val get_nodes : t -> Node.t list
+
+val get_proc_name : t -> Typ.Procname.t
+
+(** Return the return type of the procedure and type string *)
+
+val get_ret_type : t -> Typ.t
+
+val get_ret_var : t -> Pvar.t
+
+(** Get the sliced procedure's nodes up until the first branching *)
+
+val get_sliced_slope : t -> (Node.t -> bool) -> Node.t list
+
+(** Get the procedure's nodes up until the first branching *)
+
+val get_slope : t -> Node.t list
+
+val get_start_node : t -> Node.t
+
+(** Return [true] iff the procedure is defined, and not just declared *)
+
+val is_defined : t -> bool
+
+(** Return [true] if the body of the procdesc is empty (no instructions) *)
+
+val is_body_empty : t -> bool
+
+(** Return [true] if the procedure signature has the Java synchronized keyword *)
+
+val is_java_synchronized : t -> bool
+
+(** iterate over the calls from the procedure: (callee, location) pairs *)
+
+val iter_calls : (Typ.Procname.t * Location.t -> unit) -> t -> unit
+
+(** iterate over all nodes and their instructions *)
+
+val iter_instrs : (Node.t -> Sil.instr -> unit) -> t -> unit
+
+(** iterate over all the nodes of a procedure *)
+
+val iter_nodes : (Node.t -> unit) -> t -> unit
+
+(** iterate over all nodes until we reach a branching structure *)
+
+val iter_slope : (Node.t -> unit) -> t -> unit
+
+(** iterate over all calls until we reach a branching structure *)
+
+val iter_slope_calls : (Typ.Procname.t -> unit) -> t -> unit
+
+(** iterate between two nodes or until we reach a branching structure *)
+
+val iter_slope_range : (Node.t -> unit) -> Node.t -> Node.t -> unit
+
+(** Set the successor nodes and exception nodes, and build predecessor links *)
+
+val node_set_succs_exn : t -> Node.t -> Node.t list -> Node.t list -> unit
+
+(** Set the exit node of the procedure *)
+
+val set_exit_node : t -> Node.t -> unit
+
+(** Set a flag for the proc desc *)
+
+val set_flag : t -> string -> string -> unit
+
+val set_start_node : t -> Node.t -> unit
+
+(** indicate that we have performed preanalysis on the CFG assoociated with [t] *)
+
+val signal_did_preanalysis : t -> unit
+
+val is_loop_head : t -> Node.t -> bool
+
+val pp_signature : Format.formatter -> t -> unit

infer/src/IR/Procdesc.re

@@ -1,605 +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 L = Logging;
-
-module F = Format;
-
-/* =============== START of module Node =============== */
-module Node = {
-  type id = int [@@deriving compare];
-  let equal_id = [%compare.equal : id];
-  type nodekind =
-    | Start_node Typ.Procname.t
-    | Exit_node Typ.Procname.t
-    | Stmt_node string
-    | Join_node
-    | Prune_node bool Sil.if_kind string /** (true/false branch, if_kind, comment) */
-    | Skip_node string
-  [@@deriving compare];
-  let equal_nodekind = [%compare.equal : nodekind];
-
-  /** a node */
-  type t = {
-    /** unique id of the node */
-    id,
-    /** distance to the exit node */
-    mutable dist_exit: option int,
-    /** exception nodes in the cfg */
-    mutable exn: list t,
-    /** instructions for symbolic execution */
-    mutable instrs: list Sil.instr,
-    /** kind of node */
-    kind: nodekind,
-    /** location in the source code */
-    loc: Location.t,
-    /** predecessor nodes in the cfg */
-    mutable preds: list t,
-    /** name of the procedure the node belongs to */
-    pname_opt: option Typ.Procname.t,
-    /** successor nodes in the cfg */
-    mutable succs: list t
-  };
-  let exn_handler_kind = Stmt_node "exception handler";
-  let exn_sink_kind = Stmt_node "exceptions sink";
-  let throw_kind = Stmt_node "throw";
-  let dummy pname_opt => {
-    id: 0,
-    dist_exit: None,
-    instrs: [],
-    kind: Skip_node "dummy",
-    loc: Location.dummy,
-    pname_opt,
-    succs: [],
-    preds: [],
-    exn: []
-  };
-  let compare node1 node2 => Int.compare node1.id node2.id;
-  let hash node => Hashtbl.hash node.id;
-  let equal = [%compare.equal : t];
-
-  /** Get the unique id of the node */
-  let get_id node => node.id;
-  let get_succs node => node.succs;
-  type node = t;
-  module NodeSet =
-    Caml.Set.Make {
-      type t = node;
-      let compare = compare;
-    };
-  module IdMap =
-    Caml.Map.Make {
-      type t = id;
-      let compare = compare_id;
-    };
-  let get_sliced_succs node f => {
-    let visited = ref NodeSet.empty;
-    let rec slice_nodes nodes :NodeSet.t => {
-      let do_node acc n => {
-        visited := NodeSet.add n !visited;
-        if (f n) {
-          NodeSet.singleton n
-        } else {
-          NodeSet.union
-            acc (slice_nodes (List.filter f::(fun s => not (NodeSet.mem s !visited)) n.succs))
-        }
-      };
-      List.fold f::do_node init::NodeSet.empty nodes
-    };
-    NodeSet.elements (slice_nodes node.succs)
-  };
-  let get_sliced_preds node f => {
-    let visited = ref NodeSet.empty;
-    let rec slice_nodes nodes :NodeSet.t => {
-      let do_node acc n => {
-        visited := NodeSet.add n !visited;
-        if (f n) {
-          NodeSet.singleton n
-        } else {
-          NodeSet.union
-            acc (slice_nodes (List.filter f::(fun s => not (NodeSet.mem s !visited)) n.preds))
-        }
-      };
-      List.fold f::do_node init::NodeSet.empty nodes
-    };
-    NodeSet.elements (slice_nodes node.preds)
-  };
-  let get_exn node => node.exn;
-
-  /** Get the name of the procedure the node belongs to */
-  let get_proc_name node =>
-    switch node.pname_opt {
-    | None =>
-      L.internal_error "get_proc_name: at node %d@\n" node.id;
-      assert false
-    | Some pname => pname
-    };
-
-  /** Get the predecessors of the node */
-  let get_preds node => node.preds;
-
-  /** Generates a list of nodes starting at a given node
-      and recursively adding the results of the generator */
-  let get_generated_slope start_node generator => {
-    let visited = ref NodeSet.empty;
-    let rec nodes n => {
-      visited := NodeSet.add n !visited;
-      let succs = List.filter f::(fun n => not (NodeSet.mem n !visited)) (generator n);
-      switch succs {
-      | [hd] => [n, ...nodes hd]
-      | _ => [n]
-      }
-    };
-    nodes start_node
-  };
-
-  /** Get the node kind */
-  let get_kind node => node.kind;
-
-  /** Get the instructions to be executed */
-  let get_instrs node => node.instrs;
-
-  /** Get the list of callee procnames from the node */
-  let get_callees node => {
-    let collect callees instr =>
-      switch instr {
-      | Sil.Call _ exp _ _ _ =>
-        switch exp {
-        | Exp.Const (Const.Cfun procname) => [procname, ...callees]
-        | _ => callees
-        }
-      | _ => callees
-      };
-    List.fold f::collect init::[] (get_instrs node)
-  };
-
-  /** Get the location of the node */
-  let get_loc n => n.loc;
-
-  /** Get the source location of the last instruction in the node */
-  let get_last_loc n =>
-    switch (List.rev (get_instrs n)) {
-    | [instr, ..._] => Sil.instr_get_loc instr
-    | [] => n.loc
-    };
-  let pp_id f id => F.fprintf f "%d" id;
-  let pp f node => pp_id f (get_id node);
-  let get_distance_to_exit node => node.dist_exit;
-
-  /** Append the instructions to the list of instructions to execute */
-  let append_instrs node instrs => node.instrs = node.instrs @ instrs;
-
-  /** Add the instructions at the beginning of the list of instructions to execute */
-  let prepend_instrs node instrs => node.instrs = instrs @ node.instrs;
-
-  /** Replace the instructions to be executed. */
-  let replace_instrs node instrs => node.instrs = instrs;
-
-  /** Add declarations for local variables and return variable to the node */
-  let add_locals_ret_declaration node (proc_attributes: ProcAttributes.t) locals => {
-    let loc = get_loc node;
-    let pname = proc_attributes.proc_name;
-    let ret_var = {
-      let ret_type = proc_attributes.ret_type;
-      (Pvar.get_ret_pvar pname, ret_type)
-    };
-    let construct_decl (x, typ) => (Pvar.mk x pname, typ);
-    let ptl = [ret_var, ...List.map f::construct_decl locals];
-    let instr = Sil.Declare_locals ptl loc;
-    prepend_instrs node [instr]
-  };
-
-  /** Print extended instructions for the node,
-      highlighting the given subinstruction if present */
-  let pp_instrs pe0 ::sub_instrs instro fmt node => {
-    let pe =
-      switch instro {
-      | None => pe0
-      | Some instr => Pp.extend_colormap pe0 (Obj.repr instr) Red
-      };
-    let instrs = get_instrs node;
-    let pp_loc fmt () => F.fprintf fmt " %a " Location.pp (get_loc node);
-    let print_sub_instrs () => F.fprintf fmt "%a" (Sil.pp_instr_list pe) instrs;
-    switch (get_kind node) {
-    | Stmt_node s =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "statements (%s) %a" s pp_loc ()
-      }
-    | Prune_node _ _ descr =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "assume %s %a" descr pp_loc ()
-      }
-    | Exit_node _ =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "exit %a" pp_loc ()
-      }
-    | Skip_node s =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "skip (%s) %a" s pp_loc ()
-      }
-    | Start_node _ =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "start %a" pp_loc ()
-      }
-    | Join_node =>
-      if sub_instrs {
-        print_sub_instrs ()
-      } else {
-        F.fprintf fmt "join %a" pp_loc ()
-      }
-    }
-  };
-
-  /** Dump extended instructions for the node */
-  let d_instrs sub_instrs::(sub_instrs: bool) (curr_instr: option Sil.instr) (node: t) =>
-    L.add_print_action (L.PTnode_instrs, Obj.repr (sub_instrs, curr_instr, node));
-
-  /** Return a description of the cfg node */
-  let get_description pe node => {
-    let str =
-      switch (get_kind node) {
-      | Stmt_node _ => "Instructions"
-      | Prune_node _ _ descr => "Conditional" ^ " " ^ descr
-      | Exit_node _ => "Exit"
-      | Skip_node _ => "Skip"
-      | Start_node _ => "Start"
-      | Join_node => "Join"
-      };
-    let pp fmt => F.fprintf fmt "%s@\n%a@?" str (pp_instrs pe None sub_instrs::true) node;
-    F.asprintf "%t" pp
-  };
-};
-
-/* =============== END of module Node =============== */
-
-/** Map over nodes */
-module NodeMap = Caml.Map.Make Node;
-
-
-/** Hash table with nodes as keys. */
-module NodeHash = Hashtbl.Make Node;
-
-
-/** Set of nodes. */
-module NodeSet = Node.NodeSet;
-
-
-/** Map with node id keys. */
-module IdMap = Node.IdMap;
-
-
-/** procedure description */
-type t = {
-  attributes: ProcAttributes.t, /** attributes of the procedure */
-  mutable nodes: list Node.t, /** list of nodes of this procedure */
-  mutable nodes_num: int, /** number of nodes */
-  mutable start_node: Node.t, /** start node of this procedure */
-  mutable exit_node: Node.t, /** exit node of ths procedure */
-  mutable loop_heads: option NodeSet.t /** loop head nodes of this procedure */
-}
-[@@deriving compare];
-
-
-/** Only call from Cfg */
-let from_proc_attributes ::called_from_cfg attributes => {
-  if (not called_from_cfg) {
-    assert false
-  };
-  let pname_opt = Some attributes.ProcAttributes.proc_name;
-  let start_node = Node.dummy pname_opt;
-  let exit_node = Node.dummy pname_opt;
-  {attributes, nodes: [], nodes_num: 0, start_node, exit_node, loop_heads: None}
-};
-
-
-/** Compute the distance of each node to the exit node, if not computed already */
-let compute_distance_to_exit_node pdesc => {
-  let exit_node = pdesc.exit_node;
-  let rec mark_distance dist nodes => {
-    let next_nodes = ref [];
-    let do_node (node: Node.t) =>
-      switch node.dist_exit {
-      | Some _ => ()
-      | None =>
-        node.dist_exit = Some dist;
-        next_nodes := node.preds @ !next_nodes
-      };
-    List.iter f::do_node nodes;
-    if (!next_nodes != []) {
-      mark_distance (dist + 1) !next_nodes
-    }
-  };
-  mark_distance 0 [exit_node]
-};
-
-
-/** check or indicate if we have performed preanalysis on the CFG */
-let did_preanalysis pdesc => pdesc.attributes.did_preanalysis;
-
-let signal_did_preanalysis pdesc => pdesc.attributes.did_preanalysis = true;
-
-let get_attributes pdesc => pdesc.attributes;
-
-let get_err_log pdesc => pdesc.attributes.err_log;
-
-let get_exit_node pdesc => pdesc.exit_node;
-
-
-/** Get flags for the proc desc */
-let get_flags pdesc => pdesc.attributes.proc_flags;
-
-
-/** Return name and type of formal parameters */
-let get_formals pdesc => pdesc.attributes.formals;
-
-let get_loc pdesc => pdesc.attributes.loc;
-
-
-/** Return name and type of local variables */
-let get_locals pdesc => pdesc.attributes.locals;
-
-
-/** Return name and type of captured variables */
-let get_captured pdesc => pdesc.attributes.captured;
-
-
-/** Return the visibility attribute */
-let get_access pdesc => pdesc.attributes.access;
-
-let get_nodes pdesc => pdesc.nodes;
-
-let get_proc_name pdesc => pdesc.attributes.proc_name;
-
-
-/** Return the return type of the procedure */
-let get_ret_type pdesc => pdesc.attributes.ret_type;
-
-let get_ret_var pdesc => Pvar.mk Ident.name_return (get_proc_name pdesc);
-
-let get_start_node pdesc => pdesc.start_node;
-
-
-/** List of nodes in the procedure sliced by a predicate up to the first branching */
-let get_sliced_slope pdesc f =>
-  Node.get_generated_slope (get_start_node pdesc) (fun n => Node.get_sliced_succs n f);
-
-
-/** List of nodes in the procedure up to the first branching */
-let get_slope pdesc => Node.get_generated_slope (get_start_node pdesc) Node.get_succs;
-
-
-/** Return [true] iff the procedure is defined, and not just declared */
-let is_defined pdesc => pdesc.attributes.is_defined;
-
-let is_body_empty pdesc => List.is_empty (Node.get_succs (get_start_node pdesc));
-
-let is_java_synchronized pdesc => pdesc.attributes.is_java_synchronized_method;
-
-let iter_nodes f pdesc => List.iter ::f (List.rev (get_nodes pdesc));
-
-let fold_calls f acc pdesc => {
-  let do_node a node =>
-    List.fold
-      f::(fun b callee_pname => f b (callee_pname, Node.get_loc node))
-      init::a
-      (Node.get_callees node);
-  List.fold f::do_node init::acc (get_nodes pdesc)
-};
-
-
-/** iterate over the calls from the procedure: (callee,location) pairs */
-let iter_calls f pdesc => fold_calls (fun _ call => f call) () pdesc;
-
-let iter_instrs f pdesc => {
-  let do_node node => List.iter f::(fun i => f node i) (Node.get_instrs node);
-  iter_nodes do_node pdesc
-};
-
-let fold_nodes f acc pdesc => List.fold ::f init::acc (List.rev (get_nodes pdesc));
-
-let fold_instrs f acc pdesc => {
-  let fold_node acc node =>
-    List.fold f::(fun acc instr => f acc node instr) init::acc (Node.get_instrs node);
-  fold_nodes fold_node acc pdesc
-};
-
-let iter_slope f pdesc => {
-  let visited = ref NodeSet.empty;
-  let rec do_node node => {
-    visited := NodeSet.add node !visited;
-    f node;
-    switch (Node.get_succs node) {
-    | [n] =>
-      if (not (NodeSet.mem n !visited)) {
-        do_node n
-      }
-    | _ => ()
-    }
-  };
-  do_node (get_start_node pdesc)
-};
-
-let iter_slope_calls f pdesc => {
-  let do_node node => List.iter f::(fun callee_pname => f callee_pname) (Node.get_callees node);
-  iter_slope do_node pdesc
-};
-
-
-/** iterate between two nodes or until we reach a branching structure */
-let iter_slope_range f src_node dst_node => {
-  let visited = ref NodeSet.empty;
-  let rec do_node node => {
-    visited := NodeSet.add node !visited;
-    f node;
-    switch (Node.get_succs node) {
-    | [n] =>
-      if (not (NodeSet.mem n !visited) && not (Node.equal node dst_node)) {
-        do_node n
-      }
-    | _ => ()
-    }
-  };
-  do_node src_node
-};
-
-
-/** Set the exit node of the proc desc */
-let set_exit_node pdesc node => pdesc.exit_node = node;
-
-
-/** Set a flag for the proc desc */
-let set_flag pdesc key value =>
-  ProcAttributes.proc_flags_add pdesc.attributes.proc_flags key value;
-
-
-/** Set the start node of the proc desc */
-let set_start_node pdesc node => pdesc.start_node = node;
-
-
-/** Append the locals to the list of local variables */
-let append_locals pdesc new_locals =>
-  pdesc.attributes.locals = pdesc.attributes.locals @ new_locals;
-
-
-/** Set the successor nodes and exception nodes, and build predecessor links */
-let set_succs_exn_base (node: Node.t) succs exn => {
-  node.succs = succs;
-  node.exn = exn;
-  List.iter f::(fun (n: Node.t) => n.preds = [node, ...n.preds]) succs
-};
-
-
-/** Create a new cfg node */
-let create_node pdesc loc kind instrs => {
-  pdesc.nodes_num = pdesc.nodes_num + 1;
-  let node_id = pdesc.nodes_num;
-  let node = {
-    Node.id: node_id,
-    dist_exit: None,
-    instrs,
-    kind,
-    loc,
-    preds: [],
-    pname_opt: Some pdesc.attributes.proc_name,
-    succs: [],
-    exn: []
-  };
-  pdesc.nodes = [node, ...pdesc.nodes];
-  node
-};
-
-
-/** Set the successor and exception nodes.
-    If this is a join node right before the exit node, add an extra node in the middle,
-    otherwise nullify and abstract instructions cannot be added after a conditional. */
-let node_set_succs_exn pdesc (node: Node.t) succs exn =>
-  switch (node.kind, succs) {
-  | (Join_node, [{Node.kind: Exit_node _} as exit_node]) =>
-    let kind = Node.Stmt_node "between_join_and_exit";
-    let node' = create_node pdesc node.loc kind node.instrs;
-    set_succs_exn_base node [node'] exn;
-    set_succs_exn_base node' [exit_node] exn
-  | _ => set_succs_exn_base node succs exn
-  };
-
-
-/** Get loop heads for widening.
-    It collects all target nodes of back-edges in a depth-first
-    traversal.
-    */
-let get_loop_heads pdesc => {
-  let rec set_loop_head_rec visited heads wl =>
-    switch wl {
-    | [] => heads
-    | [(n, ancester), ...wl'] =>
-      if (NodeSet.mem n visited) {
-        if (NodeSet.mem n ancester) {
-          set_loop_head_rec visited (NodeSet.add n heads) wl'
-        } else {
-          set_loop_head_rec visited heads wl'
-        }
-      } else {
-        let ancester = NodeSet.add n ancester;
-        let succs = List.append (Node.get_succs n) (Node.get_exn n);
-        let works = List.map f::(fun m => (m, ancester)) succs;
-        set_loop_head_rec (NodeSet.add n visited) heads (List.append works wl')
-      }
-    };
-  let start_wl = [(get_start_node pdesc, NodeSet.empty)];
-  let lh = set_loop_head_rec NodeSet.empty NodeSet.empty start_wl;
-  pdesc.loop_heads = Some lh;
-  lh
-};
-
-let is_loop_head pdesc (node: Node.t) => {
-  let lh =
-    switch pdesc.loop_heads {
-    | Some lh => lh
-    | None => get_loop_heads pdesc
-    };
-  NodeSet.mem node lh
-};
-
-let pp_variable_list fmt etl =>
-  if (List.is_empty etl) {
-    Format.fprintf fmt "None"
-  } else {
-    List.iter
-      f::(fun (id, ty) => Format.fprintf fmt " %a:%a" Mangled.pp id (Typ.pp_full Pp.text) ty) etl
-  };
-
-let pp_objc_accessor fmt accessor =>
-  switch accessor {
-  | Some (ProcAttributes.Objc_getter name) =>
-    Format.fprintf fmt "Getter of %a, " Typ.Fieldname.pp name
-  | Some (ProcAttributes.Objc_setter name) =>
-    Format.fprintf fmt "Setter of %a, " Typ.Fieldname.pp name
-  | None => ()
-  };
-
-let pp_signature fmt pdesc => {
-  let attributes = get_attributes pdesc;
-  let pname = get_proc_name pdesc;
-  let pname_string = Typ.Procname.to_string pname;
-  let defined_string = is_defined pdesc ? "defined" : "undefined";
-  Format.fprintf
-    fmt
-    "%s [%s, Return type: %s, %aFormals: %a, Locals: %a"
-    pname_string
-    defined_string
-    (Typ.to_string (get_ret_type pdesc))
-    pp_objc_accessor
-    attributes.ProcAttributes.objc_accessor
-    pp_variable_list
-    (get_formals pdesc)
-    pp_variable_list
-    (get_locals pdesc);
-  if (not (List.is_empty (get_captured pdesc))) {
-    Format.fprintf fmt ", Captured: %a" pp_variable_list (get_captured pdesc)
-  };
-  let method_annotation = attributes.ProcAttributes.method_annotation;
-  if (not (Annot.Method.is_empty method_annotation)) {
-    Format.fprintf fmt ", Annotation: %a" (Annot.Method.pp pname_string) method_annotation
-  };
-  Format.fprintf fmt "]@\n"
-};

infer/src/IR/Procdesc.rei

@@ -1,284 +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;
-
-
-/** node of the control flow graph */
-module Node: {
-
-  /** type of nodes */
-  type t [@@deriving compare];
-
-  /** node id */
-  type id = pri int [@@deriving compare];
-  let equal_id: id => id => bool;
-
-  /** kind of cfg node */
-  type nodekind =
-    | Start_node Typ.Procname.t
-    | Exit_node Typ.Procname.t
-    | Stmt_node string
-    | Join_node
-    | Prune_node bool Sil.if_kind string /** (true/false branch, if_kind, comment) */
-    | Skip_node string
-  [@@deriving compare];
-  let equal_nodekind: nodekind => nodekind => bool;
-
-  /** kind of Stmt_node for an exception handler. */
-  let exn_handler_kind: nodekind;
-
-  /** kind of Stmt_node for an exceptions sink. */
-  let exn_sink_kind: nodekind;
-
-  /** kind of Stmt_node for a throw instruction. */
-  let throw_kind: nodekind;
-
-  /** Add declarations for local variables and return variable to the node */
-  let add_locals_ret_declaration: t => ProcAttributes.t => list (Mangled.t, Typ.t) => unit;
-
-  /** Append the instructions to the list of instructions to execute */
-  let append_instrs: t => list Sil.instr => unit;
-
-  /** Dump extended instructions for the node */
-  let d_instrs: sub_instrs::bool => option Sil.instr => t => unit;
-
-  /** Create a dummy node */
-  let dummy: option Typ.Procname.t => t;
-
-  /** Check if two nodes are equal */
-  let equal: t => t => bool;
-
-  /** Get the list of callee procnames from the node */
-  let get_callees: t => list Typ.Procname.t;
-
-  /** Return a description of the node */
-  let get_description: Pp.env => t => string;
-
-  /** Get the distance to the exit node, if it has been computed */
-  let get_distance_to_exit: t => option int;
-
-  /** Get the exception nodes from the current node */
-  let get_exn: t => list t;
-
-  /** Get a list of unique nodes until the first branch starting
-      from a node with subsequent applications of a generator function */
-  let get_generated_slope: t => (t => list t) => list t;
-
-  /** Get the unique id of the node */
-  let get_id: t => id;
-
-  /** Get the instructions to be executed */
-  let get_instrs: t => list Sil.instr;
-
-  /** Get the kind of the current node */
-  let get_kind: t => nodekind;
-
-  /** Get the source location of the last instruction in the node */
-  let get_last_loc: t => Location.t;
-
-  /** Get the source location of the node */
-  let get_loc: t => Location.t;
-
-  /** Get the predecessor nodes of the current node */
-  let get_preds: t => list t;
-
-  /** Get the name of the procedure the node belongs to */
-  let get_proc_name: t => Typ.Procname.t;
-
-  /** Get the predecessor nodes of a node where the given predicate evaluates to true */
-  let get_sliced_preds: t => (t => bool) => list t;
-
-  /** Get the successor nodes of a node where the given predicate evaluates to true */
-  let get_sliced_succs: t => (t => bool) => list t;
-
-  /** Get the successor nodes of the current node */
-  let get_succs: t => list t;
-
-  /** Hash function for nodes */
-  let hash: t => int;
-
-  /** Pretty print the node */
-  let pp: Format.formatter => t => unit;
-
-  /** Pretty print a node id */
-  let pp_id: Format.formatter => id => unit;
-
-  /** Print extended instructions for the node,
-      highlighting the given subinstruction if present */
-  let pp_instrs: Pp.env => sub_instrs::bool => option Sil.instr => Format.formatter => t => unit;
-
-  /** Replace the instructions to be executed. */
-  let replace_instrs: t => list Sil.instr => unit;
-};
-
-
-/** Map with node id keys. */
-module IdMap: Caml.Map.S with type key = Node.id;
-
-
-/** Hash table with nodes as keys. */
-module NodeHash: Caml.Hashtbl.S with type key = Node.t;
-
-
-/** Map over nodes. */
-module NodeMap: Caml.Map.S with type key = Node.t;
-
-
-/** Set of nodes. */
-module NodeSet: Caml.Set.S with type elt = Node.t;
-
-
-/** procedure descriptions */
-
-/** proc description */
-type t [@@deriving compare];
-
-
-/** append a list of new local variables to the existing list of local variables */
-let append_locals: t => list (Mangled.t, Typ.t) => unit;
-
-
-/** Compute the distance of each node to the exit node, if not computed already */
-let compute_distance_to_exit_node: t => unit;
-
-
-/** Create a new cfg node with the given location, kind, list of instructions,
-    and add it to the procdesc. */
-let create_node: t => Location.t => Node.nodekind => list Sil.instr => Node.t;
-
-
-/** true if we ran the preanalysis on the CFG associated with [t] */
-let did_preanalysis: t => bool;
-
-
-/** fold over the calls from the procedure: (callee, location) pairs */
-let fold_calls: ('a => (Typ.Procname.t, Location.t) => 'a) => 'a => t => 'a;
-
-
-/** fold over all nodes and their instructions */
-let fold_instrs: ('a => Node.t => Sil.instr => 'a) => 'a => t => 'a;
-
-
-/** fold over all nodes */
-let fold_nodes: ('a => Node.t => 'a) => 'a => t => 'a;
-
-
-/** Only call from Cfg. */
-let from_proc_attributes: called_from_cfg::bool => ProcAttributes.t => t;
-
-
-/** Return the visibility attribute */
-let get_access: t => PredSymb.access;
-
-
-/** Get the attributes of the procedure. */
-let get_attributes: t => ProcAttributes.t;
-
-
-/** Return name and type of block's captured variables */
-let get_captured: t => list (Mangled.t, Typ.t);
-
-let get_err_log: t => Errlog.t;
-
-let get_exit_node: t => Node.t;
-
-
-/** Get flags for the proc desc */
-let get_flags: t => ProcAttributes.proc_flags;
-
-
-/** Return name and type of formal parameters */
-let get_formals: t => list (Mangled.t, Typ.t);
-
-
-/** Return loc information for the procedure */
-let get_loc: t => Location.t;
-
-
-/** Return name and type of local variables */
-let get_locals: t => list (Mangled.t, Typ.t);
-
-let get_nodes: t => list Node.t;
-
-let get_proc_name: t => Typ.Procname.t;
-
-
-/** Return the return type of the procedure and type string */
-let get_ret_type: t => Typ.t;
-
-let get_ret_var: t => Pvar.t;
-
-
-/** Get the sliced procedure's nodes up until the first branching */
-let get_sliced_slope: t => (Node.t => bool) => list Node.t;
-
-
-/** Get the procedure's nodes up until the first branching */
-let get_slope: t => list Node.t;
-
-let get_start_node: t => Node.t;
-
-
-/** Return [true] iff the procedure is defined, and not just declared */
-let is_defined: t => bool;
-
-
-/** Return [true] if the body of the procdesc is empty (no instructions) */
-let is_body_empty: t => bool;
-
-
-/** Return [true] if the procedure signature has the Java synchronized keyword */
-let is_java_synchronized: t => bool;
-
-
-/** iterate over the calls from the procedure: (callee, location) pairs */
-let iter_calls: ((Typ.Procname.t, Location.t) => unit) => t => unit;
-
-
-/** iterate over all nodes and their instructions */
-let iter_instrs: (Node.t => Sil.instr => unit) => t => unit;
-
-
-/** iterate over all the nodes of a procedure */
-let iter_nodes: (Node.t => unit) => t => unit;
-
-
-/** iterate over all nodes until we reach a branching structure */
-let iter_slope: (Node.t => unit) => t => unit;
-
-
-/** iterate over all calls until we reach a branching structure */
-let iter_slope_calls: (Typ.Procname.t => unit) => t => unit;
-
-
-/** iterate between two nodes or until we reach a branching structure */
-let iter_slope_range: (Node.t => unit) => Node.t => Node.t => unit;
-
-
-/** Set the successor nodes and exception nodes, and build predecessor links */
-let node_set_succs_exn: t => Node.t => list Node.t => list Node.t => unit;
-
-
-/** Set the exit node of the procedure */
-let set_exit_node: t => Node.t => unit;
-
-
-/** Set a flag for the proc desc */
-let set_flag: t => string => string => unit;
-
-let set_start_node: t => Node.t => unit;
-
-
-/** indicate that we have performed preanalysis on the CFG assoociated with [t] */
-let signal_did_preanalysis: t => unit;
-
-let is_loop_head: t => Node.t => bool;
-
-let pp_signature: Format.formatter => t => unit;

infer/src/IR/Pvar.ml

@@ -0,0 +1,258 @@
+(*
+ * 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 *)
+open! IStd
+module L = Logging
+module F = Format
+
+type translation_unit = TUFile of SourceFile.t | TUExtern [@@deriving compare]
+
+(** Kind of global variables *)
+type pvar_kind =
+  | Local_var of Typ.Procname.t  (** local variable belonging to a function *)
+  | Callee_var of Typ.Procname.t  (** local variable belonging to a callee *)
+  | Abduced_retvar of Typ.Procname.t * Location.t
+      (** synthetic variable to represent return value *)
+  | Abduced_ref_param of Typ.Procname.t * t * Location.t
+  | Abduced_ref_param_val of Typ.Procname.t * Ident.t * Location.t
+      (** synthetic variable to represent param passed by reference *)
+  | Global_var of (translation_unit * bool * bool * bool)
+      (** global variable: translation unit + is it compile constant? + is it POD? + is it a static
+      local? *)
+  | Seed_var  (** variable used to store the initial value of formal parameters *)
+  [@@deriving compare]
+
+(** Names for program variables. *)
+and t = {pv_hash: int; pv_name: Mangled.t; pv_kind: pvar_kind} [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+let pp_translation_unit fmt = function
+  | TUFile fname
+   -> SourceFile.pp fmt fname
+  | TUExtern
+   -> Format.fprintf fmt "EXTERN"
+
+let rec _pp f pv =
+  let name = pv.pv_name in
+  match pv.pv_kind with
+  | Local_var n
+   -> if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name
+      else F.fprintf f "%a$%a" Typ.Procname.pp n Mangled.pp name
+  | Callee_var n
+   -> if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name
+      else F.fprintf f "%a$%a|callee" Typ.Procname.pp n Mangled.pp name
+  | Abduced_retvar (n, l)
+   -> if !Config.pp_simple then F.fprintf f "%a|abducedRetvar" Mangled.pp name
+      else F.fprintf f "%a$%a%a|abducedRetvar" Typ.Procname.pp n Location.pp l Mangled.pp name
+  | Abduced_ref_param (n, pv, l)
+   -> if !Config.pp_simple then F.fprintf f "%a|%a|abducedRefParam" _pp pv Mangled.pp name
+      else F.fprintf f "%a$%a%a|abducedRefParam" Typ.Procname.pp n Location.pp l Mangled.pp name
+  | Abduced_ref_param_val (n, id, l)
+   -> if !Config.pp_simple then
+        F.fprintf f "%a|%a|abducedRefParamVal" (Ident.pp Pp.text) id Mangled.pp name
+      else F.fprintf f "%a$%a%a|abducedRefParamVal" Typ.Procname.pp n Location.pp l Mangled.pp name
+  | Global_var (translation_unit, is_const, is_pod, _)
+   -> F.fprintf f "#GB<%a%s%s>$%a" pp_translation_unit translation_unit
+        (if is_const then "|const" else "")
+        (if not is_pod then "|!pod" else "")
+        Mangled.pp name
+  | Seed_var
+   -> F.fprintf f "old_%a" Mangled.pp name
+
+(** Pretty print a program variable in latex. *)
+let pp_latex f pv =
+  let name = pv.pv_name in
+  match pv.pv_kind with
+  | Local_var _
+   -> Latex.pp_string Latex.Roman f (Mangled.to_string name)
+  | Callee_var _
+   -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
+        (Latex.pp_string Latex.Roman) "callee"
+  | Abduced_retvar _
+   -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
+        (Latex.pp_string Latex.Roman) "abducedRetvar"
+  | Abduced_ref_param _
+   -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
+        (Latex.pp_string Latex.Roman) "abducedRefParam"
+  | Abduced_ref_param_val _
+   -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
+        (Latex.pp_string Latex.Roman) "abducedRefParamVal"
+  | Global_var _
+   -> Latex.pp_string Latex.Boldface f (Mangled.to_string name)
+  | Seed_var
+   -> F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
+        (Latex.pp_string Latex.Roman) "old"
+
+(** Pretty print a pvar which denotes a value, not an address *)
+let pp_value pe f pv =
+  match pe.Pp.kind with TEXT -> _pp f pv | HTML -> _pp f pv | LATEX -> pp_latex f pv
+
+(** Pretty print a program variable. *)
+let pp pe f pv =
+  let ampersand = match pe.Pp.kind with TEXT -> "&" | HTML -> "&amp;" | LATEX -> "\\&" in
+  F.fprintf f "%s%a" ampersand (pp_value pe) pv
+
+(** Dump a program variable. *)
+let d (pvar: t) = L.add_print_action (L.PTpvar, Obj.repr pvar)
+
+(** Pretty print a list of program variables. *)
+let pp_list pe f pvl = F.fprintf f "%a" (Pp.seq (fun f e -> F.fprintf f "%a" (pp pe) e)) pvl
+
+(** Dump a list of program variables. *)
+let d_list pvl = List.iter ~f:(fun pv -> d pv ; L.d_str " ") pvl
+
+let get_name pv = pv.pv_name
+
+let to_string pv = Mangled.to_string pv.pv_name
+
+let get_simplified_name pv =
+  let s = Mangled.to_string pv.pv_name in
+  match String.rsplit2 s ~on:'.' with
+  | Some (s1, s2) -> (
+    match String.rsplit2 s1 ~on:'.' with Some (_, s4) -> s4 ^ "." ^ s2 | _ -> s )
+  | _
+   -> s
+
+(** Check if the pvar is an abucted return var or param passed by ref *)
+let is_abduced pv =
+  match pv.pv_kind with
+  | Abduced_retvar _ | Abduced_ref_param _ | Abduced_ref_param_val _
+   -> true
+  | _
+   -> false
+
+(** Turn a pvar into a seed pvar (which stored the initial value) *)
+let to_seed pv = {pv with pv_kind= Seed_var}
+
+(** Check if the pvar is a local var *)
+let is_local pv = match pv.pv_kind with Local_var _ -> true | _ -> false
+
+(** Check if the pvar is a callee var *)
+let is_callee pv = match pv.pv_kind with Callee_var _ -> true | _ -> false
+
+(** Check if the pvar is a seed var *)
+let is_seed pv = match pv.pv_kind with Seed_var -> true | _ -> false
+
+(** Check if the pvar is a global var *)
+let is_global pv = match pv.pv_kind with Global_var _ -> true | _ -> false
+
+let is_static_local pv = match pv.pv_kind with Global_var (_, _, _, true) -> true | _ -> false
+
+(** Check if a pvar is the special "this" var *)
+let is_this pvar = Mangled.equal (get_name pvar) (Mangled.from_string "this")
+
+(** Check if a pvar is the special "self" var *)
+let is_self pvar = Mangled.equal (get_name pvar) (Mangled.from_string "self")
+
+(** Check if the pvar is a return var *)
+let is_return pv = Mangled.equal (get_name pv) Ident.name_return
+
+(** something that can't be part of a legal identifier in any conceivable language *)
+let tmp_prefix = "0$?%__sil_tmp"
+
+(** return true if [pvar] is a temporary variable generated by the frontend *)
+let is_frontend_tmp pvar =
+  (* Check whether the program variable is a temporary one generated by Sawja, javac, or some other
+     bytecode/name generation pass. valid java identifiers cannot contain `$` *)
+  let is_bytecode_tmp name =
+    String.contains name '$' && not (String.contains name '_')
+    || String.is_prefix ~prefix:"CatchVar" name
+  in
+  (* Check whether the program variable is generated by [mk_tmp] *)
+  let is_sil_tmp name = String.is_prefix ~prefix:tmp_prefix name in
+  let name = to_string pvar in
+  is_sil_tmp name
+  ||
+  match pvar.pv_kind with
+  | Local_var pname
+   -> Typ.Procname.is_java pname && is_bytecode_tmp name
+  | _
+   -> false
+
+(* in Sawja, variables like $T0_18 are temporaries, but not SSA vars. *)
+let is_ssa_frontend_tmp pvar =
+  is_frontend_tmp pvar
+  &&
+  let name = to_string pvar in
+  not (String.contains name '_' && String.contains name '$')
+
+(** Turn an ordinary program variable into a callee program variable *)
+let to_callee pname pvar =
+  match pvar.pv_kind with
+  | Local_var _
+   -> {pvar with pv_kind= Callee_var pname}
+  | Global_var _
+   -> pvar
+  | Callee_var _ | Abduced_retvar _ | Abduced_ref_param _ | Abduced_ref_param_val _ | Seed_var
+   -> L.d_str "Cannot convert pvar to callee: " ;
+      d pvar ;
+      L.d_ln () ;
+      assert false
+
+let name_hash (name: Mangled.t) = Hashtbl.hash name
+
+(** [mk name proc_name] creates a program var with the given function name *)
+let mk (name: Mangled.t) (proc_name: Typ.Procname.t) : t =
+  {pv_hash= name_hash name; pv_name= name; pv_kind= Local_var proc_name}
+
+let get_ret_pvar pname = mk Ident.name_return pname
+
+(** [mk_callee name proc_name] creates a program var
+    for a callee function with the given function name *)
+let mk_callee (name: Mangled.t) (proc_name: Typ.Procname.t) : t =
+  {pv_hash= name_hash name; pv_name= name; pv_kind= Callee_var proc_name}
+
+(** create a global variable with the given name *)
+let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) (name: Mangled.t)
+    translation_unit : t =
+  { pv_hash= name_hash name
+  ; pv_name= name
+  ; pv_kind= Global_var (translation_unit, is_constexpr, is_pod, is_static_local) }
+
+(** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! *)
+let mk_tmp name pname =
+  let id = Ident.create_fresh Ident.knormal in
+  let pvar_mangled = Mangled.from_string (tmp_prefix ^ name ^ Ident.to_string id) in
+  mk pvar_mangled pname
+
+(** create an abduced return variable for a call to [proc_name] at [loc] *)
+let mk_abduced_ret (proc_name: Typ.Procname.t) (loc: Location.t) : t =
+  let name = Mangled.from_string ("$RET_" ^ Typ.Procname.to_unique_id proc_name) in
+  {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_retvar (proc_name, loc)}
+
+let mk_abduced_ref_param (proc_name: Typ.Procname.t) (pv: t) (loc: Location.t) : t =
+  let name = Mangled.from_string ("$REF_PARAM_" ^ Typ.Procname.to_unique_id proc_name) in
+  {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_ref_param (proc_name, pv, loc)}
+
+let mk_abduced_ref_param_val (proc_name: Typ.Procname.t) (id: Ident.t) (loc: Location.t) : t =
+  let name = Mangled.from_string ("$REF_PARAM_VAL_" ^ Typ.Procname.to_unique_id proc_name) in
+  {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_ref_param_val (proc_name, id, loc)}
+
+let get_translation_unit pvar =
+  match pvar.pv_kind with
+  | Global_var (tu, _, _, _)
+   -> tu
+  | _
+   -> invalid_argf "Expected a global variable"
+
+let is_compile_constant pvar = match pvar.pv_kind with Global_var (_, b, _, _) -> b | _ -> false
+
+let is_pod pvar = match pvar.pv_kind with Global_var (_, _, b, _) -> b | _ -> true
+
+let get_initializer_pname {pv_name; pv_kind} =
+  match pv_kind with
+  | Global_var _
+   -> Some
+        (Typ.Procname.from_string_c_fun
+           (Config.clang_initializer_prefix ^ Mangled.to_string_full pv_name))
+  | _
+   -> None

infer/src/IR/Pvar.mli

@@ -0,0 +1,167 @@
+(*
+ * 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.
+ *)
+
+(** Program variables. *)
+open! IStd
+module F = Format
+
+type translation_unit = TUFile of SourceFile.t | TUExtern [@@deriving compare]
+
+(** Type for program variables. There are 4 kinds of variables:
+        1) local variables, used for local variables and formal parameters
+        2) callee program variables, used to handle recursion ([x | callee] is distinguished from [x])
+        3) global variables
+        4) seed variables, used to store the initial value of formal parameters
+    *)
+
+type t [@@deriving compare]
+
+(** Equality for pvar's *)
+
+val equal : t -> t -> bool
+
+(** Dump a program variable. *)
+
+val d : t -> unit
+
+(** Dump a list of program variables. *)
+
+val d_list : t list -> unit
+
+(** Get the name component of a program variable. *)
+
+val get_name : t -> Mangled.t
+
+(** [get_ret_pvar proc_name] retuns the return pvar associated with the procedure name *)
+
+val get_ret_pvar : Typ.Procname.t -> t
+
+(** Get a simplified version of the name component of a program variable. *)
+
+val get_simplified_name : t -> string
+
+(** Check if the pvar is an abduced return var or param passed by ref *)
+
+val is_abduced : t -> bool
+
+(** Check if the pvar is a callee var *)
+
+val is_callee : t -> bool
+
+(** Check if the pvar is a global var or a static local var *)
+
+val is_global : t -> bool
+
+(** Check if the pvar is a static variable declared inside a function *)
+
+val is_static_local : t -> bool
+
+(** Check if the pvar is a (non-static) local var *)
+
+val is_local : t -> bool
+
+(** Check if the pvar is a seed var *)
+
+val is_seed : t -> bool
+
+(** Check if the pvar is a return var *)
+
+val is_return : t -> bool
+
+(** Check if a pvar is the special "this" var *)
+
+val is_this : t -> bool
+
+(** Check if a pvar is the special "self" var *)
+
+val is_self : t -> bool
+
+(** return true if [pvar] is a temporary variable generated by the frontend *)
+
+val is_frontend_tmp : t -> bool
+
+(** return true if [pvar] is a temporary variable generated by the frontend and is only assigned
+    once on a non-looping control-flow path *)
+
+val is_ssa_frontend_tmp : t -> bool
+
+(** [mk name proc_name suffix] creates a program var with the given function name and suffix *)
+
+val mk : Mangled.t -> Typ.Procname.t -> t
+
+(** create an abduced variable for a parameter passed by reference *)
+
+val mk_abduced_ref_param : Typ.Procname.t -> t -> Location.t -> t
+
+(** create an abduced variable for a parameter passed by reference *)
+
+val mk_abduced_ref_param_val : Typ.Procname.t -> Ident.t -> Location.t -> t
+
+(** create an abduced return variable for a call to [proc_name] at [loc] *)
+
+val mk_abduced_ret : Typ.Procname.t -> Location.t -> t
+
+(** [mk_callee name proc_name] creates a program var
+    for a callee function with the given function name *)
+
+val mk_callee : Mangled.t -> Typ.Procname.t -> t
+
+(** create a global variable with the given name *)
+
+val mk_global :
+  ?is_constexpr:bool -> ?is_pod:bool -> ?is_static_local:bool -> Mangled.t -> translation_unit -> t
+
+(** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! *)
+
+val mk_tmp : string -> Typ.Procname.t -> t
+
+(** Pretty print a program variable. *)
+
+val pp : Pp.env -> F.formatter -> t -> unit
+
+(** Pretty print a list of program variables. *)
+
+val pp_list : Pp.env -> F.formatter -> t list -> unit
+
+(** Pretty print a pvar which denotes a value, not an address *)
+
+val pp_value : Pp.env -> F.formatter -> t -> unit
+
+val pp_translation_unit : F.formatter -> translation_unit -> unit
+
+(** Turn an ordinary program variable into a callee program variable *)
+
+val to_callee : Typ.Procname.t -> t -> t
+
+(** Turn a pvar into a seed pvar (which stores the initial value of a stack var) *)
+
+val to_seed : t -> t
+
+(** Convert a pvar to string. *)
+
+val to_string : t -> string
+
+(** Get the translation unit corresponding to a global. Raises Invalid_arg if not a global. *)
+
+val get_translation_unit : t -> translation_unit
+
+(** Is the variable's value a compile-time constant? Always (potentially incorrectly) returns
+    [false] for non-globals. *)
+
+val is_compile_constant : t -> bool
+
+(** Is the variable's type a "Plain Old Data" type (C++)? Always (potentially incorrectly) returns
+    [true] for non-globals. *)
+
+val is_pod : t -> bool
+
+(** Get the procname of the initializer function for the given global variable *)
+
+val get_initializer_pname : t -> Typ.Procname.t option

infer/src/IR/Pvar.re

@@ -1,405 +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 */
-module L = Logging;
-
-module F = Format;
-
-type translation_unit =
-  | TUFile SourceFile.t
-  | TUExtern
-[@@deriving compare];
-
-
-/** Kind of global variables */
-type pvar_kind =
-  | Local_var Typ.Procname.t /** local variable belonging to a function */
-  | Callee_var Typ.Procname.t /** local variable belonging to a callee */
-  | Abduced_retvar Typ.Procname.t Location.t /** synthetic variable to represent return value */
-  | Abduced_ref_param Typ.Procname.t t Location.t
-  | Abduced_ref_param_val Typ.Procname.t Ident.t Location.t
-  /** synthetic variable to represent param passed by reference */
-  | Global_var (translation_unit, bool, bool, bool)
-  /** global variable: translation unit + is it compile constant? + is it POD? + is it a static
-      local? */
-  | Seed_var /** variable used to store the initial value of formal parameters */
-[@@deriving compare]
-/** Names for program variables. */
-and t = {pv_hash: int, pv_name: Mangled.t, pv_kind: pvar_kind} [@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-let pp_translation_unit fmt =>
-  fun
-  | TUFile fname => SourceFile.pp fmt fname
-  | TUExtern => Format.fprintf fmt "EXTERN";
-
-let rec _pp f pv => {
-  let name = pv.pv_name;
-  switch pv.pv_kind {
-  | Local_var n =>
-    if !Config.pp_simple {
-      F.fprintf f "%a" Mangled.pp name
-    } else {
-      F.fprintf f "%a$%a" Typ.Procname.pp n Mangled.pp name
-    }
-  | Callee_var n =>
-    if !Config.pp_simple {
-      F.fprintf f "%a|callee" Mangled.pp name
-    } else {
-      F.fprintf f "%a$%a|callee" Typ.Procname.pp n Mangled.pp name
-    }
-  | Abduced_retvar n l =>
-    if !Config.pp_simple {
-      F.fprintf f "%a|abducedRetvar" Mangled.pp name
-    } else {
-      F.fprintf f "%a$%a%a|abducedRetvar" Typ.Procname.pp n Location.pp l Mangled.pp name
-    }
-  | Abduced_ref_param n pv l =>
-    if !Config.pp_simple {
-      F.fprintf f "%a|%a|abducedRefParam" _pp pv Mangled.pp name
-    } else {
-      F.fprintf f "%a$%a%a|abducedRefParam" Typ.Procname.pp n Location.pp l Mangled.pp name
-    }
-  | Abduced_ref_param_val n id l =>
-    if !Config.pp_simple {
-      F.fprintf f "%a|%a|abducedRefParamVal" (Ident.pp Pp.text) id Mangled.pp name
-    } else {
-      F.fprintf f "%a$%a%a|abducedRefParamVal" Typ.Procname.pp n Location.pp l Mangled.pp name
-    }
-  | Global_var (translation_unit, is_const, is_pod, _) =>
-    F.fprintf
-      f
-      "#GB<%a%s%s>$%a"
-      pp_translation_unit
-      translation_unit
-      (if is_const {"|const"} else {""})
-      (
-        if (not is_pod) {
-          "|!pod"
-        } else {
-          ""
-        }
-      )
-      Mangled.pp
-      name
-  | Seed_var => F.fprintf f "old_%a" Mangled.pp name
-  }
-};
-
-
-/** Pretty print a program variable in latex. */
-let pp_latex f pv => {
-  let name = pv.pv_name;
-  switch pv.pv_kind {
-  | Local_var _ => Latex.pp_string Latex.Roman f (Mangled.to_string name)
-  | Callee_var _ =>
-    F.fprintf
-      f
-      "%a_{%a}"
-      (Latex.pp_string Latex.Roman)
-      (Mangled.to_string name)
-      (Latex.pp_string Latex.Roman)
-      "callee"
-  | Abduced_retvar _ =>
-    F.fprintf
-      f
-      "%a_{%a}"
-      (Latex.pp_string Latex.Roman)
-      (Mangled.to_string name)
-      (Latex.pp_string Latex.Roman)
-      "abducedRetvar"
-  | Abduced_ref_param _ =>
-    F.fprintf
-      f
-      "%a_{%a}"
-      (Latex.pp_string Latex.Roman)
-      (Mangled.to_string name)
-      (Latex.pp_string Latex.Roman)
-      "abducedRefParam"
-  | Abduced_ref_param_val _ =>
-    F.fprintf
-      f
-      "%a_{%a}"
-      (Latex.pp_string Latex.Roman)
-      (Mangled.to_string name)
-      (Latex.pp_string Latex.Roman)
-      "abducedRefParamVal"
-  | Global_var _ => Latex.pp_string Latex.Boldface f (Mangled.to_string name)
-  | Seed_var =>
-    F.fprintf
-      f
-      "%a^{%a}"
-      (Latex.pp_string Latex.Roman)
-      (Mangled.to_string name)
-      (Latex.pp_string Latex.Roman)
-      "old"
-  }
-};
-
-
-/** Pretty print a pvar which denotes a value, not an address */
-let pp_value pe f pv =>
-  switch pe.Pp.kind {
-  | TEXT => _pp f pv
-  | HTML => _pp f pv
-  | LATEX => pp_latex f pv
-  };
-
-
-/** Pretty print a program variable. */
-let pp pe f pv => {
-  let ampersand =
-    switch pe.Pp.kind {
-    | TEXT => "&"
-    | HTML => "&amp;"
-    | LATEX => "\\&"
-    };
-  F.fprintf f "%s%a" ampersand (pp_value pe) pv
-};
-
-
-/** Dump a program variable. */
-let d (pvar: t) => L.add_print_action (L.PTpvar, Obj.repr pvar);
-
-
-/** Pretty print a list of program variables. */
-let pp_list pe f pvl => F.fprintf f "%a" (Pp.seq (fun f e => F.fprintf f "%a" (pp pe) e)) pvl;
-
-
-/** Dump a list of program variables. */
-let d_list pvl =>
-  List.iter
-    f::(
-      fun pv => {
-        d pv;
-        L.d_str " "
-      }
-    )
-    pvl;
-
-let get_name pv => pv.pv_name;
-
-let to_string pv => Mangled.to_string pv.pv_name;
-
-let get_simplified_name pv => {
-  let s = Mangled.to_string pv.pv_name;
-  switch (String.rsplit2 s on::'.') {
-  | Some (s1, s2) =>
-    switch (String.rsplit2 s1 on::'.') {
-    | Some (_, s4) => s4 ^ "." ^ s2
-    | _ => s
-    }
-  | _ => s
-  }
-};
-
-
-/** Check if the pvar is an abucted return var or param passed by ref */
-let is_abduced pv =>
-  switch pv.pv_kind {
-  | Abduced_retvar _
-  | Abduced_ref_param _
-  | Abduced_ref_param_val _ => true
-  | _ => false
-  };
-
-
-/** Turn a pvar into a seed pvar (which stored the initial value) */
-let to_seed pv => {...pv, pv_kind: Seed_var};
-
-
-/** Check if the pvar is a local var */
-let is_local pv =>
-  switch pv.pv_kind {
-  | Local_var _ => true
-  | _ => false
-  };
-
-
-/** Check if the pvar is a callee var */
-let is_callee pv =>
-  switch pv.pv_kind {
-  | Callee_var _ => true
-  | _ => false
-  };
-
-
-/** Check if the pvar is a seed var */
-let is_seed pv =>
-  switch pv.pv_kind {
-  | Seed_var => true
-  | _ => false
-  };
-
-
-/** Check if the pvar is a global var */
-let is_global pv =>
-  switch pv.pv_kind {
-  | Global_var _ => true
-  | _ => false
-  };
-
-let is_static_local pv =>
-  switch pv.pv_kind {
-  | Global_var (_, _, _, true) => true
-  | _ => false
-  };
-
-
-/** Check if a pvar is the special "this" var */
-let is_this pvar => Mangled.equal (get_name pvar) (Mangled.from_string "this");
-
-
-/** Check if a pvar is the special "self" var */
-let is_self pvar => Mangled.equal (get_name pvar) (Mangled.from_string "self");
-
-
-/** Check if the pvar is a return var */
-let is_return pv => Mangled.equal (get_name pv) Ident.name_return;
-
-
-/** something that can't be part of a legal identifier in any conceivable language */
-let tmp_prefix = "0$?%__sil_tmp";
-
-
-/** return true if [pvar] is a temporary variable generated by the frontend */
-let is_frontend_tmp pvar => {
-  /* Check whether the program variable is a temporary one generated by Sawja, javac, or some other
-     bytecode/name generation pass. valid java identifiers cannot contain `$` */
-  let is_bytecode_tmp name =>
-    String.contains name '$' && not (String.contains name '_') ||
-    String.is_prefix prefix::"CatchVar" name;
-  /* Check whether the program variable is generated by [mk_tmp] */
-  let is_sil_tmp name => String.is_prefix prefix::tmp_prefix name;
-  let name = to_string pvar;
-  is_sil_tmp name || (
-    switch pvar.pv_kind {
-    | Local_var pname => Typ.Procname.is_java pname && is_bytecode_tmp name
-    | _ => false
-    }
-  )
-};
-
-/* in Sawja, variables like $T0_18 are temporaries, but not SSA vars. */
-let is_ssa_frontend_tmp pvar =>
-  is_frontend_tmp pvar && {
-    let name = to_string pvar;
-    not (String.contains name '_' && String.contains name '$')
-  };
-
-
-/** Turn an ordinary program variable into a callee program variable */
-let to_callee pname pvar =>
-  switch pvar.pv_kind {
-  | Local_var _ => {...pvar, pv_kind: Callee_var pname}
-  | Global_var _ => pvar
-  | Callee_var _
-  | Abduced_retvar _
-  | Abduced_ref_param _
-  | Abduced_ref_param_val _
-  | Seed_var =>
-    L.d_str "Cannot convert pvar to callee: ";
-    d pvar;
-    L.d_ln ();
-    assert false
-  };
-
-let name_hash (name: Mangled.t) => Hashtbl.hash name;
-
-
-/** [mk name proc_name] creates a program var with the given function name */
-let mk (name: Mangled.t) (proc_name: Typ.Procname.t) :t => {
-  pv_hash: name_hash name,
-  pv_name: name,
-  pv_kind: Local_var proc_name
-};
-
-let get_ret_pvar pname => mk Ident.name_return pname;
-
-
-/** [mk_callee name proc_name] creates a program var
-    for a callee function with the given function name */
-let mk_callee (name: Mangled.t) (proc_name: Typ.Procname.t) :t => {
-  pv_hash: name_hash name,
-  pv_name: name,
-  pv_kind: Callee_var proc_name
-};
-
-
-/** create a global variable with the given name */
-let mk_global
-    ::is_constexpr=false
-    ::is_pod=true
-    ::is_static_local=false
-    (name: Mangled.t)
-    translation_unit
-    :t => {
-  pv_hash: name_hash name,
-  pv_name: name,
-  pv_kind: Global_var (translation_unit, is_constexpr, is_pod, is_static_local)
-};
-
-
-/** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! */
-let mk_tmp name pname => {
-  let id = Ident.create_fresh Ident.knormal;
-  let pvar_mangled = Mangled.from_string (tmp_prefix ^ name ^ Ident.to_string id);
-  mk pvar_mangled pname
-};
-
-
-/** create an abduced return variable for a call to [proc_name] at [loc] */
-let mk_abduced_ret (proc_name: Typ.Procname.t) (loc: Location.t) :t => {
-  let name = Mangled.from_string ("$RET_" ^ Typ.Procname.to_unique_id proc_name);
-  {pv_hash: name_hash name, pv_name: name, pv_kind: Abduced_retvar proc_name loc}
-};
-
-let mk_abduced_ref_param (proc_name: Typ.Procname.t) (pv: t) (loc: Location.t) :t => {
-  let name = Mangled.from_string ("$REF_PARAM_" ^ Typ.Procname.to_unique_id proc_name);
-  {pv_hash: name_hash name, pv_name: name, pv_kind: Abduced_ref_param proc_name pv loc}
-};
-
-let mk_abduced_ref_param_val (proc_name: Typ.Procname.t) (id: Ident.t) (loc: Location.t) :t => {
-  let name = Mangled.from_string ("$REF_PARAM_VAL_" ^ Typ.Procname.to_unique_id proc_name);
-  {pv_hash: name_hash name, pv_name: name, pv_kind: Abduced_ref_param_val proc_name id loc}
-};
-
-let get_translation_unit pvar =>
-  switch pvar.pv_kind {
-  | Global_var (tu, _, _, _) => tu
-  | _ => invalid_argf "Expected a global variable"
-  };
-
-let is_compile_constant pvar =>
-  switch pvar.pv_kind {
-  | Global_var (_, b, _, _) => b
-  | _ => false
-  };
-
-let is_pod pvar =>
-  switch pvar.pv_kind {
-  | Global_var (_, _, b, _) => b
-  | _ => true
-  };
-
-let get_initializer_pname {pv_name, pv_kind} =>
-  switch pv_kind {
-  | Global_var _ =>
-    Some (
-      Typ.Procname.from_string_c_fun (
-        Config.clang_initializer_prefix ^ Mangled.to_string_full pv_name
-      )
-    )
-  | _ => None
-  };

infer/src/IR/Pvar.rei

@@ -1,176 +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;
-
-
-/** Program variables. */
-module F = Format;
-
-type translation_unit =
-  | TUFile SourceFile.t
-  | TUExtern
-[@@deriving compare];
-
-
-/** Type for program variables. There are 4 kinds of variables:
-        1) local variables, used for local variables and formal parameters
-        2) callee program variables, used to handle recursion ([x | callee] is distinguished from [x])
-        3) global variables
-        4) seed variables, used to store the initial value of formal parameters
-    */
-type t [@@deriving compare];
-
-
-/** Equality for pvar's */
-let equal: t => t => bool;
-
-
-/** Dump a program variable. */
-let d: t => unit;
-
-
-/** Dump a list of program variables. */
-let d_list: list t => unit;
-
-
-/** Get the name component of a program variable. */
-let get_name: t => Mangled.t;
-
-
-/** [get_ret_pvar proc_name] retuns the return pvar associated with the procedure name */
-let get_ret_pvar: Typ.Procname.t => t;
-
-
-/** Get a simplified version of the name component of a program variable. */
-let get_simplified_name: t => string;
-
-
-/** Check if the pvar is an abduced return var or param passed by ref */
-let is_abduced: t => bool;
-
-
-/** Check if the pvar is a callee var */
-let is_callee: t => bool;
-
-
-/** Check if the pvar is a global var or a static local var */
-let is_global: t => bool;
-
-
-/** Check if the pvar is a static variable declared inside a function */
-let is_static_local: t => bool;
-
-
-/** Check if the pvar is a (non-static) local var */
-let is_local: t => bool;
-
-
-/** Check if the pvar is a seed var */
-let is_seed: t => bool;
-
-
-/** Check if the pvar is a return var */
-let is_return: t => bool;
-
-
-/** Check if a pvar is the special "this" var */
-let is_this: t => bool;
-
-
-/** Check if a pvar is the special "self" var */
-let is_self: t => bool;
-
-
-/** return true if [pvar] is a temporary variable generated by the frontend */
-let is_frontend_tmp: t => bool;
-
-
-/** return true if [pvar] is a temporary variable generated by the frontend and is only assigned
-    once on a non-looping control-flow path */
-let is_ssa_frontend_tmp: t => bool;
-
-
-/** [mk name proc_name suffix] creates a program var with the given function name and suffix */
-let mk: Mangled.t => Typ.Procname.t => t;
-
-
-/** create an abduced variable for a parameter passed by reference */
-let mk_abduced_ref_param: Typ.Procname.t => t => Location.t => t;
-
-
-/** create an abduced variable for a parameter passed by reference */
-let mk_abduced_ref_param_val: Typ.Procname.t => Ident.t => Location.t => t;
-
-
-/** create an abduced return variable for a call to [proc_name] at [loc] */
-let mk_abduced_ret: Typ.Procname.t => Location.t => t;
-
-
-/** [mk_callee name proc_name] creates a program var
-    for a callee function with the given function name */
-let mk_callee: Mangled.t => Typ.Procname.t => t;
-
-
-/** create a global variable with the given name */
-let mk_global:
-  is_constexpr::bool? =>
-  is_pod::bool? =>
-  is_static_local::bool? =>
-  Mangled.t =>
-  translation_unit =>
-  t;
-
-
-/** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! */
-let mk_tmp: string => Typ.Procname.t => t;
-
-
-/** Pretty print a program variable. */
-let pp: Pp.env => F.formatter => t => unit;
-
-
-/** Pretty print a list of program variables. */
-let pp_list: Pp.env => F.formatter => list t => unit;
-
-
-/** Pretty print a pvar which denotes a value, not an address */
-let pp_value: Pp.env => F.formatter => t => unit;
-
-let pp_translation_unit: F.formatter => translation_unit => unit;
-
-
-/** Turn an ordinary program variable into a callee program variable */
-let to_callee: Typ.Procname.t => t => t;
-
-
-/** Turn a pvar into a seed pvar (which stores the initial value of a stack var) */
-let to_seed: t => t;
-
-
-/** Convert a pvar to string. */
-let to_string: t => string;
-
-
-/** Get the translation unit corresponding to a global. Raises Invalid_arg if not a global. */
-let get_translation_unit: t => translation_unit;
-
-
-/** Is the variable's value a compile-time constant? Always (potentially incorrectly) returns
-    [false] for non-globals. */
-let is_compile_constant: t => bool;
-
-
-/** Is the variable's type a "Plain Old Data" type (C++)? Always (potentially incorrectly) returns
-    [true] for non-globals. */
-let is_pod: t => bool;
-
-
-/** Get the procname of the initializer function for the given global variable */
-let get_initializer_pname: t => option Typ.Procname.t;

infer/src/IR/QualifiedCppName.ml

@@ -0,0 +1,90 @@
+(*
+ * Copyright (c) 2017 - 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
+
+(* internally it uses reversed list to store qualified name, for example: ["get", "shared_ptr<int>", "std"]*)
+type t = string list [@@deriving compare]
+
+let equal = [%compare.equal : t]
+
+let empty = []
+
+let append_qualifier quals ~qual = List.cons qual quals
+
+let extract_last = function last :: rest -> Some (last, rest) | [] -> None
+
+let strip_template_args quals =
+  let no_template_name s = List.hd_exn (String.split ~on:'<' s) in
+  List.map ~f:no_template_name quals
+
+let append_template_args_to_last quals ~args =
+  match quals with
+  | [last; _] when String.contains last '<'
+   -> failwith "expected qualified name without template args"
+  | last :: rest
+   -> (last ^ args) :: rest
+  | []
+   -> failwith "expected non-empty qualified name"
+
+let to_list = List.rev
+
+let to_rev_list = ident
+
+let of_list = List.rev
+
+let of_rev_list = ident
+
+let cpp_separator = "::"
+
+(* define [cpp_separator_regex] here to compute it once *)
+let cpp_separator_regex = Str.regexp_string cpp_separator
+
+(* This is simplistic and will give the wrong answer in some cases, eg
+   "foo<bar::baz<goo>>::someMethod" will get parsed as ["foo<bar", "baz<goo>>",
+   "someMethod"]. Avoid using it if possible *)
+let of_qual_string str = Str.split cpp_separator_regex str |> List.rev
+
+let to_separated_string quals ~sep = List.rev quals |> String.concat ~sep
+
+let to_qual_string = to_separated_string ~sep:cpp_separator
+
+let pp fmt quals = Format.fprintf fmt "%s" (to_qual_string quals)
+
+module Match = struct
+  type quals_matcher = Str.regexp
+
+  let matching_separator = "#"
+
+  let regexp_string_of_qualifiers quals =
+    Str.quote (to_separated_string ~sep:matching_separator quals) ^ "$"
+
+  let qualifiers_list_matcher quals_list =
+    ( if List.is_empty quals_list then "a^"
+    else
+      (* regexp that does not match anything *)
+      List.map ~f:regexp_string_of_qualifiers quals_list |> String.concat ~sep:"\\|" )
+    |> Str.regexp
+
+  let qualifiers_of_fuzzy_qual_name qual_name =
+    (* Fail if we detect templates in the fuzzy name. Template instantiations are not taken into
+       account when fuzzy matching, and templates may produce wrong results when parsing qualified
+       names. *)
+    if String.contains qual_name '<' then
+      failwithf "Unexpected template in fuzzy qualified name %s." qual_name ;
+    of_qual_string qual_name
+
+  let of_fuzzy_qual_names fuzzy_qual_names =
+    List.map fuzzy_qual_names ~f:qualifiers_of_fuzzy_qual_name |> qualifiers_list_matcher
+
+  let match_qualifiers matcher quals =
+    (* qual_name may have qualifiers with template parameters - drop them to whitelist all
+       instantiations *)
+    let normalized_qualifiers = strip_template_args quals in
+    Str.string_match matcher (to_separated_string ~sep:matching_separator normalized_qualifiers) 0
+end

infer/src/IR/QualifiedCppName.mli

@@ -1,67 +1,68 @@
-/*
+(*
  * Copyright (c) 2017 - 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;
 
-type t [@@deriving compare];
+open! IStd
 
+type t [@@deriving compare]
 
-/** empty qualified name */
+(** empty qualified name *)
-let empty: t;
 
-let equal: t => t => bool;
+val empty : t
 
+val equal : t -> t -> bool
 
-/** attempts to parse the argument into a list::of::possibly::templated<T>::qualifiers */
+(** attempts to parse the argument into a list::of::possibly::templated<T>::qualifiers *)
-let of_qual_string: string => t;
 
+val of_qual_string : string -> t
 
-/** returns qualified name as a string with "::" as a separator between qualifiers */
+(** returns qualified name as a string with "::" as a separator between qualifiers *)
-let to_qual_string: t => string;
 
+val to_qual_string : t -> string
 
-/** append qualifier to the end (innermost scope) of the qualified name */
+(** append qualifier to the end (innermost scope) of the qualified name *)
-let append_qualifier: t => qual::string => t;
 
+val append_qualifier : t -> qual:string -> t
 
-/** returns last (innermost scope) qualifier and qualified name without last qualifier */
+(** returns last (innermost scope) qualifier and qualified name without last qualifier *)
-let extract_last: t => option (string, t);
 
+val extract_last : t -> (string * t) option
 
-/** returns qualified name without template arguments. For example:
+(** returns qualified name without template arguments. For example:
     input: std::shared_ptr<int>::shared_ptr<long>
-    output: std::shared_ptr::shared_ptr */
+    output: std::shared_ptr::shared_ptr *)
-let strip_template_args: t => t;
 
+val strip_template_args : t -> t
 
-/** append template arguments to the last qualifier. Fails if qualified name is empty or it already has
+(** append template arguments to the last qualifier. Fails if qualified name is empty or it already has
-    template args */
+    template args *)
-let append_template_args_to_last: t => args::string => t;
 
+val append_template_args_to_last : t -> args:string -> t
 
-/** returns list of qualifers */
+(** returns list of qualifers *)
-let to_list: t => list string;
 
+val to_list : t -> string list
 
-/** returns reversed list of qualifiers, ie innermost scope is the first element */
+(** returns reversed list of qualifiers, ie innermost scope is the first element *)
-let to_rev_list: t => list string;
 
+val to_rev_list : t -> string list
 
-/** given list of qualifiers in normal order produce qualified name ["std", "move"] */
+(** given list of qualifiers in normal order produce qualified name ["std", "move"] *)
-let of_list: list string => t;
 
+val of_list : string list -> t
 
-/** given reversed list of qualifiers, produce qualified name (ie. ["move", "std"] for std::move )*/
+(** given reversed list of qualifiers, produce qualified name (ie. ["move", "std"] for std::move )*)
-let of_rev_list: list string => t;
 
-let pp: Format.formatter => t => unit;
+val of_rev_list : string list -> t
 
-/* Module to match qualified C++ procnames "fuzzily", that is up to namescapes and templating. In
+val pp : Format.formatter -> t -> unit
+
+(* Module to match qualified C++ procnames "fuzzily", that is up to namescapes and templating. In
     particular, this deals with the following issues:
 
     1. 'std::' namespace may have inline namespace afterwards: std::move becomes std::__1::move. This
@@ -87,9 +88,12 @@ let pp: Format.formatter => t => unit;
        does not match: ["folly", "BAD", "someFunction"] - unlike 'std' any other namespace needs all
                                                           qualifiers to match
        does not match: ["folly","someFunction<int>", "BAD"] - same as previous example
-   */
+   *)
-module Match: {
+
-  type quals_matcher;
+module Match : sig
-  let of_fuzzy_qual_names: list string => quals_matcher;
+  type quals_matcher
-  let match_qualifiers: quals_matcher => t => bool;
+
-};
+  val of_fuzzy_qual_names : string list -> quals_matcher
+
+  val match_qualifiers : quals_matcher -> t -> bool
+end

infer/src/IR/QualifiedCppName.re

@@ -1,92 +0,0 @@
-/*
- * Copyright (c) 2017 - 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;
-
-/* internally it uses reversed list to store qualified name, for example: ["get", "shared_ptr<int>", "std"]*/
-type t = list string [@@deriving compare];
-
-let equal = [%compare.equal : t];
-
-let empty = [];
-
-let append_qualifier quals ::qual => List.cons qual quals;
-
-let extract_last =
-  fun
-  | [last, ...rest] => Some (last, rest)
-  | [] => None;
-
-let strip_template_args quals => {
-  let no_template_name s => List.hd_exn (String.split on::'<' s);
-  List.map f::no_template_name quals
-};
-
-let append_template_args_to_last quals ::args =>
-  switch quals {
-  | [last, _] when String.contains last '<' =>
-    failwith "expected qualified name without template args"
-  | [last, ...rest] => [last ^ args, ...rest]
-  | [] => failwith "expected non-empty qualified name"
-  };
-
-let to_list = List.rev;
-
-let to_rev_list = ident;
-
-let of_list = List.rev;
-
-let of_rev_list = ident;
-
-let cpp_separator = "::";
-
-/* define [cpp_separator_regex] here to compute it once */
-let cpp_separator_regex = Str.regexp_string cpp_separator;
-
-/* This is simplistic and will give the wrong answer in some cases, eg
-   "foo<bar::baz<goo>>::someMethod" will get parsed as ["foo<bar", "baz<goo>>",
-   "someMethod"]. Avoid using it if possible */
-let of_qual_string str => Str.split cpp_separator_regex str |> List.rev;
-
-let to_separated_string quals ::sep => List.rev quals |> String.concat ::sep;
-
-let to_qual_string = to_separated_string sep::cpp_separator;
-
-let pp fmt quals => Format.fprintf fmt "%s" (to_qual_string quals);
-
-module Match = {
-  type quals_matcher = Str.regexp;
-  let matching_separator = "#";
-  let regexp_string_of_qualifiers quals =>
-    Str.quote (to_separated_string sep::matching_separator quals) ^ "$";
-  let qualifiers_list_matcher quals_list =>
-    (
-      if (List.is_empty quals_list) {
-        "a^" /* regexp that does not match anything */
-      } else {
-        List.map f::regexp_string_of_qualifiers quals_list |> String.concat sep::"\\|"
-      }
-    ) |> Str.regexp;
-  let qualifiers_of_fuzzy_qual_name qual_name => {
-    /* Fail if we detect templates in the fuzzy name. Template instantiations are not taken into
-       account when fuzzy matching, and templates may produce wrong results when parsing qualified
-       names. */
-    if (String.contains qual_name '<') {
-      failwithf "Unexpected template in fuzzy qualified name %s." qual_name
-    };
-    of_qual_string qual_name
-  };
-  let of_fuzzy_qual_names fuzzy_qual_names =>
-    List.map fuzzy_qual_names f::qualifiers_of_fuzzy_qual_name |> qualifiers_list_matcher;
-  let match_qualifiers matcher quals => {
-    /* qual_name may have qualifiers with template parameters - drop them to whitelist all
-       instantiations */
-    let normalized_qualifiers = strip_template_args quals;
-    Str.string_match matcher (to_separated_string sep::matching_separator normalized_qualifiers) 0
-  };
-};

infer/src/IR/README.md

@@ -2,11 +2,11 @@
 
 The Intermediate Representation is a format used by the back-end for analysis. It is produced by one of the front-ends, one for each program analyzed.
 
-The main entry point is the intermediate language in [Sil](Sil.rei).
+The main entry point is the intermediate language in [Sil](Sil.mli).
 
-The control flow graph module is [Cfg](Cfg.rei).
+The control flow graph module is [Cfg](Cfg.mli).
 
-The call graph module is [Cg](Cg.rei).
+The call graph module is [Cg](Cg.mli).
 
-The type environment module is [Tenv](Tenv.rei).
+The type environment module is [Tenv](Tenv.mli).