diff --git a/infer/src/IR/PredSymb.re b/infer/src/IR/PredSymb.re index 53204694f..4683bb9dc 100644 --- a/infer/src/IR/PredSymb.re +++ b/infer/src/IR/PredSymb.re @@ -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 { diff --git a/infer/src/IR/PredSymb.rei b/infer/src/IR/PredSymb.rei index bcc264b52..1d1098ddb 100644 --- a/infer/src/IR/PredSymb.rei +++ b/infer/src/IR/PredSymb.rei @@ -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. */ diff --git a/infer/src/IR/Sil.re b/infer/src/IR/Sil.re index 91df934cb..ae1995fb1 100644 --- a/infer/src/IR/Sil.re +++ b/infer/src/IR/Sil.re @@ -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 } } } diff --git a/infer/src/backend/Attribute.ml b/infer/src/backend/Attribute.ml index 176457f6d..c68fab377 100644 --- a/infer/src/backend/Attribute.ml +++ b/infer/src/backend/Attribute.ml @@ -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 diff --git a/infer/src/backend/paths.ml b/infer/src/backend/paths.ml index b902b07b8..0b902d341 100644 --- a/infer/src/backend/paths.ml +++ b/infer/src/backend/paths.ml @@ -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 diff --git a/infer/src/backend/tabulation.ml b/infer/src/backend/tabulation.ml index 2fe5b89c6..881987fb5 100644 --- a/infer/src/backend/tabulation.ml +++ b/infer/src/backend/tabulation.ml @@ -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__)) | _ -> ()