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

ppx_compare PredSymb

Browse Source 
Reviewed By: cristianoc

Differential Revision: D4232393

fbshipit-source-id: 384182b
master
Josh Berdine 8 years ago committed by Facebook Github Bot
parent 71ed8c9e1d
commit 6298d043e6
6 changed files with 58 additions and 158 deletions
Show Stats Download Patch File Download Diff File

165
infer/src/IR/PredSymb.re
Unescape View File

@ -43,7 +43,8 @@ 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 */;
| Mobjc /** memory allocated with objective-c alloc */
[@@deriving compare];
let mem_kind_to_num =
fun
@ -52,39 +53,21 @@ let mem_kind_to_num =
| Mnew_array => 2
| Mobjc => 3;
let mem_kind_compare mk1 mk2 => int_compare (mem_kind_to_num mk1) (mem_kind_to_num mk2);
/** resource that can be allocated */
type resource =
| Rmemory mem_kind
| Rfile
| Rignore
| Rlock;
let resource_compare r1 r2 => {
let res_to_num =
fun
| Rmemory mk => mem_kind_to_num mk
| Rfile => 100
| Rignore => 200
| Rlock => 300;
int_compare (res_to_num r1) (res_to_num r2)
};
| Rlock
[@@deriving compare];
/** kind of resource action */
type res_act_kind =
| Racquire
| Rrelease;
let res_act_kind_compare rak1 rak2 =>
switch (rak1, rak2) {
| (Racquire, Racquire) => 0
| (Racquire, Rrelease) => (-1)
| (Rrelease, Racquire) => 1
| (Rrelease, Rrelease) => 0
};
| Rrelease
[@@deriving compare];
/** kind of dangling pointers */
@ -95,62 +78,24 @@ type dangling_kind =
of a stack variable which went out of scope */
| DAaddr_stack_var
/** pointer is -1 */
| DAminusone;
let dangling_kind_compare dk1 dk2 =>
switch (dk1, dk2) {
| (DAuninit, DAuninit) => 0
| (DAuninit, _) => (-1)
| (_, DAuninit) => 1
| (DAaddr_stack_var, DAaddr_stack_var) => 0
| (DAaddr_stack_var, _) => (-1)
| (_, DAaddr_stack_var) => 1
| (DAminusone, DAminusone) => 0
};
| DAminusone
[@@deriving compare];
/** position in a path: proc name, node id */
type path_pos = (Procname.t, int);
let path_pos_compare (pn1, nid1) (pn2, nid2) => {
let n = Procname.compare pn1 pn2;
if (n != 0) {
n
} else {
int_compare nid1 nid2
}
};
type path_pos = (Procname.t, int) [@@deriving compare];
let path_pos_equal pp1 pp2 => path_pos_compare pp1 pp2 == 0;
let equal_path_pos pp1 pp2 => compare_path_pos pp1 pp2 == 0;
type taint_kind =
| Tk_unverified_SSL_socket
| Tk_shared_preferences_data
| Tk_privacy_annotation
| Tk_integrity_annotation
| Tk_unknown;
let taint_kind_compare tk1 tk2 =>
switch (tk1, tk2) {
| (Tk_unverified_SSL_socket, Tk_unverified_SSL_socket) => 0
| (Tk_unverified_SSL_socket, _) => (-1)
| (_, Tk_unverified_SSL_socket) => 1
| (Tk_shared_preferences_data, Tk_shared_preferences_data) => 0
| (Tk_shared_preferences_data, _) => 1
| (_, Tk_shared_preferences_data) => (-1)
| (Tk_privacy_annotation, Tk_privacy_annotation) => 0
| (Tk_privacy_annotation, _) => 1
| (_, Tk_privacy_annotation) => (-1)
| (Tk_integrity_annotation, Tk_integrity_annotation) => 0
| (Tk_integrity_annotation, _) => 1
| (_, Tk_integrity_annotation) => (-1)
| (Tk_unknown, Tk_unknown) => 0
};
type taint_info = {taint_source: Procname.t, taint_kind: taint_kind};
| Tk_unknown
[@@deriving compare];
let taint_info_compare {taint_source: ts1, taint_kind: tk1} {taint_source: ts2, taint_kind: tk2} =>
taint_kind_compare tk1 tk2 |> next Procname.compare ts1 ts2;
type taint_info = {taint_source: Procname.t, taint_kind: taint_kind} [@@deriving compare];
/** acquire/release action on a resource */
@ -162,6 +107,23 @@ type res_action = {
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
@ -176,7 +138,7 @@ type t =
| Aautorelease
| Adangling dangling_kind /** dangling pointer */
/** undefined value obtained by calling the given procedure, plus its return value annots */
| Aundef Procname.t Annot.Item.t Location.t path_pos
| Aundef Procname.t _annot_item _location _path_pos
| Ataint taint_info
| Auntaint taint_info
| Alocked
@ -190,62 +152,8 @@ type 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;
let compare (att1: t) (att2: t) :int =>
switch (att1, att2) {
| (Aresource ra1, Aresource ra2) =>
let n = res_act_kind_compare ra1.ra_kind ra2.ra_kind;
if (n != 0) {
n
} else {
/* ignore other values beside resources: arbitrary merging into one */
resource_compare
ra1.ra_res ra2.ra_res
}
| (Aresource _, _) => (-1)
| (_, Aresource _) => 1
| (Aautorelease, Aautorelease) => 0
| (Aautorelease, _) => (-1)
| (_, Aautorelease) => 1
| (Adangling dk1, Adangling dk2) => dangling_kind_compare dk1 dk2
| (Adangling _, _) => (-1)
| (_, Adangling _) => 1
| (Aundef pn1 _ _ _, Aundef pn2 _ _ _) => Procname.compare pn1 pn2
| (Ataint ti1, Ataint ti2) => taint_info_compare ti1 ti2
| (Ataint _, _) => (-1)
| (_, Ataint _) => 1
| (Auntaint ti1, Auntaint ti2) => taint_info_compare ti1 ti2
| (Auntaint _, _) => (-1)
| (_, Auntaint _) => 1
| (Alocked, Alocked) => 0
| (Alocked, _) => (-1)
| (_, Alocked) => 1
| (Aunlocked, Aunlocked) => 0
| (Aunlocked, _) => (-1)
| (_, Aunlocked) => 1
| (Adiv0 pp1, Adiv0 pp2) => path_pos_compare pp1 pp2
| (Adiv0 _, _) => (-1)
| (_, Adiv0 _) => 1
| (Aobjc_null, Aobjc_null) => 0
| (Aobjc_null, _) => (-1)
| (_, Aobjc_null) => 1
| (Aretval pn1 annots1, Aretval pn2 annots2) =>
let n = Procname.compare pn1 pn2;
if (n != 0) {
n
} else {
Annot.Item.compare annots1 annots2
}
| (Aretval _, _) => (-1)
| (_, Aretval _) => 1
| (Aobserver, Aobserver) => 0
| (Aobserver, _) => (-1)
| (_, Aobserver) => 1
| (Aunsubscribed_observer, Aunsubscribed_observer) => 0
| (Aunsubscribed_observer, _) => (-1)
| (_, Aunsubscribed_observer) => 1
};
| Aunsubscribed_observer
[@@deriving compare];
let equal att1 att2 => compare att1 att2 == 0;
@ -278,11 +186,10 @@ type category =
| ACobjc_null
| ACundef
| ACretval
| ACobserver;
let category_compare (ac1: category) (ac2: category) :int => Pervasives.compare ac1 ac2;
| ACobserver
[@@deriving compare];
let category_equal att1 att2 => category_compare att1 att2 == 0;
let equal_category att1 att2 => compare_category att1 att2 == 0;
let to_category att =>
switch att {

33
infer/src/IR/PredSymb.rei
Unescape View File

@ -41,9 +41,8 @@ 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 */;
let mem_kind_compare: mem_kind => mem_kind => int;
| Mobjc /** memory allocated with objective-c alloc */
[@@deriving compare];
/** resource that can be allocated */
@ -51,17 +50,15 @@ type resource =
| Rmemory mem_kind
| Rfile
| Rignore
| Rlock;
let resource_compare: resource => resource => int;
| Rlock
[@@deriving compare];
/** kind of resource action */
type res_act_kind =
| Racquire
| Rrelease;
let res_act_kind_compare: res_act_kind => res_act_kind => int;
| Rrelease
[@@deriving compare];
/** kind of dangling pointers */
@ -75,11 +72,9 @@ type dangling_kind =
/** position in a path: proc name, node id */
type path_pos = (Procname.t, int);
type path_pos = (Procname.t, int) [@@deriving compare];
let path_pos_compare: path_pos => path_pos => int;
let path_pos_equal: path_pos => path_pos => bool;
let equal_path_pos: path_pos => path_pos => bool;
type taint_kind =
| Tk_unverified_SSL_socket
@ -128,9 +123,8 @@ type 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;
let compare: t => t => int;
| Aunsubscribed_observer
[@@deriving compare];
let equal: t => t => bool;
@ -153,11 +147,10 @@ type category =
| ACobjc_null
| ACundef
| ACretval
| ACobserver;
let category_compare: category => category => int;
| ACobserver
[@@deriving compare];
let category_equal: category => category => bool;
let equal_category: category => category => bool;
/** Return the category to which the attribute belongs. */

4
infer/src/IR/Sil.re
Unescape View File

@ -334,7 +334,7 @@ let inst_compare_base inst1 inst2 =>
if (n != 0) {
n
} else {
PredSymb.path_pos_compare path_pos1 path_pos2
PredSymb.compare_path_pos path_pos1 path_pos2
}
}
}
@ -359,7 +359,7 @@ let inst_compare_base inst1 inst2 =>
if (n != 0) {
n
} else {
PredSymb.path_pos_compare path_pos1 path_pos2
PredSymb.compare_path_pos path_pos1 path_pos2
}
}
}

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

@ -30,7 +30,7 @@ let add tenv ?(footprint = false) ?(polarity = true) prop attr args =
let attributes_in_same_category attr1 attr2 =
let cat1 = PredSymb.to_category attr1 in
let cat2 = PredSymb.to_category attr2 in
PredSymb.category_equal cat1 cat2
PredSymb.equal_category cat1 cat2
(** Replace an attribute associated to the expression *)
let add_or_replace_check_changed tenv check_attribute_change prop atom0 =
@ -88,7 +88,7 @@ let get tenv prop exp category =
Some
(IList.find (function
| Sil.Apred (att, _) | Anpred (att, _) ->
PredSymb.category_equal (PredSymb.to_category att) category
PredSymb.equal_category (PredSymb.to_category att) category
| _ -> false
) atts)
with Not_found -> None
@ -150,8 +150,8 @@ let remove_for_attr tenv prop att0 =
let remove_resource tenv ra_kind ra_res =
let f = function
| Sil.Apred (Aresource res_action, _) ->
PredSymb.res_act_kind_compare res_action.ra_kind ra_kind <> 0
|| PredSymb.resource_compare res_action.ra_res ra_res <> 0
PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0
|| PredSymb.compare_resource res_action.ra_res ra_res <> 0
| _ -> true in
filter_atoms tenv ~f

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

@ -275,7 +275,7 @@ end = struct
let contains_position path pos =
let found = ref false in
let f node =
if PredSymb.path_pos_equal (get_path_pos node) pos then found := true;
if PredSymb.equal_path_pos (get_path_pos node) pos then found := true;
true in
Invariant.compute_stats true f path;
Invariant.reset_stats path;
@ -318,7 +318,7 @@ end = struct
(pos_opt : PredSymb.path_pos option) (path: t) : unit =
let filter node = match pos_opt with
| None -> true
| Some pos -> PredSymb.path_pos_equal (get_path_pos node) pos in
| Some pos -> PredSymb.equal_path_pos (get_path_pos node) pos in
let path_pos_at_path p =
try
match curr_node p with

2
infer/src/backend/tabulation.ml
Unescape View File

@ -590,7 +590,7 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv
let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
| PredSymb.Aresource ({ ra_kind = Racquire; ra_res = Rmemory mk_old } as ra_old),
PredSymb.Aresource ({ ra_kind = Rrelease; ra_res = Rmemory mk_new } as ra_new)
when PredSymb.mem_kind_compare mk_old mk_new <> 0 ->
when PredSymb.compare_mem_kind mk_old mk_new <> 0 ->
let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in
raise (Exceptions.Deallocation_mismatch (desc, __POS__))
| _ -> ()

Write Preview
Loading…
Cancel
Save