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

[absint] make Set and Map functors take an ordered type

Browse Source 
Reviewed By: jeremydubreil

Differential Revision: D5080742

fbshipit-source-id: 19245a8
master
Sam Blackshear 8 years ago committed by Facebook Github Bot
parent 7c1a01b186
commit 32ead76a3b
26 changed files with 229 additions and 318 deletions
Show Stats Download Patch File Download Diff File

11
infer/src/IR/Pvar.re
Unescape View File

@ -36,9 +36,6 @@ type pvar_kind =
/** Names for program variables. */ /** Names for program variables. */
and t = {pv_hash: int, pv_name: Mangled.t, pv_kind: pvar_kind} [@@deriving compare]; and t = {pv_hash: int, pv_name: Mangled.t, pv_kind: pvar_kind} [@@deriving compare];
let compare_alpha pv1 pv2 =>
[%compare : (Mangled.t, pvar_kind)] (pv1.pv_name, pv1.pv_kind) (pv2.pv_name, pv2.pv_kind);
let equal = [%compare.equal : t]; let equal = [%compare.equal : t];
let pp_translation_unit fmt => let pp_translation_unit fmt =>
@ -384,11 +381,3 @@ let get_initializer_pname {pv_name, pv_kind} =>
) )
| _ => None | _ => None
}; };
module Set =
PrettyPrintable.MakePPCompareSet {
type nonrec t = t;
let compare = compare;
let compare_pp = compare_alpha;
let pp = pp Pp.text;
};

6
infer/src/IR/Pvar.rei
Unescape View File

@ -32,10 +32,6 @@ type t [@@deriving compare];
let equal: t => t => bool; let equal: t => t => bool;
/** Compare two pvar's in alphabetical order */
let compare_alpha: t => t => int;
/** Dump a program variable. */ /** Dump a program variable. */
let d: t => unit; let d: t => unit;
@ -174,5 +170,3 @@ let is_pod: t => bool;
/** Get the procname of the initializer function for the given global variable */ /** Get the procname of the initializer function for the given global variable */
let get_initializer_pname: t => option Typ.Procname.t; let get_initializer_pname: t => option Typ.Procname.t;
module Set: PrettyPrintable.PPSet with type elt = t;

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

@ -95,7 +95,7 @@ module BackwardCfg = ProcCfg.OneInstrPerNode(ProcCfg.Backward(ProcCfg.Exceptiona
module LivenessAnalysis = AbstractInterpreter.Make (BackwardCfg) (Liveness.TransferFunctions) module LivenessAnalysis = AbstractInterpreter.Make (BackwardCfg) (Liveness.TransferFunctions)
module VarDomain = AbstractDomain.FiniteSet(Var.Set) module VarDomain = Liveness.Domain
(** computes the non-nullified reaching definitions at the end of each node by building on the (** computes the non-nullified reaching definitions at the end of each node by building on the
results of a liveness analysis to be precise, what we want to compute is: results of a liveness analysis to be precise, what we want to compute is:
@ -208,7 +208,7 @@ let add_nullify_instrs pdesc tenv liveness_inv_map =
match NullifyAnalysis.extract_post (ProcCfg.Exceptional.id node) nullify_inv_map with match NullifyAnalysis.extract_post (ProcCfg.Exceptional.id node) nullify_inv_map with
| Some (_, to_nullify) -> | Some (_, to_nullify) ->
let pvars_to_nullify, ids_to_remove = let pvars_to_nullify, ids_to_remove =
Var.Set.fold VarDomain.fold
(fun var (pvars_acc, ids_acc) -> match Var.to_exp var with (fun var (pvars_acc, ids_acc) -> match Var.to_exp var with
(* we nullify all address taken variables at the end of the procedure *) (* we nullify all address taken variables at the end of the procedure *)
| Exp.Lvar pvar when not (AddressTaken.Domain.mem pvar address_taken_vars) -> | Exp.Lvar pvar when not (AddressTaken.Domain.mem pvar address_taken_vars) ->

11
infer/src/base/PrettyPrintable.ml
Unescape View File

@ -48,17 +48,6 @@ module MakePPSet (Ord : PrintableOrderedType) = struct
pp_collection ~pp_item:pp_element fmt (elements s) pp_collection ~pp_item:pp_element fmt (elements s)
end end
module MakePPCompareSet
(Ord : sig include PrintableOrderedType val compare_pp : t -> t -> int end) = struct
include Caml.Set.Make(Ord)
let pp_element = Ord.pp
let pp fmt s =
let elements_alpha = List.sort ~cmp:Ord.compare_pp (elements s) in
pp_collection ~pp_item:pp_element fmt elements_alpha
end
module MakePPMap (Ord : PrintableOrderedType) = struct module MakePPMap (Ord : PrintableOrderedType) = struct
include Caml.Map.Make(Ord) include Caml.Map.Make(Ord)

8
infer/src/base/PrettyPrintable.mli
Unescape View File

@ -35,12 +35,4 @@ end
module MakePPSet (Ord : PrintableOrderedType) : (PPSet with type elt = Ord.t) module MakePPSet (Ord : PrintableOrderedType) : (PPSet with type elt = Ord.t)
(** Use a comparison function to determine the order of the elements printed *)
module MakePPCompareSet
(Ord : sig
include PrintableOrderedType
val compare_pp : t -> t -> int
end)
: (PPSet with type elt = Ord.t)
module MakePPMap (Ord : PrintableOrderedType) : (PPMap with type key = Ord.t) module MakePPMap (Ord : PrintableOrderedType) : (PPMap with type key = Ord.t)

16
infer/src/bufferoverrun/absLoc.ml
Unescape View File

@ -26,16 +26,16 @@ struct
| Allocsite of Allocsite.t | Allocsite of Allocsite.t
| Field of t * Fieldname.t | Field of t * Fieldname.t
| Unknown | Unknown
[@@deriving compare] [@@deriving compare]
let unknown = Unknown let unknown = Unknown
let rec pp fmt = function let rec pp fmt = function
| Var v -> | Var v ->
Var.pp F.str_formatter v; Var.pp F.str_formatter v;
let s = F.flush_str_formatter () in let s = F.flush_str_formatter () in
if s.[0] = '&' then if s.[0] = '&' then
F.fprintf fmt "%s" (String.sub s 1 (String.length s - 1)) F.fprintf fmt "%s" (String.sub s 1 (String.length s - 1))
else F.fprintf fmt "%s" s else F.fprintf fmt "%s" s
| Allocsite a -> Allocsite.pp fmt a | Allocsite a -> Allocsite.pp fmt a
| Field (l, f) -> F.fprintf fmt "%a.%a" pp l Fieldname.pp f | Field (l, f) -> F.fprintf fmt "%a.%a" pp l Fieldname.pp f
| Unknown -> F.fprintf fmt "Unknown" | Unknown -> F.fprintf fmt "Unknown"
@ -51,13 +51,13 @@ struct
let is_return = function let is_return = function
| Var (Var.ProgramVar x) -> | Var (Var.ProgramVar x) ->
Mangled.equal (Pvar.get_name x) Ident.name_return Mangled.equal (Pvar.get_name x) Ident.name_return
| _ -> false | _ -> false
end end
module PowLoc = module PowLoc =
struct struct
include AbstractDomain.FiniteSet(PrettyPrintable.MakePPSet(Loc)) include AbstractDomain.FiniteSet(Loc)
let bot = empty let bot = empty
let is_bot = is_empty let is_bot = is_empty

11
infer/src/bufferoverrun/arrayBlk.ml
Unescape View File

@ -116,16 +116,7 @@ struct
= fun arr1 arr2 -> { arr1 with offset = Itv.prune_ne arr1.offset arr2.offset } = fun arr1 arr2 -> { arr1 with offset = Itv.prune_ne arr1.offset arr2.offset }
end end
module PPMap = include AbstractDomain.Map (Allocsite) (ArrInfo)
struct
include PrettyPrintable.MakePPMap (Allocsite)
let pp ~pp_value fmt m =
let pp_item fmt (k, v) = F.fprintf fmt "(%a, %a)" pp_key k pp_value v in
PrettyPrintable.pp_collection ~pp_item fmt (bindings m)
end
include AbstractDomain.Map (PPMap) (ArrInfo)
let bot : astate let bot : astate
= empty = empty

366
infer/src/bufferoverrun/bufferOverrunDomain.ml
Unescape View File

@ -28,141 +28,140 @@ struct
loc : Location.t; loc : Location.t;
trace : trace; trace : trace;
id : string } id : string }
[@@deriving compare] [@@deriving compare]
and trace = Intra of Typ.Procname.t and trace = Intra of Typ.Procname.t
| Inter of Typ.Procname.t * Typ.Procname.t * Location.t | Inter of Typ.Procname.t * Typ.Procname.t * Location.t
[@@deriving compare] [@@deriving compare]
and astate = t and astate = t
let set_size_pos : t -> t let set_size_pos : t -> t
= fun c -> = fun c ->
if Itv.Bound.lt (Itv.lb c.size) Itv.Bound.zero if Itv.Bound.lt (Itv.lb c.size) Itv.Bound.zero
then { c with size = Itv.make Itv.Bound.zero (Itv.ub c.size) } then { c with size = Itv.make Itv.Bound.zero (Itv.ub c.size) }
else c else c
let string_of_location : Location.t -> string let string_of_location : Location.t -> string
= fun loc -> = fun loc ->
let fname = SourceFile.to_string loc.Location.file in let fname = SourceFile.to_string loc.Location.file in
let pos = Location.to_string loc in let pos = Location.to_string loc in
F.fprintf F.str_formatter "%s:%s" fname pos; F.fprintf F.str_formatter "%s:%s" fname pos;
F.flush_str_formatter () F.flush_str_formatter ()
let pp_location : F.formatter -> t -> unit let pp_location : F.formatter -> t -> unit
= fun fmt c -> = fun fmt c ->
F.fprintf fmt "%s" (string_of_location c.loc) F.fprintf fmt "%s" (string_of_location c.loc)
let pp : F.formatter -> t -> unit let pp : F.formatter -> t -> unit
= fun fmt c -> = fun fmt c ->
let c = set_size_pos c in let c = set_size_pos c in
if Config.bo_debug <= 1 then if Config.bo_debug <= 1 then
F.fprintf fmt "%a < %a at %a" Itv.pp c.idx Itv.pp c.size pp_location c F.fprintf fmt "%a < %a at %a" Itv.pp c.idx Itv.pp c.size pp_location c
else else
match c.trace with match c.trace with
Inter (_, pname, loc) -> Inter (_, pname, loc) ->
let pname = Typ.Procname.to_string pname in let pname = Typ.Procname.to_string pname in
F.fprintf fmt "%a < %a at %a by call %s() at %s" F.fprintf fmt "%a < %a at %a by call %s() at %s"
Itv.pp c.idx Itv.pp c.size pp_location c pname (string_of_location loc) Itv.pp c.idx Itv.pp c.size pp_location c pname (string_of_location loc)
| Intra _ -> F.fprintf fmt "%a < %a at %a" Itv.pp c.idx Itv.pp c.size pp_location c | Intra _ -> F.fprintf fmt "%a < %a at %a" Itv.pp c.idx Itv.pp c.size pp_location c
let get_location : t -> Location.t let get_location : t -> Location.t
= fun c -> c.loc = fun c -> c.loc
let get_trace : t -> trace let get_trace : t -> trace
= fun c -> c.trace = fun c -> c.trace
let get_proc_name : t -> Typ.Procname.t let get_proc_name : t -> Typ.Procname.t
= fun c -> c.proc_name = fun c -> c.proc_name
let make : Typ.Procname.t -> Location.t -> string -> idx:Itv.t -> size:Itv.t -> t let make : Typ.Procname.t -> Location.t -> string -> idx:Itv.t -> size:Itv.t -> t
= fun proc_name loc id ~idx ~size -> = fun proc_name loc id ~idx ~size ->
{ proc_name; idx; size; loc; id ; trace = Intra proc_name } { proc_name; idx; size; loc; id ; trace = Intra proc_name }
let filter1 : t -> bool let filter1 : t -> bool
= fun c -> = fun c ->
Itv.eq c.idx Itv.top || Itv.eq c.size Itv.top Itv.eq c.idx Itv.top || Itv.eq c.size Itv.top
|| Itv.Bound.eq (Itv.lb c.idx) Itv.Bound.MInf || Itv.Bound.eq (Itv.lb c.idx) Itv.Bound.MInf
|| Itv.Bound.eq (Itv.lb c.size) Itv.Bound.MInf || Itv.Bound.eq (Itv.lb c.size) Itv.Bound.MInf
|| (Itv.eq c.idx Itv.nat && Itv.eq c.size Itv.nat) || (Itv.eq c.idx Itv.nat && Itv.eq c.size Itv.nat)
let filter2 : t -> bool let filter2 : t -> bool
= fun c -> = fun c ->
(* basically, alarms involving infinity are filtered *) (* basically, alarms involving infinity are filtered *)
(not (Itv.is_finite c.idx) || not (Itv.is_finite c.size)) (not (Itv.is_finite c.idx) || not (Itv.is_finite c.size))
&& (* except the following cases *) && (* except the following cases *)
not ((Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb < 0 *) not ((Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb < 0 *)
Itv.Bound.lt (Itv.lb c.idx) Itv.Bound.zero) Itv.Bound.lt (Itv.lb c.idx) Itv.Bound.zero)
|| ||
(Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb > size lb *) (Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb > size lb *)
(Itv.Bound.gt (Itv.lb c.idx) (Itv.lb c.size))) (Itv.Bound.gt (Itv.lb c.idx) (Itv.lb c.size)))
|| ||
(Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb > size ub *) (Itv.Bound.is_not_infty (Itv.lb c.idx) && (* idx non-infty lb > size ub *)
(Itv.Bound.gt (Itv.lb c.idx) (Itv.ub c.size))) (Itv.Bound.gt (Itv.lb c.idx) (Itv.ub c.size)))
|| ||
(Itv.Bound.is_not_infty (Itv.ub c.idx) && (* idx non-infty ub > size lb *) (Itv.Bound.is_not_infty (Itv.ub c.idx) && (* idx non-infty ub > size lb *)
(Itv.Bound.gt (Itv.ub c.idx) (Itv.lb c.size))) (Itv.Bound.gt (Itv.ub c.idx) (Itv.lb c.size)))
|| ||
(Itv.Bound.is_not_infty (Itv.ub c.idx) && (* idx non-infty ub > size ub *) (Itv.Bound.is_not_infty (Itv.ub c.idx) && (* idx non-infty ub > size ub *)
(Itv.Bound.gt (Itv.ub c.idx) (Itv.ub c.size)))) (Itv.Bound.gt (Itv.ub c.idx) (Itv.ub c.size))))
(* check buffer overrun and return its confidence *) (* check buffer overrun and return its confidence *)
let check : t -> string option let check : t -> string option
= fun c -> = fun c ->
(* idx = [il, iu], size = [sl, su], we want to check that 0 <= idx < size *) (* idx = [il, iu], size = [sl, su], we want to check that 0 <= idx < size *)
let c' = set_size_pos c in (* if sl < 0, use sl' = 0 *) let c' = set_size_pos c in (* if sl < 0, use sl' = 0 *)
let not_overrun = Itv.lt_sem c'.idx c'.size in let not_overrun = Itv.lt_sem c'.idx c'.size in
let not_underrun = Itv.le_sem Itv.zero c'.idx in let not_underrun = Itv.le_sem Itv.zero c'.idx in
(* il >= 0 and iu < sl, definitely not an error *) (* il >= 0 and iu < sl, definitely not an error *)
if Itv.eq not_overrun Itv.one && Itv.eq not_underrun Itv.one then if Itv.eq not_overrun Itv.one && Itv.eq not_underrun Itv.one then
None None
(* iu < 0 or il >= su, definitely an error *) (* iu < 0 or il >= su, definitely an error *)
else if Itv.eq not_overrun Itv.zero || Itv.eq not_underrun Itv.zero then else if Itv.eq not_overrun Itv.zero || Itv.eq not_underrun Itv.zero then
Some Localise.BucketLevel.b1 Some Localise.BucketLevel.b1
(* su <= iu < +oo, most probably an error *) (* su <= iu < +oo, most probably an error *)
else if Itv.Bound.is_not_infty (Itv.ub c.idx) else if Itv.Bound.is_not_infty (Itv.ub c.idx)
&& Itv.Bound.le (Itv.ub c.size) (Itv.ub c.idx) then && Itv.Bound.le (Itv.ub c.size) (Itv.ub c.idx) then
Some Localise.BucketLevel.b2 Some Localise.BucketLevel.b2
(* symbolic il >= sl, probably an error *) (* symbolic il >= sl, probably an error *)
else if Itv.Bound.is_symbolic (Itv.lb c.idx) else if Itv.Bound.is_symbolic (Itv.lb c.idx)
&& Itv.Bound.le (Itv.lb c'.size) (Itv.lb c.idx) then && Itv.Bound.le (Itv.lb c'.size) (Itv.lb c.idx) then
Some Localise.BucketLevel.b3 Some Localise.BucketLevel.b3
(* other symbolic bounds are probably too noisy *) (* other symbolic bounds are probably too noisy *)
else if Config.bo_debug <= 1 && (Itv.is_symbolic c.idx || Itv.is_symbolic c.size) then else if Config.bo_debug <= 1 && (Itv.is_symbolic c.idx || Itv.is_symbolic c.size) then
None None
else if filter1 c then else if filter1 c then
Some Localise.BucketLevel.b5 Some Localise.BucketLevel.b5
else if filter2 c then else if filter2 c then
Some Localise.BucketLevel.b3 Some Localise.BucketLevel.b3
else else
Some Localise.BucketLevel.b2 Some Localise.BucketLevel.b2
let invalid : t -> bool let invalid : t -> bool
= fun x -> Itv.invalid x.idx || Itv.invalid x.size = fun x -> Itv.invalid x.idx || Itv.invalid x.size
let to_string : t -> string let to_string : t -> string
= fun c -> = fun c ->
let c = set_size_pos c in let c = set_size_pos c in
"Offset: " ^ Itv.to_string c.idx ^ " Size: " ^ Itv.to_string c.size "Offset: " ^ Itv.to_string c.idx ^ " Size: " ^ Itv.to_string c.size
^ " @ " ^ string_of_location c.loc ^ " @ " ^ string_of_location c.loc
^ (match c.trace with ^ (match c.trace with
Inter (_, pname, _) -> Inter (_, pname, _) ->
" by call " " by call "
^ MF.monospaced_to_string (Typ.Procname.to_string pname ^ "()") ^ " " ^ MF.monospaced_to_string (Typ.Procname.to_string pname ^ "()") ^ " "
| Intra _ -> "") | Intra _ -> "")
let subst : t -> Itv.Bound.t Itv.SubstMap.t -> Typ.Procname.t -> Typ.Procname.t -> Location.t -> t let subst : t -> Itv.Bound.t Itv.SubstMap.t -> Typ.Procname.t -> Typ.Procname.t -> Location.t -> t
= fun c subst_map caller_pname callee_pname loc -> = fun c subst_map caller_pname callee_pname loc ->
if Itv.is_symbolic c.idx || Itv.is_symbolic c.size then if Itv.is_symbolic c.idx || Itv.is_symbolic c.size then
{ c with idx = Itv.subst c.idx subst_map; { c with idx = Itv.subst c.idx subst_map;
size = Itv.subst c.size subst_map; size = Itv.subst c.size subst_map;
trace = Inter (caller_pname, callee_pname, loc) } trace = Inter (caller_pname, callee_pname, loc) }
else c else c
end end
module ConditionSet = module ConditionSet =
struct struct
module PPSet = PrettyPrintable.MakePPSet (Condition) include AbstractDomain.FiniteSet (Condition)
include AbstractDomain.FiniteSet (PPSet)
module Map = Caml.Map.Make (struct module Map = Caml.Map.Make (struct
type t = Location.t [@@deriving compare] type t = Location.t [@@deriving compare]
@ -180,8 +179,8 @@ struct
let group : t -> t Map.t let group : t -> t Map.t
= fun x -> = fun x ->
fold (fun cond map -> fold (fun cond map ->
let old_set = try Map.find cond.loc map with _ -> empty in let old_set = try Map.find cond.loc map with _ -> empty in
Map.add cond.loc (add cond old_set) map) x Map.empty Map.add cond.loc (add cond old_set) map) x Map.empty
let pp_summary : F.formatter -> t -> unit let pp_summary : F.formatter -> t -> unit
= fun fmt x -> = fun fmt x ->
@ -247,9 +246,9 @@ struct
let rec joins : t list -> t let rec joins : t list -> t
= function = function
| [] -> bot | [] -> bot
| [a] -> a | [a] -> a
| a :: b -> join a (joins b) | a :: b -> join a (joins b)
let get_itv : t -> Itv.t let get_itv : t -> Itv.t
= fun x -> x.itv = fun x -> x.itv
@ -403,7 +402,7 @@ struct
let subst : t -> Itv.Bound.t Itv.SubstMap.t -> t let subst : t -> Itv.Bound.t Itv.SubstMap.t -> t
= fun x subst_map -> = fun x subst_map ->
{ x with itv = Itv.subst x.itv subst_map; { x with itv = Itv.subst x.itv subst_map;
arrayblk = ArrayBlk.subst x.arrayblk subst_map } arrayblk = ArrayBlk.subst x.arrayblk subst_map }
let get_symbols : t -> Itv.Symbol.t list let get_symbols : t -> Itv.Symbol.t list
= fun x -> = fun x ->
@ -419,28 +418,7 @@ end
module Stack = module Stack =
struct struct
module PPMap = include AbstractDomain.Map (Loc) (Val)
struct
include PrettyPrintable.MakePPMap (Loc)
let pp_collection
: pp_item:(F.formatter -> 'a -> unit) -> F.formatter -> 'a list -> unit
= fun ~pp_item fmt c ->
let pp_sep fmt () = F.fprintf fmt ",@," in
F.pp_print_list ~pp_sep pp_item fmt c
let pp
: pp_value:(F.formatter -> 'a -> unit) -> F.formatter -> 'a t -> unit
= fun ~pp_value fmt m ->
let pp_item fmt (k, v) =
F.fprintf fmt "%a -> %a" Loc.pp k pp_value v
in
F.fprintf fmt "@[<v 2>{ ";
pp_collection ~pp_item fmt (bindings m);
F.fprintf fmt " }@]"
end
include AbstractDomain.Map (PPMap) (Val)
let bot = empty let bot = empty
@ -493,7 +471,7 @@ struct
F.fprintf fmt " }@]" F.fprintf fmt " }@]"
end end
include AbstractDomain.Map (PPMap) (Val) include AbstractDomain.Map (Loc) (Val)
let bot = empty let bot = empty
@ -549,49 +527,49 @@ struct
match M.find k rhs with match M.find k rhs with
| v' -> Pvar.equal v v' | v' -> Pvar.equal v v'
| exception Not_found -> false | exception Not_found -> false
in in
M.for_all is_in_rhs lhs M.for_all is_in_rhs lhs
let join : t -> t -> t
= fun x y ->
let join_v _ v1_opt v2_opt =
match v1_opt, v2_opt with
| None, None -> None
| Some v, None
| None, Some v -> Some v
| Some v1, Some v2 -> if Pvar.equal v1 v2 then Some v1 else assert false
in
M.merge join_v x y
let widen : prev:t -> next:t -> num_iters:int -> t
= fun ~prev ~next ~num_iters:_ -> join prev next
let pp : F.formatter -> t -> unit let join : t -> t -> t
= fun fmt x -> = fun x y ->
let pp_sep fmt () = F.fprintf fmt ", @," in let join_v _ v1_opt v2_opt =
let pp1 fmt (k, v) = match v1_opt, v2_opt with
F.fprintf fmt "%a=%a" (Ident.pp Pp.text) k (Pvar.pp Pp.text) v | None, None -> None
in | Some v, None
(* F.fprintf fmt "@[<v 0>Logical Variables :@,"; *) | None, Some v -> Some v
F.fprintf fmt "@[<hov 2>{ @,"; | Some v1, Some v2 -> if Pvar.equal v1 v2 then Some v1 else assert false
F.pp_print_list ~pp_sep pp1 fmt (M.bindings x); in
F.fprintf fmt " }@]"; M.merge join_v x y
F.fprintf fmt "@]"
let widen : prev:t -> next:t -> num_iters:int -> t
let load : Ident.t -> Exp.t -> t -> t = fun ~prev ~next ~num_iters:_ -> join prev next
= fun id exp m ->
match exp with let pp : F.formatter -> t -> unit
| Exp.Lvar x -> M.add id x m = fun fmt x ->
| _ -> m let pp_sep fmt () = F.fprintf fmt ", @," in
let pp1 fmt (k, v) =
let store : Exp.t -> Exp.t -> t -> t F.fprintf fmt "%a=%a" (Ident.pp Pp.text) k (Pvar.pp Pp.text) v
= fun e _ m -> in
match e with (* F.fprintf fmt "@[<v 0>Logical Variables :@,"; *)
| Exp.Lvar x -> M.filter (fun _ y -> not (Pvar.equal x y)) m F.fprintf fmt "@[<hov 2>{ @,";
| _ -> m F.pp_print_list ~pp_sep pp1 fmt (M.bindings x);
F.fprintf fmt " }@]";
let find : Ident.t -> t -> Pvar.t option F.fprintf fmt "@]"
= fun k m -> try Some (M.find k m) with Not_found -> None
let load : Ident.t -> Exp.t -> t -> t
= fun id exp m ->
match exp with
| Exp.Lvar x -> M.add id x m
| _ -> m
let store : Exp.t -> Exp.t -> t -> t
= fun e _ m ->
match e with
| Exp.Lvar x -> M.filter (fun _ y -> not (Pvar.equal x y)) m
| _ -> m
let find : Ident.t -> t -> Pvar.t option
= fun k m -> try Some (M.find k m) with Not_found -> None
end end
module MemReach = module MemReach =

7
infer/src/checkers/AbstractDomain.ml
Unescape View File

@ -136,8 +136,8 @@ module Pair (Domain1 : S) (Domain2 : S) = struct
F.fprintf fmt "(%a, %a)" Domain1.pp astate1 Domain2.pp astate2 F.fprintf fmt "(%a, %a)" Domain1.pp astate1 Domain2.pp astate2
end end
module FiniteSet (S : PrettyPrintable.PPSet) = struct module FiniteSet (Element : PrettyPrintable.PrintableOrderedType) = struct
include S include PrettyPrintable.MakePPSet(Element)
type astate = t type astate = t
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
@ -172,7 +172,8 @@ module InvertedSet (S : PrettyPrintable.PPSet) = struct
join prev next join prev next
end end
module Map (M : PrettyPrintable.PPMap) (ValueDomain : S) = struct module Map (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S) = struct
module M = PrettyPrintable.MakePPMap(Key)
include M include M
type astate = ValueDomain.astate M.t type astate = ValueDomain.astate M.t

10
infer/src/checkers/AbstractDomain.mli
Unescape View File

@ -67,8 +67,8 @@ module Pair (Domain1 : S) (Domain2 : S) : S with type astate = Domain1.astate *
(** Lift a set to a powerset domain ordered by subset. The elements of the set should be drawn from (** Lift a set to a powerset domain ordered by subset. The elements of the set should be drawn from
a *finite* collection of possible values, since the widening operator here is just union. *) a *finite* collection of possible values, since the widening operator here is just union. *)
module FiniteSet (Set : PrettyPrintable.PPSet) : sig module FiniteSet (Element : PrettyPrintable.PrintableOrderedType) : sig
include PrettyPrintable.PPSet with type t = Set.t and type elt = Set.elt include (module type of PrettyPrintable.MakePPSet(Element))
include WithBottom with type astate = t include WithBottom with type astate = t
end end
@ -80,9 +80,9 @@ end
(** Map domain ordered by union over the set of bindings, so the bottom element is the empty map. (** Map domain ordered by union over the set of bindings, so the bottom element is the empty map.
Every element implicitly maps to bottom unless it is explicitly bound to something else *) Every element implicitly maps to bottom unless it is explicitly bound to something else *)
module Map (Map : PrettyPrintable.PPMap) (ValueDomain : S) : sig module Map (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S) : sig
include PrettyPrintable.PPMap with type 'a t = 'a Map.t and type key = Map.key include (module type of PrettyPrintable.MakePPMap(Key))
include WithBottom with type astate = ValueDomain.astate Map.t include WithBottom with type astate = ValueDomain.astate t
end end
(** Map domain ordered by intersection over the set of bindings, so the top element is the empty (** Map domain ordered by intersection over the set of bindings, so the top element is the empty

6
infer/src/checkers/AnnotReachabilityDomain.ml
Unescape View File

@ -7,8 +7,8 @@
* of patent rights can be found in the PATENTS file in the same directory. * of patent rights can be found in the PATENTS file in the same directory.
*) *)
module CallSites = AbstractDomain.FiniteSet (CallSite.Set) module CallSites = AbstractDomain.FiniteSet (CallSite)
module SinkMap = AbstractDomain.Map (Typ.Procname.Map) (CallSites) module SinkMap = AbstractDomain.Map (Typ.Procname) (CallSites)
include AbstractDomain.Map (Annot.Map) (SinkMap) include AbstractDomain.Map (Annot) (SinkMap)

2
infer/src/checkers/BoundedCallTree.ml
Unescape View File

@ -14,7 +14,7 @@ module L = Logging
(** find transitive procedure calls for each procedure *) (** find transitive procedure calls for each procedure *)
module Domain = AbstractDomain.FiniteSet(Typ.Procname.Set) module Domain = AbstractDomain.FiniteSet(Typ.Procname)
(* Store a single stacktree frame per method. That is, callees is (* Store a single stacktree frame per method. That is, callees is
always []. Instead, the expanded per-method summaries are directly stored always []. Instead, the expanded per-method summaries are directly stored

18
infer/src/checkers/NullabilityPreanalysis.ml
Unescape View File

@ -14,20 +14,14 @@ open! IStd
module F = Format module F = Format
module L = Logging module L = Logging
type t = Fieldname.t * Typ.t [@@deriving compare] module FieldsAssignedInConstructors =
AbstractDomain.FiniteSet(struct
type t = Fieldname.t * Typ.t [@@deriving compare]
let pp fmt (fieldname, typ) = let pp fmt (fieldname, typ) =
F.fprintf fmt "(%a, %a)" Fieldname.pp fieldname (Typ.pp_full Pp.text) typ F.fprintf fmt "(%a, %a)" Fieldname.pp fieldname (Typ.pp_full Pp.text) typ
module DomainSet =
PrettyPrintable.MakePPSet(struct
type nonrec t = t
let compare = compare
let pp = pp
end) end)
module FieldsAssignedInConstructors = AbstractDomain.FiniteSet(DomainSet)
module TransferFunctions (CFG : ProcCfg.S) = struct module TransferFunctions (CFG : ProcCfg.S) = struct
module CFG = CFG module CFG = CFG
module Domain = FieldsAssignedInConstructors module Domain = FieldsAssignedInConstructors
@ -94,7 +88,7 @@ let add_nonnull_to_fields fields tenv =
~fields: fields_with_annot ~statics ~supers ~methods ~annots typ_name) ~fields: fields_with_annot ~statics ~supers ~methods ~annots typ_name)
| None -> ()) | None -> ())
| None -> () in | None -> () in
DomainSet.iter add_nonnull_to_field fields FieldsAssignedInConstructors.iter add_nonnull_to_field fields
let analysis cfg tenv = let analysis cfg tenv =
let initial = FieldsAssignedInConstructors.empty in let initial = FieldsAssignedInConstructors.empty in

13
infer/src/checkers/SimpleChecker.ml
Unescape View File

@ -46,13 +46,12 @@ module Make (Spec : Spec) : S = struct
module Domain = struct module Domain = struct
include include
AbstractDomain.FiniteSet AbstractDomain.FiniteSet
(PrettyPrintable.MakePPSet( (struct
struct type t = Spec.astate
type t = Spec.astate let compare = Spec.compare
let compare = Spec.compare let pp _ _ = ()
let pp _ _ = () end)
end)
)
let widen ~prev ~next ~num_iters = let widen ~prev ~next ~num_iters =
let iters_befor_timeout = 1000 in let iters_befor_timeout = 1000 in

4
infer/src/checkers/SiofDomain.ml
Unescape View File

@ -9,13 +9,13 @@
open! IStd open! IStd
module VarNames = PrettyPrintable.MakePPSet(String) module VarNames = AbstractDomain.FiniteSet(String)
module BottomSiofTrace = AbstractDomain.BottomLifted(SiofTrace) module BottomSiofTrace = AbstractDomain.BottomLifted(SiofTrace)
include AbstractDomain.Pair include AbstractDomain.Pair
(BottomSiofTrace) (BottomSiofTrace)
(AbstractDomain.FiniteSet(VarNames)) (VarNames)
(** group together procedure-local accesses *) (** group together procedure-local accesses *)
let normalize ((trace, initialized) as astate) = match trace with let normalize ((trace, initialized) as astate) = match trace with

6
infer/src/checkers/SiofDomain.mli
Unescape View File

@ -7,7 +7,9 @@
* of patent rights can be found in the PATENTS file in the same directory. * of patent rights can be found in the PATENTS file in the same directory.
*) *)
module VarNames : PrettyPrintable.PPSet with type elt = string open! IStd
module VarNames : module type of AbstractDomain.FiniteSet(String)
module BottomSiofTrace : module type of AbstractDomain.BottomLifted(SiofTrace) module BottomSiofTrace : module type of AbstractDomain.BottomLifted(SiofTrace)
@ -28,7 +30,7 @@ module BottomSiofTrace : module type of AbstractDomain.BottomLifted(SiofTrace)
std::ios_base::Init::Init(). *) std::ios_base::Init::Init(). *)
include module type of AbstractDomain.Pair include module type of AbstractDomain.Pair
(AbstractDomain.BottomLifted(SiofTrace)) (AbstractDomain.BottomLifted(SiofTrace))
(AbstractDomain.FiniteSet(VarNames)) (VarNames)
(** group together procedure-local accesses *) (** group together procedure-local accesses *)
val normalize : astate -> astate val normalize : astate -> astate

8
infer/src/checkers/ThreadSafetyDomain.ml
Unescape View File

@ -173,16 +173,10 @@ module AccessPrecondition = struct
| Protected -> F.fprintf fmt "Protected" | Protected -> F.fprintf fmt "Protected"
| Unprotected (Some index) -> F.fprintf fmt "Unprotected(%d)" index | Unprotected (Some index) -> F.fprintf fmt "Unprotected(%d)" index
| Unprotected None -> F.fprintf fmt "Unprotected" | Unprotected None -> F.fprintf fmt "Unprotected"
module Map = PrettyPrintable.MakePPMap(struct
type nonrec t = t
let compare = compare
let pp = pp
end)
end end
module AccessDomain = struct module AccessDomain = struct
include AbstractDomain.Map (AccessPrecondition.Map) (PathDomain) include AbstractDomain.Map (AccessPrecondition) (PathDomain)
let add_access precondition access_path t = let add_access precondition access_path t =
let precondition_accesses = let precondition_accesses =

4
infer/src/checkers/ThreadSafetyDomain.mli
Unescape View File

@ -101,14 +101,12 @@ module AccessPrecondition : sig
val unprotected : t val unprotected : t
val pp : F.formatter -> t -> unit val pp : F.formatter -> t -> unit
module Map : PrettyPrintable.PPMap with type key = t
end end
(** map of access precondition |-> set of accesses. the map should hold all accesses to a (** map of access precondition |-> set of accesses. the map should hold all accesses to a
possibly-unowned access path *) possibly-unowned access path *)
module AccessDomain : sig module AccessDomain : sig
include module type of AbstractDomain.Map (AccessPrecondition.Map) (PathDomain) include module type of AbstractDomain.Map (AccessPrecondition) (PathDomain)
(* add the given (access, precondition) pair to the map *) (* add the given (access, precondition) pair to the map *)
val add_access : AccessPrecondition.t -> TraceElem.t -> astate -> astate val add_access : AccessPrecondition.t -> TraceElem.t -> astate -> astate

5
infer/src/checkers/addressTaken.ml
Unescape View File

@ -9,7 +9,10 @@
open! IStd open! IStd
module Domain = AbstractDomain.FiniteSet(Pvar.Set) module Domain = AbstractDomain.FiniteSet(struct
include Pvar
let pp = pp Pp.text
end)
module TransferFunctions (CFG : ProcCfg.S) = struct module TransferFunctions (CFG : ProcCfg.S) = struct
module CFG = CFG module CFG = CFG

8
infer/src/checkers/annotationReachability.ml
Unescape View File

@ -42,7 +42,7 @@ let src_snk_pairs =
specs specs
module Domain = struct module Domain = struct
module TrackingVar = AbstractDomain.FiniteSet (Var.Set) module TrackingVar = AbstractDomain.FiniteSet (Var)
module TrackingDomain = AbstractDomain.BottomLifted (TrackingVar) module TrackingDomain = AbstractDomain.BottomLifted (TrackingVar)
include AbstractDomain.Pair (AnnotReachabilityDomain) (TrackingDomain) include AbstractDomain.Pair (AnnotReachabilityDomain) (TrackingDomain)
@ -159,7 +159,7 @@ let lookup_annotation_calls caller_pdesc annot pname =
| Some { Specs.payload = { Specs.annot_map = Some annot_map; }; } -> | Some { Specs.payload = { Specs.annot_map = Some annot_map; }; } ->
begin begin
try try
Annot.Map.find annot annot_map AnnotReachabilityDomain.find annot annot_map
with Not_found -> with Not_found ->
AnnotReachabilityDomain.SinkMap.empty AnnotReachabilityDomain.SinkMap.empty
end end
@ -309,7 +309,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
if AnnotReachabilityDomain.CallSites.is_empty calls if AnnotReachabilityDomain.CallSites.is_empty calls
then astate then astate
else Domain.add_call_site annot sink call_site astate in else Domain.add_call_site annot sink call_site astate in
Annot.Map.fold AnnotReachabilityDomain.fold
(fun annot sink_map astate -> (fun annot sink_map astate ->
AnnotReachabilityDomain.SinkMap.fold AnnotReachabilityDomain.SinkMap.fold
(add_call_site annot) (add_call_site annot)
@ -389,7 +389,7 @@ module Interprocedural = struct
(CallSite.make proc_name loc) (CallSite.make proc_name loc)
sink_map in sink_map in
try try
let sink_map = Annot.Map.find snk_annot annot_map in let sink_map = AnnotReachabilityDomain.find snk_annot annot_map in
List.iter ~f:(report_src_snk_path sink_map) src_annot_list List.iter ~f:(report_src_snk_path sink_map) src_annot_list
with Not_found -> () in with Not_found -> () in

2
infer/src/checkers/liveness.ml
Unescape View File

@ -14,7 +14,7 @@ module L = Logging
(** backward analysis for computing set of maybe-live variables at each program point *) (** backward analysis for computing set of maybe-live variables at each program point *)
module Domain = AbstractDomain.FiniteSet(Var.Set) module Domain = AbstractDomain.FiniteSet(Var)
(* compilers 101-style backward transfer functions for liveness analysis. gen a variable when it is (* compilers 101-style backward transfer functions for liveness analysis. gen a variable when it is
read, kill the variable when it is assigned *) read, kill the variable when it is assigned *)

11
infer/src/checkers/var.ml
Unescape View File

@ -28,10 +28,6 @@ let to_exp = function
| ProgramVar pvar -> Exp.Lvar pvar | ProgramVar pvar -> Exp.Lvar pvar
| LogicalVar id -> Exp.Var id | LogicalVar id -> Exp.Var id
let compare_alpha v1 v2 = match v1, v2 with
| ProgramVar pv1, ProgramVar pv2 -> Pvar.compare_alpha pv1 pv2
| _ -> compare v1 v2
let pp fmt = function let pp fmt = function
| ProgramVar pv -> (Pvar.pp Pp.text) fmt pv | ProgramVar pv -> (Pvar.pp Pp.text) fmt pv
| LogicalVar id -> (Ident.pp Pp.text) fmt id | LogicalVar id -> (Ident.pp Pp.text) fmt id
@ -41,10 +37,3 @@ module Map = PrettyPrintable.MakePPMap(struct
let compare = compare let compare = compare
let pp = pp let pp = pp
end) end)
module Set = PrettyPrintable.MakePPCompareSet(struct
type nonrec t = t
let compare = compare
let compare_pp = compare_alpha
let pp = pp
end)

2
infer/src/checkers/var.mli
Unescape View File

@ -27,5 +27,3 @@ val to_exp : t -> Exp.t
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
module Map : PrettyPrintable.PPMap with type key = t module Map : PrettyPrintable.PPMap with type key = t
module Set : PrettyPrintable.PPSet with type elt = t

2
infer/src/unit/accessTreeTests.ml
Unescape View File

@ -13,7 +13,7 @@ module F = Format
(* string set domain we use to ensure we're getting the expected traces *) (* string set domain we use to ensure we're getting the expected traces *)
module MockTraceDomain = struct module MockTraceDomain = struct
include AbstractDomain.FiniteSet (PrettyPrintable.MakePPSet (String)) include AbstractDomain.FiniteSet (String)
let top_str = "T" let top_str = "T"

2
infer/src/unit/addressTakenTests.ml
Unescape View File

@ -93,7 +93,7 @@ let tests =
); );
invariant "{ &b, &d }"; invariant "{ &b, &d }";
var_assign_addrof_var ~rhs_typ:int_ptr_typ "e" "f"; var_assign_addrof_var ~rhs_typ:int_ptr_typ "e" "f";
invariant "{ &b, &d, &f }" invariant "{ &b, &f, &d }"
]; ];
] |> TestInterpreter.create_tests ProcData.empty_extras ~initial:AddressTaken.Domain.empty in ] |> TestInterpreter.create_tests ProcData.empty_extras ~initial:AddressTaken.Domain.empty in
"address_taken_suite">:::test_list "address_taken_suite">:::test_list

4
infer/src/unit/livenessTests.ml
Unescape View File

@ -42,7 +42,7 @@ let tests =
]; ];
"iterative_live", "iterative_live",
[ [
invariant "{ &b, &d, &f }"; invariant "{ &b, &f, &d }";
id_assign_var "e" "f"; id_assign_var "e" "f";
invariant "{ &b, &d }"; invariant "{ &b, &d }";
id_assign_var "c" "d"; id_assign_var "c" "d";
@ -91,7 +91,7 @@ let tests =
]; ];
"call_params_live", "call_params_live",
[ [
invariant "{ &a, &b, &c }"; invariant "{ &b, &a, &c }";
call_unknown_no_ret ["a"; "b"; "c";] call_unknown_no_ret ["a"; "b"; "c";]
]; ];
"dead_after_call_with_retval", "dead_after_call_with_retval",

Write Preview
Loading…
Cancel
Save