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: 3bd2786master
Josh Berdine
8 years ago
committed by
Facebook Github Bot
parent
bf2a0cfc53
commit
bab3d81cb0
@ -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
|
||||
@ -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
|
||||
@ -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];
|
||||
};
|
||||
@ -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;
|
||||
};
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
}
|
||||
};
|
||||
@ -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;
|
||||
@ -0,0 +1,134 @@
|
||||
(*
|
||||
* Copyright (c) 2009 - 2013 Monoidics ltd.
|
||||
* Copyright (c) 2013 - present Facebook, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* This source code is licensed under the BSD style license found in the
|
||||
* LICENSE file in the root directory of this source tree. An additional grant
|
||||
* of patent rights can be found in the PATENTS file in the same directory.
|
||||
*)
|
||||
|
||||
(** The Smallfoot Intermediate Language: Binary Operators *)
|
||||
open! IStd
|
||||
module L = Logging
|
||||
module F = Format
|
||||
|
||||
(** Binary operations *)
|
||||
type t =
|
||||
| PlusA (** arithmetic + *)
|
||||
| PlusPI (** pointer + integer *)
|
||||
| MinusA (** arithmetic - *)
|
||||
| MinusPI (** pointer - integer *)
|
||||
| MinusPP (** pointer - pointer *)
|
||||
| Mult (** * *)
|
||||
| Div (** / *)
|
||||
| Mod (** % *)
|
||||
| Shiftlt (** shift left *)
|
||||
| Shiftrt (** shift right *)
|
||||
| Lt (** < (arithmetic comparison) *)
|
||||
| Gt (** > (arithmetic comparison) *)
|
||||
| Le (** <= (arithmetic comparison) *)
|
||||
| Ge (** >= (arithmetic comparison) *)
|
||||
| Eq (** == (arithmetic comparison) *)
|
||||
| Ne (** != (arithmetic comparison) *)
|
||||
| BAnd (** bitwise and *)
|
||||
| BXor (** exclusive-or *)
|
||||
| BOr (** inclusive-or *)
|
||||
| LAnd (** logical and. Does not always evaluate both operands. *)
|
||||
| LOr (** logical or. Does not always evaluate both operands. *)
|
||||
[@@deriving compare]
|
||||
|
||||
let equal = [%compare.equal : t]
|
||||
|
||||
(** This function returns true if the operation is injective
|
||||
wrt. each argument: op(e,-) and op(-, e) is injective for all e.
|
||||
The return value false means "don't know". *)
|
||||
let injective = function PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false
|
||||
|
||||
(** This function returns true if the operation can be inverted. *)
|
||||
let invertible = function PlusA | PlusPI | MinusA | MinusPI -> true | _ -> false
|
||||
|
||||
(** This function inverts an invertible injective binary operator.
|
||||
If the [binop] operation is not invertible, the function raises Assert_failure. *)
|
||||
let invert bop =
|
||||
match bop with
|
||||
| PlusA
|
||||
-> MinusA
|
||||
| PlusPI
|
||||
-> MinusPI
|
||||
| MinusA
|
||||
-> PlusA
|
||||
| MinusPI
|
||||
-> PlusPI
|
||||
| _
|
||||
-> assert false
|
||||
|
||||
(** This function returns true if 0 is the right unit of [binop].
|
||||
The return value false means "don't know". *)
|
||||
let is_zero_runit = function PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false
|
||||
|
||||
let text = function
|
||||
| PlusA
|
||||
-> "+"
|
||||
| PlusPI
|
||||
-> "+"
|
||||
| MinusA | MinusPP
|
||||
-> "-"
|
||||
| MinusPI
|
||||
-> "-"
|
||||
| Mult
|
||||
-> "*"
|
||||
| Div
|
||||
-> "/"
|
||||
| Mod
|
||||
-> "%"
|
||||
| Shiftlt
|
||||
-> "<<"
|
||||
| Shiftrt
|
||||
-> ">>"
|
||||
| Lt
|
||||
-> "<"
|
||||
| Gt
|
||||
-> ">"
|
||||
| Le
|
||||
-> "<="
|
||||
| Ge
|
||||
-> ">="
|
||||
| Eq
|
||||
-> "=="
|
||||
| Ne
|
||||
-> "!="
|
||||
| BAnd
|
||||
-> "&"
|
||||
| BXor
|
||||
-> "^"
|
||||
| BOr
|
||||
-> "|"
|
||||
| LAnd
|
||||
-> "&&"
|
||||
| LOr
|
||||
-> "||"
|
||||
|
||||
(** Pretty print a binary operator. *)
|
||||
let str pe binop =
|
||||
match pe.Pp.kind with
|
||||
| HTML -> (
|
||||
match binop with
|
||||
| Ge
|
||||
-> " >= "
|
||||
| Le
|
||||
-> " <= "
|
||||
| Gt
|
||||
-> " > "
|
||||
| Lt
|
||||
-> " < "
|
||||
| Shiftlt
|
||||
-> " << "
|
||||
| Shiftrt
|
||||
-> " >> "
|
||||
| _
|
||||
-> text binop )
|
||||
| LATEX -> (
|
||||
match binop with Ge -> " \\geq " | Le -> " \\leq " | _ -> text binop )
|
||||
| _
|
||||
-> text binop
|
||||
@ -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
|
||||
@ -1,138 +0,0 @@
|
||||
/*
|
||||
* Copyright (c) 2009 - 2013 Monoidics ltd.
|
||||
* Copyright (c) 2013 - present Facebook, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* This source code is licensed under the BSD style license found in the
|
||||
* LICENSE file in the root directory of this source tree. An additional grant
|
||||
* of patent rights can be found in the PATENTS file in the same directory.
|
||||
*/
|
||||
open! IStd;
|
||||
|
||||
|
||||
/** The Smallfoot Intermediate Language: Binary Operators */
|
||||
module L = Logging;
|
||||
|
||||
module F = Format;
|
||||
|
||||
|
||||
/** Binary operations */
|
||||
type t =
|
||||
| PlusA /** arithmetic + */
|
||||
| PlusPI /** pointer + integer */
|
||||
| MinusA /** arithmetic - */
|
||||
| MinusPI /** pointer - integer */
|
||||
| MinusPP /** pointer - pointer */
|
||||
| Mult /** * */
|
||||
| Div /** / */
|
||||
| Mod /** % */
|
||||
| Shiftlt /** shift left */
|
||||
| Shiftrt /** shift right */
|
||||
| Lt /** < (arithmetic comparison) */
|
||||
| Gt /** > (arithmetic comparison) */
|
||||
| Le /** <= (arithmetic comparison) */
|
||||
| Ge /** >= (arithmetic comparison) */
|
||||
| Eq /** == (arithmetic comparison) */
|
||||
| Ne /** != (arithmetic comparison) */
|
||||
| BAnd /** bitwise and */
|
||||
| BXor /** exclusive-or */
|
||||
| BOr /** inclusive-or */
|
||||
| LAnd /** logical and. Does not always evaluate both operands. */
|
||||
| LOr /** logical or. Does not always evaluate both operands. */
|
||||
[@@deriving compare];
|
||||
|
||||
let equal = [%compare.equal : t];
|
||||
|
||||
|
||||
/** This function returns true if the operation is injective
|
||||
wrt. each argument: op(e,-) and op(-, e) is injective for all e.
|
||||
The return value false means "don't know". */
|
||||
let injective =
|
||||
fun
|
||||
| PlusA
|
||||
| PlusPI
|
||||
| MinusA
|
||||
| MinusPI
|
||||
| MinusPP => true
|
||||
| _ => false;
|
||||
|
||||
|
||||
/** This function returns true if the operation can be inverted. */
|
||||
let invertible =
|
||||
fun
|
||||
| PlusA
|
||||
| PlusPI
|
||||
| MinusA
|
||||
| MinusPI => true
|
||||
| _ => false;
|
||||
|
||||
|
||||
/** This function inverts an invertible injective binary operator.
|
||||
If the [binop] operation is not invertible, the function raises Assert_failure. */
|
||||
let invert bop =>
|
||||
switch bop {
|
||||
| PlusA => MinusA
|
||||
| PlusPI => MinusPI
|
||||
| MinusA => PlusA
|
||||
| MinusPI => PlusPI
|
||||
| _ => assert false
|
||||
};
|
||||
|
||||
|
||||
/** This function returns true if 0 is the right unit of [binop].
|
||||
The return value false means "don't know". */
|
||||
let is_zero_runit =
|
||||
fun
|
||||
| PlusA
|
||||
| PlusPI
|
||||
| MinusA
|
||||
| MinusPI
|
||||
| MinusPP => true
|
||||
| _ => false;
|
||||
|
||||
let text =
|
||||
fun
|
||||
| PlusA => "+"
|
||||
| PlusPI => "+"
|
||||
| MinusA
|
||||
| MinusPP => "-"
|
||||
| MinusPI => "-"
|
||||
| Mult => "*"
|
||||
| Div => "/"
|
||||
| Mod => "%"
|
||||
| Shiftlt => "<<"
|
||||
| Shiftrt => ">>"
|
||||
| Lt => "<"
|
||||
| Gt => ">"
|
||||
| Le => "<="
|
||||
| Ge => ">="
|
||||
| Eq => "=="
|
||||
| Ne => "!="
|
||||
| BAnd => "&"
|
||||
| BXor => "^"
|
||||
| BOr => "|"
|
||||
| LAnd => "&&"
|
||||
| LOr => "||";
|
||||
|
||||
|
||||
/** Pretty print a binary operator. */
|
||||
let str pe binop =>
|
||||
switch pe.Pp.kind {
|
||||
| HTML =>
|
||||
switch binop {
|
||||
| Ge => " >= "
|
||||
| Le => " <= "
|
||||
| Gt => " > "
|
||||
| Lt => " < "
|
||||
| Shiftlt => " << "
|
||||
| Shiftrt => " >> "
|
||||
| _ => text binop
|
||||
}
|
||||
| LATEX =>
|
||||
switch binop {
|
||||
| Ge => " \\geq "
|
||||
| Le => " \\leq "
|
||||
| _ => text binop
|
||||
}
|
||||
| _ => text binop
|
||||
};
|
||||
@ -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;
|
||||
@ -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= [] }
|
||||
@ -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
|
||||
@ -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: []
|
||||
};
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
};
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
};
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
};
|
||||
@ -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;
|
||||
@ -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)
|
||||
@ -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
|
||||
@ -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;
|
||||
};
|
||||
@ -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;
|
||||
@ -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)
|
||||
@ -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
|
||||
@ -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);
|
||||
@ -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;
|
||||
@ -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__ }
|
||||
@ -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
|
||||
@ -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__
|
||||
};
|
||||
@ -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;
|
||||
@ -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"
|
||||
@ -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
|
||||
@ -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"
|
||||
};
|
||||
@ -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;
|
||||
@ -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 -> "&" | 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
|
||||
@ -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
|
||||
@ -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 => "&"
|
||||
| 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
|
||||
};
|
||||
@ -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;
|
||||
@ -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
|
||||
@ -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
|
||||
};
|
||||
};
|
||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue