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

[whitespace] indent .ml files as well

Browse Source
master
Jules Villard 10 years ago
parent 6911a1516c
commit bae8a4dced
101 changed files with 5243 additions and 5243 deletions
Show Stats Download Patch File Download Diff File

36
infer/src/backend/DB.ml
Unescape View File

@ -142,12 +142,12 @@ let find_source_dirs () =
let add_cg_files_from_dir dir = let add_cg_files_from_dir dir =
let files = Array.to_list (Sys.readdir dir) in let files = Array.to_list (Sys.readdir dir) in
list_iter (fun fname -> list_iter (fun fname ->
let path = Filename.concat dir fname in let path = Filename.concat dir fname in
if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs) if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs)
files in files in
list_iter (fun fname -> list_iter (fun fname ->
let dir = Filename.concat capt_dir fname in let dir = Filename.concat capt_dir fname in
if Sys.is_directory dir then add_cg_files_from_dir dir) if Sys.is_directory dir then add_cg_files_from_dir dir)
files_in_results_dir; files_in_results_dir;
list_rev !source_dirs list_rev !source_dirs
@ -193,15 +193,15 @@ let create_dir dir =
try try
if (Unix.stat dir).Unix.st_kind != Unix.S_DIR then if (Unix.stat dir).Unix.st_kind != Unix.S_DIR then
(L.err "@.ERROR: file %s exists and is not a directory@." dir; (L.err "@.ERROR: file %s exists and is not a directory@." dir;
assert false) assert false)
with Unix.Unix_error _ -> with Unix.Unix_error _ ->
(try Unix.mkdir dir 0o700 with (try Unix.mkdir dir 0o700 with
Unix.Unix_error _ -> Unix.Unix_error _ ->
let created_concurrently = (* check if another process created it meanwhile *) let created_concurrently = (* check if another process created it meanwhile *)
(Unix.stat dir).Unix.st_kind = Unix.S_DIR in (Unix.stat dir).Unix.st_kind = Unix.S_DIR in
if not created_concurrently then if not created_concurrently then
(L.err "@.ERROR: cannot create directory %s@." dir; (L.err "@.ERROR: cannot create directory %s@." dir;
assert false)) assert false))
let read_whole_file fd = let read_whole_file fd =
let stats = Unix.fstat fd in let stats = Unix.fstat fd in
@ -216,9 +216,9 @@ let read_whole_file fd =
buf buf
(** Update the file contents with the update function provided. (** Update the file contents with the update function provided.
If the directory does not exist, it is created. If the directory does not exist, it is created.
If the file does not exist, it is created, and update is given the empty string. If the file does not exist, it is created, and update is given the empty string.
A lock is used to allow write attempts in parallel. *) A lock is used to allow write attempts in parallel. *)
let update_file_with_lock dir fname update = let update_file_with_lock dir fname update =
let reset_file fd = let reset_file fd =
let n = Unix.lseek fd 0 Unix.SEEK_SET in let n = Unix.lseek fd 0 Unix.SEEK_SET in
@ -238,7 +238,7 @@ let update_file_with_lock dir fname update =
if (i = (String.length str)) if (i = (String.length str))
then (Unix.lockf fd Unix.F_ULOCK 0; Unix.close fd) then (Unix.lockf fd Unix.F_ULOCK 0; Unix.close fd)
else (L.err "@.save_with_lock: fail on path: %s@." path; else (L.err "@.save_with_lock: fail on path: %s@." path;
assert false) assert false)
(** Read a file using a lock to allow write attempts in parallel. *) (** Read a file using a lock to allow write attempts in parallel. *)
let read_file_with_lock dir fname = let read_file_with_lock dir fname =
@ -252,8 +252,8 @@ let read_file_with_lock dir fname =
Unix.close fd; Unix.close fd;
Some buf Some buf
with Unix.Unix_error _ -> with Unix.Unix_error _ ->
L.stderr "read_file_with_lock: Unix error"; L.stderr "read_file_with_lock: Unix error";
assert false assert false
with Unix.Unix_error _ -> None with Unix.Unix_error _ -> None
(** {2 Results Directory} *) (** {2 Results Directory} *)

128
infer/src/backend/abs.ml
Unescape View File

@ -421,10 +421,10 @@ let typ_get_recursive_flds tenv te =
match te with match te with
| Sil.Sizeof (typ, _) -> | Sil.Sizeof (typ, _) ->
(match typ with (match typ with
| Sil.Tvar _ -> assert false (* there should be no indirection *) | Sil.Tvar _ -> assert false (* there should be no indirection *)
| Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> [] | Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list) | Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list)
| Sil.Tarray _ -> []) | Sil.Tarray _ -> [])
| Sil.Var _ -> [] (* type of |-> not known yet *) | Sil.Var _ -> [] (* type of |-> not known yet *)
| Sil.Const _ -> [] | Sil.Const _ -> []
| _ -> | _ ->
@ -933,7 +933,7 @@ let create_absrules_from_tdecl tenv tname =
match is_simply_recursive tenv tname with match is_simply_recursive tenv tname with
| None -> () | None -> ()
| Some (fld) -> | Some (fld) ->
(* L.out "@[.... Adding Abstraction Rules ....@\n@."; *) (* L.out "@[.... Adding Abstraction Rules ....@\n@."; *)
let para = create_hpara_from_tname_flds tenv tname fld [] [] Sil.inst_abstraction in let para = create_hpara_from_tname_flds tenv tname fld [] [] Sil.inst_abstraction in
abs_rules_add_sll para abs_rules_add_sll para
else () else ()
@ -949,27 +949,27 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
let filter atom = let filter atom =
let fav' = Sil.atom_fav atom in let fav' = Sil.atom_fav atom in
Sil.fav_for_all fav' (fun id -> Sil.fav_for_all fav' (fun id ->
if Ident.is_primed id then Sil.fav_mem fav_sigma id if Ident.is_primed id then Sil.fav_mem fav_sigma id
else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id
else true) in else true) in
list_filter filter pure in list_filter filter pure in
let new_pure = let new_pure =
list_fold_left list_fold_left
(fun pi a -> (fun pi a ->
match a with match a with
| Sil.Aneq (Sil.Var name, _) -> a:: pi | Sil.Aneq (Sil.Var name, _) -> a:: pi
(* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *)
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _)) | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _))
| Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i)) | Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i))
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _)) | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _))
| Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i -> | Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i ->
a :: pi a :: pi
| Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) -> | Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) ->
(match e with (match e with
| Sil.Var _ | Sil.Var _
| Sil.Const _ -> a :: pi | Sil.Const _ -> a :: pi
| _ -> pi) | _ -> pi)
| _ -> pi) | _ -> pi)
[] pi_filtered in [] pi_filtered in
list_rev new_pure in list_rev new_pure in
@ -988,8 +988,8 @@ let abstract_gc p =
let p_without_pi = Prop.normalize (Prop.replace_pi [] p) in let p_without_pi = Prop.normalize (Prop.replace_pi [] p) in
let fav_p_without_pi = Prop.prop_fav p_without_pi in let fav_p_without_pi = Prop.prop_fav p_without_pi in
(* let weak_filter atom = (* let weak_filter atom =
let fav_atom = atom_fav atom in let fav_atom = atom_fav atom in
list_intersect compare fav_p_without_pi fav_atom in *) list_intersect compare fav_p_without_pi fav_atom in *)
let strong_filter = function let strong_filter = function
| Sil.Aeq(e1, e2) | Sil.Aneq(e1, e2) -> | Sil.Aeq(e1, e2) | Sil.Aneq(e1, e2) ->
let fav_e1 = Sil.exp_fav e1 in let fav_e1 = Sil.exp_fav e1 in
@ -1046,8 +1046,8 @@ let sigma_reachable root_fav sigma =
if modified then find_fixpoint edges_to_revisit in if modified then find_fixpoint edges_to_revisit in
find_fixpoint !edges; find_fixpoint !edges;
(* L.d_str "reachable: "; (* L.d_str "reachable: ";
Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set; Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set;
L.d_ln (); *) L.d_ln (); *)
!reach_set !reach_set
let get_cycle root prop = let get_cycle root prop =
@ -1056,19 +1056,19 @@ let get_cycle root prop =
match e with match e with
| Sil.Eexp(e', _) -> | Sil.Eexp(e', _) ->
(try (try
Some(list_find (fun hpred -> match hpred with Some(list_find (fun hpred -> match hpred with
| Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e' | Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e'
| _ -> false) sigma) | _ -> false) sigma)
with _ -> None) with _ -> None)
| _ -> None in | _ -> None in
let print_cycle cyc = let print_cycle cyc =
(L.d_str "Cycle= "; (L.d_str "Cycle= ";
list_iter (fun ((e, t), f, e') -> list_iter (fun ((e, t), f, e') ->
match e, e' with match e, e' with
| Sil.Eexp (e, _), Sil.Eexp (e', _) -> | Sil.Eexp (e, _), Sil.Eexp (e', _) ->
L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")") L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")")
| _ -> ()) cyc; | _ -> ()) cyc;
L.d_strln "") in L.d_strln "") in
(* perform a dfs of a graph stopping when e_root is reached. *) (* perform a dfs of a graph stopping when e_root is reached. *)
(* Returns a pair (path, bool) where path is a list of edges ((e1,type_e1),f,e2) *) (* Returns a pair (path, bool) where path is a list of edges ((e1,type_e1),f,e2) *)
(* describing the path to e_root and bool is true if e_root is reached. *) (* describing the path to e_root and bool is true if e_root is reached. *)
@ -1129,7 +1129,7 @@ let full_reachability_algorithm = true
let should_raise_objc_leak prop hpred = let should_raise_objc_leak prop hpred =
match hpred with match hpred with
| Sil.Hpointsto(e, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _), Sil.Sizeof (typ, _)) | Sil.Hpointsto(e, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _), Sil.Sizeof (typ, _))
when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) -> when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) ->
Mleak_buckets.should_raise_leak typ Mleak_buckets.should_raise_leak typ
| _ -> None | _ -> None
@ -1155,7 +1155,7 @@ let get_var_retain_cycle _prop =
let is_hpred_block v h = let is_hpred_block v h =
match h, v with match h, v with
| Sil.Hpointsto (e, _, Sil.Sizeof(typ, _)), Sil.Eexp (e', _) | Sil.Hpointsto (e, _, Sil.Sizeof(typ, _)), Sil.Eexp (e', _)
when Sil.exp_equal e e' && Sil.is_block_type typ -> true when Sil.exp_equal e e' && Sil.is_block_type typ -> true
| _, _ -> false in | _, _ -> false in
let find_pvar v = let find_pvar v =
try try
@ -1171,8 +1171,8 @@ let get_var_retain_cycle _prop =
match find_pvar e with match find_pvar e with
| Some pvar -> [((sexp pvar, t), f, e')] | Some pvar -> [((sexp pvar, t), f, e')]
| _ -> (match find_block e with | _ -> (match find_block e with
| Some blk -> [((sexp blk, t), f, e')] | Some blk -> [((sexp blk, t), f, e')]
| _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in | _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in
(* returns the pvars of the first cycle we find in sigma. *) (* returns the pvars of the first cycle we find in sigma. *)
(* This is an heuristic that works if there is one cycle. *) (* This is an heuristic that works if there is one cycle. *)
(* In case there are more than one cycle we may return not necessarily*) (* In case there are more than one cycle we may return not necessarily*)
@ -1202,7 +1202,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
| Sil.Tstruct(nsf, sf, _, _, _, _, _) -> | Sil.Tstruct(nsf, sf, _, _, _, _, _) ->
let ia = ref [] in let ia = ref [] in
list_iter (fun (fn', t', ia') -> list_iter (fun (fn', t', ia') ->
if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf); if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf);
!ia !ia
| _ -> [] in | _ -> [] in
let rec has_weak_or_unretained_or_assign params = let rec has_weak_or_unretained_or_assign params =
@ -1212,7 +1212,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
| _:: params' -> has_weak_or_unretained_or_assign params' in | _:: params' -> has_weak_or_unretained_or_assign params' in
let do_annotation (a, _) = let do_annotation (a, _) =
((a.Sil.class_name = Config.property_attributes) || ((a.Sil.class_name = Config.property_attributes) ||
(a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in (a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in
let rec do_cycle c = let rec do_cycle c =
match c with match c with
| [] -> false | [] -> false
@ -1308,26 +1308,26 @@ let check_junk ?original_prop pname tenv prop =
Exceptions.Leak (fp_part, prop, hpred, Errdesc.explain_leak tenv hpred prop alloc_attribute objc_ml_bucket_opt, !Absarray.array_abstraction_performed, resource, try assert false with Assert_failure x -> x) in Exceptions.Leak (fp_part, prop, hpred, Errdesc.explain_leak tenv hpred prop alloc_attribute objc_ml_bucket_opt, !Absarray.array_abstraction_performed, resource, try assert false with Assert_failure x -> x) in
let ignore_resource, exn = let ignore_resource, exn =
(match alloc_attribute, resource with (match alloc_attribute, resource with
| Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) -> | Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) ->
(* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *) (* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *)
(* Otherwise we report a retain cycle*) (* Otherwise we report a retain cycle*)
let cycle = get_var_retain_cycle (remove_opt original_prop) in let cycle = get_var_retain_cycle (remove_opt original_prop) in
if cycle_has_weak_or_unretained_or_assign_field cycle then if cycle_has_weak_or_unretained_or_assign_field cycle then
true, exn_retain_cycle cycle true, exn_retain_cycle cycle
else false, exn_retain_cycle cycle else false, exn_retain_cycle cycle
| Some _, Sil.Rmemory Sil.Mobjc -> | Some _, Sil.Rmemory Sil.Mobjc ->
objc_ml_bucket_opt = None, exn_leak objc_ml_bucket_opt = None, exn_leak
| Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak | Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak
| Some _, Sil.Rignore -> true, exn_leak | Some _, Sil.Rignore -> true, exn_leak
| Some _, Sil.Rfile -> false, exn_leak | Some _, Sil.Rfile -> false, exn_leak
| Some _, Sil.Rlock -> false, exn_leak | Some _, Sil.Rlock -> false, exn_leak
| _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred -> | _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred ->
(* When its a cycle and the object has a ref counter then *) (* When its a cycle and the object has a ref counter then *)
(* we have a retain cycle. Objc object may not have the *) (* we have a retain cycle. Objc object may not have the *)
(* Sil.Mobjc qualifier when added in footprint doing abduction *) (* Sil.Mobjc qualifier when added in footprint doing abduction *)
let cycle = get_var_retain_cycle (remove_opt original_prop) in let cycle = get_var_retain_cycle (remove_opt original_prop) in
false, exn_retain_cycle cycle false, exn_retain_cycle cycle
| _ -> !Sil.curr_language = Sil.Java, exn_leak) in | _ -> !Sil.curr_language = Sil.Java, exn_leak) in
let ignore_leak = !Config.allowleak || ignore_resource || is_undefined in let ignore_leak = !Config.allowleak || ignore_resource || is_undefined in
let report_and_continue = !Config.footprint in (* in footprint mode, report leak and continue *) let report_and_continue = !Config.footprint in (* in footprint mode, report leak and continue *)
let already_reported () = let already_reported () =
@ -1367,7 +1367,7 @@ let check_junk ?original_prop pname tenv prop =
else Prop.normalize (Prop.replace_sigma sigma_new (Prop.replace_sigma_footprint sigma_fp_new prop)) else Prop.normalize (Prop.replace_sigma sigma_new (Prop.replace_sigma_footprint sigma_fp_new prop))
(** Check whether the prop contains junk. (** Check whether the prop contains junk.
If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *) If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *)
let abstract_junk ?original_prop pname tenv prop = let abstract_junk ?original_prop pname tenv prop =
Absarray.array_abstraction_performed := false; Absarray.array_abstraction_performed := false;
check_junk ~original_prop: original_prop pname tenv prop check_junk ~original_prop: original_prop pname tenv prop
@ -1427,7 +1427,7 @@ let remove_local_stack sigma pvars =
list_filter filter_non_stack sigma list_filter filter_non_stack sigma
(** [prop_set_fooprint p p_foot] removes a local stack from [p_foot], (** [prop_set_fooprint p p_foot] removes a local stack from [p_foot],
and sets proposition [p_foot] as footprint of [p]. *) and sets proposition [p_foot] as footprint of [p]. *)
let set_footprint_for_abs (p : 'a Prop.t) (p_foot : 'a Prop.t) local_stack_pvars : Prop.exposed Prop.t = let set_footprint_for_abs (p : 'a Prop.t) (p_foot : 'a Prop.t) local_stack_pvars : Prop.exposed Prop.t =
let p_foot_pure = Prop.get_pure p_foot in let p_foot_pure = Prop.get_pure p_foot in
let p_foot_sigma = Prop.get_sigma p_foot in let p_foot_sigma = Prop.get_sigma p_foot in

48
infer/src/backend/absarray.ml
Unescape View File

@ -18,7 +18,7 @@ type sigma = Sil.hpred list
(** Matcher for the sigma part specialized to strexps *) (** Matcher for the sigma part specialized to strexps *)
module StrexpMatch : sig module StrexpMatch : sig
(** path through a strexp *) (** path through a strexp *)
type path type path
(** convert a path into a list of expressions *) (** convert a path into a list of expressions *)
@ -156,7 +156,7 @@ end = struct
let t = (fun (x,y,z) -> y) (list_find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in let t = (fun (x,y,z) -> y) (list_find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in
find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t
with Not_found -> with Not_found ->
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find") L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
end; end;
find_offset_fsel sigma_other hpred root offs fsel' ftal typ find_offset_fsel sigma_other hpred root offs fsel' ftal typ
and find_offset_esel sigma_other hpred root offs esel t = match esel with and find_offset_esel sigma_other hpred root offs esel t = match esel with
@ -247,20 +247,20 @@ end = struct
end end
(** This function renames expressions in [p]. The renaming is, roughly (** This function renames expressions in [p]. The renaming is, roughly
speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *) speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *)
let prop_replace_path_index let prop_replace_path_index
(p: Prop.exposed Prop.t) (p: Prop.exposed Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t (map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t
= =
let elist_path = StrexpMatch.path_to_exps path in let elist_path = StrexpMatch.path_to_exps path in
let expmap_list = let expmap_list =
list_fold_left (fun acc_outer e_path -> list_fold_left (fun acc_outer e_path ->
list_fold_left (fun acc_inner (old_index, new_index) -> list_fold_left (fun acc_inner (old_index, new_index) ->
let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in
(old_e_path_index, new_e_path_index) :: acc_inner (old_e_path_index, new_e_path_index) :: acc_inner
) acc_outer map ) acc_outer map
) [] elist_path in ) [] elist_path in
let expmap_fun e' = let expmap_fun e' =
try try
@ -270,11 +270,11 @@ let prop_replace_path_index
Prop.prop_expmap expmap_fun p Prop.prop_expmap expmap_fun p
(** This function uses [update] and transforms the two sigma parts of [p], (** This function uses [update] and transforms the two sigma parts of [p],
the sigma of the current SH of [p] and that of the footprint of [p]. *) the sigma of the current SH of [p] and that of the footprint of [p]. *)
let prop_update_sigma_and_fp_sigma let prop_update_sigma_and_fp_sigma
(p : Prop.normal Prop.t) (p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
= =
let sigma', changed = update false (Prop.get_sigma p) in let sigma', changed = update false (Prop.get_sigma p) in
let ep1 = Prop.replace_sigma sigma' p in let ep1 = Prop.replace_sigma sigma' p in
let ep2, changed2 = let ep2, changed2 =
@ -285,13 +285,13 @@ let prop_update_sigma_and_fp_sigma
(Prop.normalize ep2, changed || changed2) (Prop.normalize ep2, changed || changed2)
(** This function uses [update] and transforms the sigma of the (** This function uses [update] and transforms the sigma of the
current SH of [p] or that of the footprint of [p], depending on current SH of [p] or that of the footprint of [p], depending on
[footprint_part]. *) [footprint_part]. *)
let prop_update_sigma_or_fp_sigma let prop_update_sigma_or_fp_sigma
(footprint_part : bool) (footprint_part : bool)
(p : Prop.normal Prop.t) (p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
= =
let ep1, changed1 = let ep1, changed1 =
if footprint_part then (Prop.expose p, false) if footprint_part then (Prop.expose p, false)
else else
@ -311,15 +311,15 @@ let prop_update_sigma_or_fp_sigma
let array_abstraction_performed = ref false let array_abstraction_performed = ref false
(** This function abstracts strexps. The parameter [can_abstract] spots strexps (** This function abstracts strexps. The parameter [can_abstract] spots strexps
where the abstraction might be applicable, and the parameter [do_abstract] does where the abstraction might be applicable, and the parameter [do_abstract] does
the abstraction to those spotted strexps. *) the abstraction to those spotted strexps. *)
let generic_strexp_abstract let generic_strexp_abstract
(abstraction_name : string) (abstraction_name : string)
(p_in : Prop.normal Prop.t) (p_in : Prop.normal Prop.t)
(_can_abstract : sigma -> StrexpMatch.strexp_data -> bool) (_can_abstract : sigma -> StrexpMatch.strexp_data -> bool)
(do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) (do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool)
: Prop.normal Prop.t : Prop.normal Prop.t
= =
let can_abstract s data = let can_abstract s data =
let r = _can_abstract s data in let r = _can_abstract s data in
if r then array_abstraction_performed := true; if r then array_abstraction_performed := true;
@ -382,7 +382,7 @@ let blur_array_index
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(index: Sil.exp) : Prop.normal Prop.t (index: Sil.exp) : Prop.normal Prop.t
= =
try try
let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in
let p2 = let p2 =
@ -415,7 +415,7 @@ let blur_array_indices
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(root: StrexpMatch.path) (root: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
= =
let f prop index = blur_array_index footprint_part prop root index in let f prop index = blur_array_index footprint_part prop root index in
(list_fold_left f p indices, list_length indices > 0) (list_fold_left f p indices, list_length indices > 0)
@ -426,7 +426,7 @@ let keep_only_indices
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
= =
let prune_sigma footprint_part sigma = let prune_sigma footprint_part sigma =
try try
let matched = StrexpMatch.find_path sigma path in let matched = StrexpMatch.find_path sigma path in
@ -559,8 +559,8 @@ let check_after_array_abstraction prop =
else list_iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel else list_iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel
| Sil.Estruct (fsel, _) -> | Sil.Estruct (fsel, _) ->
list_iter (fun (f, se) -> list_iter (fun (f, se) ->
let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in
let check_hpred = function let check_hpred = function
| Sil.Hpointsto (root, se, texp) -> | Sil.Hpointsto (root, se, texp) ->
let typ = Sil.texp_to_typ (Some Sil.Tvoid) texp in let typ = Sil.texp_to_typ (Some Sil.Tvoid) texp in
@ -593,7 +593,7 @@ let remove_redundant_elements prop =
let favl_foot = Sil.fav_to_list fav_foot in let favl_foot = Sil.fav_to_list fav_foot in
Sil.fav_duplicates := false; Sil.fav_duplicates := false;
(* L.d_str "favl_curr "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln(); (* L.d_str "favl_curr "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln();
L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *) L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *)
let num_occur l id = list_length (list_filter (fun id' -> Ident.equal id id') l) in let num_occur l id = list_length (list_filter (fun id' -> Ident.equal id id') l) in
let at_most_once v = let at_most_once v =
num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in

38
infer/src/backend/autounit.ml
Unescape View File

@ -21,7 +21,7 @@ module IdMap = Map.Make (Ident) (** maps from identifiers *)
(** Constraint solving module *) (** Constraint solving module *)
module Constraint : sig module Constraint : sig
(** Collect constraints on [vars] from [pi], and return a satisfying instantiation *) (** Collect constraints on [vars] from [pi], and return a satisfying instantiation *)
val solve_from_pure : Sil.atom list -> Ident.t list -> Sil.Int.t IdMap.t val solve_from_pure : Sil.atom list -> Ident.t list -> Sil.Int.t IdMap.t
end = struct end = struct
(** flag for debug mode of the module *) (** flag for debug mode of the module *)
@ -162,9 +162,9 @@ end = struct
if !found = None then search_down (); if !found = None then search_down ();
if !found = None then if !found = None then
(L.err "Constraint Error: empty range %a@." (pp_range id) rng; (L.err "Constraint Error: empty range %a@." (pp_range id) rng;
rng.top <- Some Sil.Int.zero; rng.top <- Some Sil.Int.zero;
rng.bottom <- Some Sil.Int.zero; rng.bottom <- Some Sil.Int.zero;
rng.excluded <- []) rng.excluded <- [])
(** return the solution if the id is solved (has unique solution) *) (** return the solution if the id is solved (has unique solution) *)
let solved ev id = let solved ev id =
@ -239,20 +239,20 @@ end = struct
add_excluded rng id n add_excluded rng id n
| Sil.Var id1, Sil.Var id2 -> | Sil.Var id1, Sil.Var id2 ->
(match solved ev id1, solved ev id2 with (match solved ev id1, solved ev id2 with
| None, None -> () | None, None -> ()
| Some _, Some _ -> () | Some _, Some _ -> ()
| Some n1, None -> | Some n1, None ->
do_neq (Sil.exp_int n1) e2 do_neq (Sil.exp_int n1) e2
| None, Some n2 -> | None, Some n2 ->
do_neq e1 (Sil.exp_int n2)) do_neq e1 (Sil.exp_int n2))
| Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint n)) -> | Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint n)) ->
(match solved ev id1, solved ev id2 with (match solved ev id1, solved ev id2 with
| None, None -> () | None, None -> ()
| Some _, Some _ -> () | Some _, Some _ -> ()
| Some n1, None -> | Some n1, None ->
do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2) do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2)
| None, Some n2 -> | None, Some n2 ->
do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n))) do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n)))
| _ -> if debug then assert false in | _ -> if debug then assert false in
let do_ident id = let do_ident id =
if debug then F.fprintf F.std_formatter "constraints before doing %a:@.%a@." (Ident.pp pe_text) id pp_eval ev; if debug then F.fprintf F.std_formatter "constraints before doing %a:@.%a@." (Ident.pp pe_text) id pp_eval ev;
@ -442,9 +442,9 @@ let gen_sigma code proc_name spec_num env idmap sigma =
list_iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel list_iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel
| Sil.Earray (size, esel, _) -> | Sil.Earray (size, esel, _) ->
list_iter (fun (e, se) -> list_iter (fun (e, se) ->
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in let index = pp_to_string pp () in
do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in
let gen_hpred = function let gen_hpred = function
| Sil.Hpointsto (Sil.Lvar pvar, se, _) -> | Sil.Hpointsto (Sil.Lvar pvar, se, _) ->

6
infer/src/backend/buckets.ml
Unescape View File

@ -17,7 +17,7 @@ open Utils
let verbose = Config.trace_error let verbose = Config.trace_error
(** check if the error was reported inside a nested loop (** check if the error was reported inside a nested loop
the implementation is approximate: check if the last two visits to a loop were entering loops *) the implementation is approximate: check if the last two visits to a loop were entering loops *)
let check_nested_loop path pos_opt = let check_nested_loop path pos_opt =
let trace_length = ref 0 in let trace_length = ref 0 in
let loop_visits_log = ref [] in let loop_visits_log = ref [] in
@ -28,7 +28,7 @@ let check_nested_loop path pos_opt =
| _ -> false in | _ -> false in
let do_node_caller node = match Cfg.Node.get_kind node with let do_node_caller node = match Cfg.Node.get_kind node with
| Cfg.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) -> | Cfg.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) ->
(* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *) (* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *)
loop_visits_log := b :: !loop_visits_log loop_visits_log := b :: !loop_visits_log
| _ -> () in | _ -> () in
let do_any_node level node = let do_any_node level node =
@ -44,7 +44,7 @@ let check_nested_loop path pos_opt =
in_nested_loop () in_nested_loop ()
(** Check that we know where the value was last assigned, (** Check that we know where the value was last assigned,
and that there is a local access instruction at that line. **) and that there is a local access instruction at that line. **)
let check_access access_opt de_opt = let check_access access_opt de_opt =
let find_bucket line_number null_case_flag = let find_bucket line_number null_case_flag =
let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *) let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *)

76
infer/src/backend/callbacks.ml
Unescape View File

@ -29,24 +29,24 @@ let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr
let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in
found instr instr' found instr instr'
| Sil.Letderef (id1, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc), [ret_id], [] | Sil.Letderef (id1, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc), [ret_id], []
when Sil.pvar_is_global pvar -> (* getter for static fields *) when Sil.pvar_is_global pvar -> (* getter for static fields *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in
found instr instr' found instr instr'
| Sil.Set (Sil.Lfield (ex1, fn, ft), bt , ex2, loc), _, [(e1, t1); (e2, t2)] -> (* setter for fields *) | Sil.Set (Sil.Lfield (ex1, fn, ft), bt , ex2, loc), _, [(e1, t1); (e2, t2)] -> (* setter for fields *)
let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in
found instr instr' found instr instr'
| Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , ex2, loc), _, [(e1, t1)] | Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , ex2, loc), _, [(e1, t1)]
when Sil.pvar_is_global pvar -> (* setter for static fields *) when Sil.pvar_is_global pvar -> (* setter for static fields *)
let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in
found instr instr' found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids' when list_length ret_ids = list_length ret_ids'
&& list_length etl' = list_length etl -> && list_length etl' = list_length etl ->
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in
found instr instr' found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids' when list_length ret_ids = list_length ret_ids'
&& list_length etl' + 1 = list_length etl -> && list_length etl' + 1 = list_length etl ->
let etl1 = match list_rev etl with (* remove last element *) let etl1 = match list_rev etl with (* remove last element *)
| _ :: l -> list_rev l | _ :: l -> list_rev l
| [] -> assert false in | [] -> assert false in
@ -61,15 +61,15 @@ let proc_inline_synthetic_methods cfg proc_desc : unit =
let instr_inline_synthetic_method = function let instr_inline_synthetic_method = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc, _) -> | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc, _) ->
(match Cfg.Procdesc.find_from_name cfg pn with (match Cfg.Procdesc.find_from_name cfg pn with
| Some pd -> | Some pd ->
let is_access = Procname.java_is_access_method pn in let is_access = Procname.java_is_access_method pn in
let attributes = Cfg.Procdesc.get_attributes pd in let attributes = Cfg.Procdesc.get_attributes pd in
let is_synthetic = attributes.Sil.is_synthetic_method in let is_synthetic = attributes.Sil.is_synthetic_method in
let is_bridge = attributes.Sil.is_bridge_method in let is_bridge = attributes.Sil.is_bridge_method in
if is_access || is_bridge || is_synthetic if is_access || is_bridge || is_synthetic
then inline_synthetic_method ret_ids etl pd pn loc then inline_synthetic_method ret_ids etl pd pn loc
else None else None
| None -> None) | None -> None)
| _ -> None in | _ -> None in
let node_inline_synthetic_methods node = let node_inline_synthetic_methods node =
let modified = ref false in let modified = ref false in
@ -119,10 +119,10 @@ let get_procedure_definition exe_env proc_name =
let tenv = Exe_env.get_tenv exe_env proc_name in let tenv = Exe_env.get_tenv exe_env proc_name in
Option.map Option.map
(fun proc_desc -> (fun proc_desc ->
proc_inline_synthetic_methods cfg proc_desc; proc_inline_synthetic_methods cfg proc_desc;
let idenv = Idenv.create cfg proc_desc let idenv = Idenv.create cfg proc_desc
and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in
(idenv, tenv, proc_name, proc_desc, language)) (idenv, tenv, proc_name, proc_desc, language))
(Cfg.Procdesc.find_from_name cfg proc_name) (Cfg.Procdesc.find_from_name cfg proc_name)
let get_language proc_name = if Procname.is_java proc_name then Sil.Java else Sil.C_CPP let get_language proc_name = if Procname.is_java proc_name then Sil.Java else Sil.C_CPP
@ -146,19 +146,19 @@ let iterate_procedure_callbacks all_procs exe_env proc_name =
Option.may Option.may
(fun (idenv, tenv, proc_name, proc_desc, language) -> (fun (idenv, tenv, proc_name, proc_desc, language) ->
list_iter list_iter
(fun (language_opt, proc_callback) -> (fun (language_opt, proc_callback) ->
let language_matches = match language_opt with let language_matches = match language_opt with
| Some language -> language = procedure_language | Some language -> language = procedure_language
| None -> true in | None -> true in
if language_matches then if language_matches then
begin begin
let init_time = Unix.gettimeofday () in let init_time = Unix.gettimeofday () in
proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc; proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc;
let elapsed = Unix.gettimeofday () -. init_time in let elapsed = Unix.gettimeofday () -. init_time in
update_time proc_name elapsed update_time proc_name elapsed
end) end)
!procedure_callbacks) !procedure_callbacks)
(get_procedure_definition exe_env proc_name) (get_procedure_definition exe_env proc_name)
(** Invoke all registered cluster callbacks on a cluster of procedures. *) (** Invoke all registered cluster callbacks on a cluster of procedures. *)
@ -187,9 +187,9 @@ let iterate_cluster_callbacks all_procs exe_env proc_names =
list_iter list_iter
(fun (language_opt, cluster_callback) -> (fun (language_opt, cluster_callback) ->
let proc_names = relevant_procedures language_opt in let proc_names = relevant_procedures language_opt in
if list_length proc_names > 0 then if list_length proc_names > 0 then
cluster_callback all_procs get_procdesc environment) cluster_callback all_procs get_procdesc environment)
!cluster_callbacks !cluster_callbacks
(** Invoke all procedure and cluster callbacks on a given environment. *) (** Invoke all procedure and cluster callbacks on a given environment. *)
@ -205,9 +205,9 @@ let iterate_callbacks store_summary call_graph exe_env =
let cluster_map = let cluster_map =
list_fold_left list_fold_left
(fun map proc_name -> (fun map proc_name ->
let proc_cluster = cluster_id proc_name in let proc_cluster = cluster_id proc_name in
let bucket = try StringMap.find proc_cluster map with Not_found -> [] in let bucket = try StringMap.find proc_cluster map with Not_found -> [] in
StringMap.add proc_cluster (proc_name:: bucket) map) StringMap.add proc_cluster (proc_name:: bucket) map)
StringMap.empty StringMap.empty
proc_names in proc_names in
(* Return all values of the map *) (* Return all values of the map *)

70
infer/src/backend/cfg.ml
Unescape View File

@ -249,7 +249,7 @@ module Node = struct
| Join_node, _ -> -1 | Join_node, _ -> -1
| _, Join_node -> 1 | _, Join_node -> 1
| Prune_node (is_true_branch1, if_kind1, descr1), | Prune_node (is_true_branch1, if_kind1, descr1),
Prune_node (is_true_branch2, if_kind2, descr2) -> Prune_node (is_true_branch2, if_kind2, descr2) ->
let n = bool_compare is_true_branch1 is_true_branch2 in let n = bool_compare is_true_branch1 is_true_branch2 in
if n <> 0 then n else let n = Pervasives.compare if_kind1 if_kind2 in if n <> 0 then n else let n = Pervasives.compare if_kind1 if_kind2 in
if n <> 0 then n else string_compare descr1 descr2 if n <> 0 then n else string_compare descr1 descr2
@ -373,11 +373,11 @@ module Node = struct
let proc_desc_remove cfg name remove_nodes = let proc_desc_remove cfg name remove_nodes =
(if remove_nodes then (if remove_nodes then
let pdesc = pdesc_tbl_find cfg name in let pdesc = pdesc_tbl_find cfg name in
let proc_nodes = let proc_nodes =
list_fold_right (fun node set -> NodeSet.add node set) list_fold_right (fun node set -> NodeSet.add node set)
pdesc.pd_nodes NodeSet.empty in pdesc.pd_nodes NodeSet.empty in
remove_node_set cfg proc_nodes); remove_node_set cfg proc_nodes);
pdesc_tbl_remove cfg name pdesc_tbl_remove cfg name
let proc_desc_get_start_node proc_desc = let proc_desc_get_start_node proc_desc =
@ -546,27 +546,27 @@ module Node = struct
let proc_desc_iter_slope f proc_desc = let proc_desc_iter_slope f proc_desc =
let visited = ref NodeSet.empty in let visited = ref NodeSet.empty in
let rec do_node node = begin let rec do_node node = begin
visited := NodeSet.add node !visited; visited := NodeSet.add node !visited;
f node; f node;
match get_succs node with match get_succs node with
| [n] -> if not (NodeSet.mem n !visited) then do_node n | [n] -> if not (NodeSet.mem n !visited) then do_node n
| _ -> () | _ -> ()
end in end in
do_node (proc_desc_get_start_node proc_desc) do_node (proc_desc_get_start_node proc_desc)
(** iterate between two nodes or until we reach a branching structure *) (** iterate between two nodes or until we reach a branching structure *)
let proc_desc_iter_slope_range f proc_desc src_node dst_node = let proc_desc_iter_slope_range f proc_desc src_node dst_node =
let visited = ref NodeSet.empty in let visited = ref NodeSet.empty in
let rec do_node node = begin let rec do_node node = begin
visited := NodeSet.add node !visited; visited := NodeSet.add node !visited;
f node; f node;
match get_succs node with match get_succs node with
| [n] -> | [n] ->
if not (NodeSet.mem n !visited) if not (NodeSet.mem n !visited)
&& not (equal node dst_node) && not (equal node dst_node)
then do_node n then do_node n
| _ -> () | _ -> ()
end in end in
do_node src_node do_node src_node
let proc_desc_iter_slope_calls f proc_desc = let proc_desc_iter_slope_calls f proc_desc =
@ -611,7 +611,7 @@ let save_source_files cfg =
Node.proc_desc_is_defined pdesc && Node.proc_desc_is_defined pdesc &&
Sys.file_exists source_file_str && Sys.file_exists source_file_str &&
(not (Sys.file_exists dest_file_str) || (not (Sys.file_exists dest_file_str) ||
DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in
if needs_copy then if needs_copy then
match Utils.copy_file source_file_str dest_file_str with match Utils.copy_file source_file_str dest_file_str with
| Some _ -> () | Some _ -> ()
@ -727,8 +727,8 @@ let get_defined_procs cfg =
(** Get the objc procedures whose body is generated *) (** Get the objc procedures whose body is generated *)
let get_objc_generated_procs cfg = let get_objc_generated_procs cfg =
list_filter ( list_filter (
fun procdesc -> fun procdesc ->
(Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg) (Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg)
(** get the function names which should be analyzed before the other ones *) (** get the function names which should be analyzed before the other ones *)
let get_priority_procnames cfg = let get_priority_procnames cfg =
@ -849,12 +849,12 @@ let remove_abducted_retvars p =
let abducted_pvars, normal_pvars = let abducted_pvars, normal_pvars =
list_fold_left list_fold_left
(fun pvars hpred -> (fun pvars hpred ->
match hpred with match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> | Sil.Hpointsto (Sil.Lvar pvar, _, _) ->
let abducted_pvars, normal_pvars = pvars in let abducted_pvars, normal_pvars = pvars in
if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars
else abducted_pvars, pvar :: normal_pvars else abducted_pvars, pvar :: normal_pvars
| _ -> pvars) | _ -> pvars)
([], []) ([], [])
(Prop.get_sigma p) in (Prop.get_sigma p) in
let _, p' = Prop.deallocate_stack_vars p abducted_pvars in let _, p' = Prop.deallocate_stack_vars p abducted_pvars in
@ -894,7 +894,7 @@ let remove_locals_ret (curr_f : Procdesc.t) p =
snd (remove_locals curr_f (remove_ret curr_f p)) snd (remove_locals curr_f (remove_ret curr_f p))
(** Remove locals and formal parameters from the prop. (** Remove locals and formal parameters from the prop.
Return the list of stack variables whose address was still present after deallocation. *) Return the list of stack variables whose address was still present after deallocation. *)
let remove_locals_formals (curr_f : Procdesc.t) p = let remove_locals_formals (curr_f : Procdesc.t) p =
let pvars1, p1 = remove_formals curr_f p in let pvars1, p1 = remove_formals curr_f p in
let pvars2, p2 = remove_locals curr_f p1 in let pvars2, p2 = remove_locals curr_f p1 in
@ -924,11 +924,11 @@ let check_cfg_connectedness cfg =
| Node.Stmt_node _ | Node.Prune_node _ | Node.Stmt_node _ | Node.Prune_node _
| Node.Skip_node _ -> (list_length succs = 0) || (list_length preds = 0) | Node.Skip_node _ -> (list_length succs = 0) || (list_length preds = 0)
| Node.Join_node -> | Node.Join_node ->
(* Join node has the exception that it may be without predecessors and pointing to an exit 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 *) (* if the if brances end with a return *)
(match succs with (match succs with
| [n'] when is_exit_node n' -> false | [n'] when is_exit_node n' -> false
| _ -> (list_length preds = 0)) in | _ -> (list_length preds = 0)) in
let do_pdesc pd = let do_pdesc pd =
let pname = Procname.to_string (Procdesc.get_proc_name pd) in let pname = Procname.to_string (Procdesc.get_proc_name pd) in
let nodes = Procdesc.get_nodes pd in let nodes = Procdesc.get_nodes pd in

18
infer/src/backend/cg.ml
Unescape View File

@ -53,15 +53,15 @@ let _add_node g n defined =
let info = Procname.Hash.find g.node_map n in let info = Procname.Hash.find g.node_map n in
if defined then info.defined <- true if defined then info.defined <- true
with Not_found -> with Not_found ->
let info = let info =
{ defined = defined; { defined = defined;
parents = Procname.Set.empty; parents = Procname.Set.empty;
children = Procname.Set.empty; children = Procname.Set.empty;
ancestors = None; ancestors = None;
heirs = None; heirs = None;
recursive_dependents = None; recursive_dependents = None;
in_out_calls = None } in in_out_calls = None } in
Procname.Hash.add g.node_map n info Procname.Hash.add g.node_map n info
let add_node g n = let add_node g n =
_add_node g n true _add_node g n true

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

@ -56,10 +56,10 @@ let find_comment_start_and_style lines_arr n =
let is_start line = match cur_line_comment with let is_start line = match cur_line_comment with
| Some (Line (s)) -> if string_is_prefix s line then None else Some (Line (s)) | Some (Line (s)) -> if string_is_prefix s line then None else Some (Line (s))
| _ -> try | _ -> try
Some (list_find (function Some (list_find (function
| Block(s, _, _) -> string_contains s line | Block(s, _, _) -> string_contains s line
| _ -> false) comment_styles) | _ -> false) comment_styles)
with Not_found -> None in with Not_found -> None in
let i = ref (n - 1) in let i = ref (n - 1) in
(* hacky fake line comment to avoid an option type *) (* hacky fake line comment to avoid an option type *)
let found = ref (-1, Line(">>>>>>>>>>>")) in let found = ref (-1, Line(">>>>>>>>>>>")) in

64
infer/src/backend/config.ml
Unescape View File

@ -113,31 +113,31 @@ let project_root : string option ref = ref None
(** FLAGS AND GLOBAL VARIABLES *) (** FLAGS AND GLOBAL VARIABLES *)
(** Flag for abstracting fields of structs (** Flag for abstracting fields of structs
0 = no 0 = no
1 = forget some fields during matching (and so lseg abstraction) *) 1 = forget some fields during matching (and so lseg abstraction) *)
let abs_struct = ref 1 let abs_struct = ref 1
(** Flag for abstracting numerical values (** Flag for abstracting numerical values
0 = no abstraction. 0 = no abstraction.
1 = evaluate all expressions abstractly. 1 = evaluate all expressions abstractly.
2 = 1 + abstract constant integer values during join. 2 = 1 + abstract constant integer values during join.
*) *)
let abs_val = ref 2 let abs_val = ref 2
(** if true, completely ignore the possibility that errors can be caused by unknown procedures (** if true, completely ignore the possibility that errors can be caused by unknown procedures
* during the symbolic execution phase *) * during the symbolic execution phase *)
let angelic_execution = ref true let angelic_execution = ref true
(** Flag for forgetting memory leak (** Flag for forgetting memory leak
false = no false = no
true = forget leaked memory cells during abstraction true = forget leaked memory cells during abstraction
*) *)
let allowleak = ref false let allowleak = ref false
(** Flag for ignoring arrays and pointer arithmetic. (** Flag for ignoring arrays and pointer arithmetic.
0 = treats both features soundly. 0 = treats both features soundly.
1 = assumes that the size of every array is infinite. 1 = assumes that the size of every array is infinite.
2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct. 2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct.
*) *)
let array_level = ref 0 let array_level = ref 0
@ -186,14 +186,14 @@ let intraprocedural = ref false
let join_plus = ref true let join_plus = ref true
(** Flag to tune the final information-loss check used by the join (** Flag to tune the final information-loss check used by the join
0 = use the most aggressive join for preconditions 0 = use the most aggressive join for preconditions
1 = use the least aggressive join for preconditions 1 = use the least aggressive join for preconditions
*) *)
let join_cond = ref 1 let join_cond = ref 1
(** Flag for turning on the transformation that (** Flag for turning on the transformation that
null is assigned to a program variable when it becomes dead. null is assigned to a program variable when it becomes dead.
**) **)
let liveness = ref true let liveness = ref true
(** if true, give static procs a long name filename::procname *) (** if true, give static procs a long name filename::procname *)
@ -212,9 +212,9 @@ let max_num_proc = ref 0
let max_recursion = ref 5 let max_recursion = ref 5
(** Flag to tune the level of applying the meet operator for (** Flag to tune the level of applying the meet operator for
preconditions during the footprint analysis. preconditions during the footprint analysis.
0 = do not use the meet. 0 = do not use the meet.
1 = use the meet to generate new preconditions. 1 = use the meet to generate new preconditions.
*) *)
let meet_level = ref 1 let meet_level = ref 1
@ -258,9 +258,9 @@ let results_dir = ref default_results_dir
let slice_fun = ref "" let slice_fun = ref ""
(** Flag to tune the level of abstracting the postconditions of specs discovered (** Flag to tune the level of abstracting the postconditions of specs discovered
by the footprint analysis. by the footprint analysis.
0 = nothing special. 0 = nothing special.
1 = filter out redundant posts implied by other posts. *) 1 = filter out redundant posts implied by other posts. *)
let spec_abs_level = ref 1 let spec_abs_level = ref 1
(** Flag for test mode *) (** Flag for test mode *)
@ -294,15 +294,15 @@ let taint_analysis = ref false
let trace_anal = ref false let trace_anal = ref false
(** Flag for turning on the optimization based on locality (** Flag for turning on the optimization based on locality
0 = no 0 = no
1 = based on reachability 1 = based on reachability
*) *)
let undo_join = ref true let undo_join = ref true
(** visit mode for the worklist: (** visit mode for the worklist:
0 depth - fist visit 0 depth - fist visit
1 bias towards exit node 1 bias towards exit node
2 least visited first *) 2 least visited first *)
let worklist_mode = ref 0 let worklist_mode = ref 0
(** flag: if true write dot files in db dir*) (** flag: if true write dot files in db dir*)
@ -328,16 +328,16 @@ let show_ml_buckets = ref false
let dotty_cfg_libs = ref true let dotty_cfg_libs = ref true
(** if true, it deals with messages (method calls) in objective-c using the objective-c (** if true, it deals with messages (method calls) in objective-c using the objective-c
typical semantics. That is: if the receiver is nil then the method is nop and it returns 0. typical semantics. That is: if the receiver is nil then the method is nop and it returns 0.
When the flag is false we deal with messages as standard method / function calls *) When the flag is false we deal with messages as standard method / function calls *)
let objc_method_call_semantics = ref true let objc_method_call_semantics = ref true
(** if true, generate preconditions for runtime exceptions in Java and report errors for the public (** if true, generate preconditions for runtime exceptions in Java and report errors for the public
methods having preconditions to throw runtime exceptions *) methods having preconditions to throw runtime exceptions *)
let report_runtime_exceptions = ref false let report_runtime_exceptions = ref false
(** if true, sanity-check inferred preconditions against Nullable annotations and report (** if true, sanity-check inferred preconditions against Nullable annotations and report
inconsistencies *) inconsistencies *)
let report_nullable_inconsistency = ref true let report_nullable_inconsistency = ref true
(** true if the current objective-c source file is compiled with automatic reference counting (ARC) *) (** true if the current objective-c source file is compiled with automatic reference counting (ARC) *)
@ -356,11 +356,11 @@ module Experiment = struct
let activate_subtyping_in_cpp = ref false let activate_subtyping_in_cpp = ref false
(** if true, a precondition with e.g. index 3 in an array does not require the caller to have index 3 too (** if true, a precondition with e.g. index 3 in an array does not require the caller to have index 3 too
this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *) this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *)
let allow_missing_index_in_proc_call = ref true let allow_missing_index_in_proc_call = ref true
(** if true, a procedure call succeeds even when there is a bound error (** if true, a procedure call succeeds even when there is a bound error
this mimics what happens with a direct array access where an error is produced and the analysis continues *) this mimics what happens with a direct array access where an error is produced and the analysis continues *)
let bound_error_allowed_in_procedure_call = ref true let bound_error_allowed_in_procedure_call = ref true
end end

246
infer/src/backend/dom.ml
Unescape View File

@ -85,13 +85,13 @@ let do_side side f e1 e2 =
(** {2 Sets for expression pairs} *) (** {2 Sets for expression pairs} *)
module EPset = Set.Make module EPset = Set.Make
(struct (struct
type t = Sil.exp * Sil.exp type t = Sil.exp * Sil.exp
let compare (e1, e1') (e2, e2') = let compare (e1, e1') (e2, e2') =
match (Sil.exp_compare e1 e2) with match (Sil.exp_compare e1 e2) with
| i when i <> 0 -> i | i when i <> 0 -> i
| _ -> Sil.exp_compare e1' e2' | _ -> Sil.exp_compare e1' e2'
end) end)
let epset_add e e' set = let epset_add e e' set =
match (Sil.exp_compare e e') with match (Sil.exp_compare e e') with
@ -479,16 +479,16 @@ end = struct
let (_, _, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in let (_, _, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in
e e
with Not_found -> with Not_found ->
let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in
t := (e1, e2, e)::!t; t := (e1, e2, e)::!t;
e e
let lookup side e = let lookup side e =
try try
let (e1, e2, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in let (e1, e2, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in
Some (e, select (opposite side) e1 e2) Some (e, select (opposite side) e1 e2)
with Not_found -> with Not_found ->
None None
let get_induced_atom acc strict_lower upper e = let get_induced_atom acc strict_lower upper e =
let ineq_lower = Prop.mk_inequality (Sil.BinOp(Sil.Lt, strict_lower, e)) in let ineq_lower = Prop.mk_inequality (Sil.BinOp(Sil.Lt, strict_lower, e)) in
@ -516,8 +516,8 @@ end = struct
let eqs_acc' = eq:: eqs_acc in let eqs_acc' = eq:: eqs_acc in
f_eqs_entry entry eqs_acc' t_seen t_rest' f_eqs_entry entry eqs_acc' t_seen t_rest'
with Not_found -> with Not_found ->
let t_seen' = entry':: t_seen in let t_seen' = entry':: t_seen in
f_eqs_entry entry eqs_acc t_seen' t_rest' in f_eqs_entry entry eqs_acc t_seen' t_rest' in
let rec f_eqs eqs_acc t_acc = function let rec f_eqs eqs_acc t_acc = function
| [] -> (eqs_acc, t_acc) | [] -> (eqs_acc, t_acc)
| entry:: t_rest -> | entry:: t_rest ->
@ -610,12 +610,12 @@ end = struct
let res = ref [] in let res = ref [] in
let f v = match v, side with let f v = match v, side with
| (Sil.BinOp (Sil.PlusA, e1', Sil.Const (Sil.Cint i)), e2, e'), Lhs | (Sil.BinOp (Sil.PlusA, e1', Sil.Const (Sil.Cint i)), e2, e'), Lhs
when Sil.exp_equal e e1' -> when Sil.exp_equal e e1' ->
let c' = Sil.exp_int (Sil.Int.neg i) in let c' = Sil.exp_int (Sil.Int.neg i) in
let v' = (e1', Sil.BinOp(Sil.PlusA, e2, c'), Sil.BinOp (Sil.PlusA, e', c')) in let v' = (e1', Sil.BinOp(Sil.PlusA, e2, c'), Sil.BinOp (Sil.PlusA, e', c')) in
res := v'::!res res := v'::!res
| (e1, Sil.BinOp (Sil.PlusA, e2', Sil.Const (Sil.Cint i)), e'), Rhs | (e1, Sil.BinOp (Sil.PlusA, e2', Sil.Const (Sil.Cint i)), e'), Rhs
when Sil.exp_equal e e2' -> when Sil.exp_equal e e2' ->
let c' = Sil.exp_int (Sil.Int.neg i) in let c' = Sil.exp_int (Sil.Int.neg i) in
let v' = (Sil.BinOp(Sil.PlusA, e1, c'), e2', Sil.BinOp (Sil.PlusA, e', c')) in let v' = (Sil.BinOp(Sil.PlusA, e1, c'), e2', Sil.BinOp (Sil.PlusA, e', c')) in
res := v'::!res res := v'::!res
@ -705,11 +705,11 @@ end = struct
let others = get_others_direct_or_induced side e in let others = get_others_direct_or_induced side e in
let others' = get_others_direct_or_induced side e' in let others' = get_others_direct_or_induced side e' in
(match others, others' with (match others, others' with
| None, _ | _, None -> None | None, _ | _, None -> None
| Some (e_res, e_op), Some(e_res', e_op') -> | Some (e_res, e_op), Some(e_res', e_op') ->
let e_res'' = Sil.BinOp(op, e_res, e_res') in let e_res'' = Sil.BinOp(op, e_res, e_res') in
let e_op'' = Sil.BinOp(op, e_op, e_op') in let e_op'' = Sil.BinOp(op, e_op, e_op') in
Some (e_res'', e_op'')) Some (e_res'', e_op''))
| _ -> None | _ -> None
let get_other_atoms side atom_in = let get_other_atoms side atom_in =
@ -739,22 +739,22 @@ end = struct
begin begin
match atom_in with match atom_in with
| Sil.Aneq((Sil.Var id as e), e') | Sil.Aneq(e', (Sil.Var id as e)) | Sil.Aneq((Sil.Var id as e), e') | Sil.Aneq(e', (Sil.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_neq e0 e') side e build_other_atoms (fun e0 -> Prop.mk_neq e0 e') side e
| Sil.Aeq((Sil.Var id as e), e') | Sil.Aeq(e', (Sil.Var id as e)) | Sil.Aeq((Sil.Var id as e), e') | Sil.Aeq(e', (Sil.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_eq e0 e') side e build_other_atoms (fun e0 -> Prop.mk_eq e0 e') side e
| Sil.Aeq(Sil.BinOp(Sil.Le, e, e'), Sil.Const (Sil.Cint i)) | Sil.Aeq(Sil.BinOp(Sil.Le, e, e'), Sil.Const (Sil.Cint i))
| Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Le, e, e')) | Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Le, e, e'))
when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Le, e0, e')) in let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Le, e0, e')) in
build_other_atoms construct side e build_other_atoms construct side e
| Sil.Aeq(Sil.BinOp(Sil.Lt, e', e), Sil.Const (Sil.Cint i)) | Sil.Aeq(Sil.BinOp(Sil.Lt, e', e), Sil.Const (Sil.Cint i))
| Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Lt, e', e)) | Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Lt, e', e))
when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Lt, e', e0)) in let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Lt, e', e0)) in
build_other_atoms construct side e build_other_atoms construct side e
@ -764,31 +764,31 @@ end = struct
type data_opt = ExtFresh | ExtDefault of Sil.exp type data_opt = ExtFresh | ExtDefault of Sil.exp
(* Extend the renaming relation. At least one of e1 and e2 (* Extend the renaming relation. At least one of e1 and e2
* should be a primed or footprint variable *) * should be a primed or footprint variable *)
let extend e1 e2 default_op = let extend e1 e2 default_op =
try try
let eq_to_e (f1, f2, _) = Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2 in let eq_to_e (f1, f2, _) = Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2 in
let _, _, res = list_find eq_to_e !tbl in let _, _, res = list_find eq_to_e !tbl in
res res
with Not_found -> with Not_found ->
let fav1 = Sil.exp_fav e1 in let fav1 = Sil.exp_fav e1 in
let fav2 = Sil.exp_fav e2 in let fav2 = Sil.exp_fav e2 in
let no_ren1 = not (Sil.fav_exists fav1 can_rename) in let no_ren1 = not (Sil.fav_exists fav1 can_rename) in
let no_ren2 = not (Sil.fav_exists fav2 can_rename) in let no_ren2 = not (Sil.fav_exists fav2 can_rename) in
let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in
let e = let e =
if (no_ren1 && no_ren2) then if (no_ren1 && no_ren2) then
if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail) if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail)
else else
match default_op with match default_op with
| ExtDefault e -> e | ExtDefault e -> e
| ExtFresh -> | ExtFresh ->
let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in
Sil.Var (Ident.create_fresh kind) in Sil.Var (Ident.create_fresh kind) in
let entry = e1, e2, e in let entry = e1, e2, e in
push entry; push entry;
Todo.push entry; Todo.push entry;
e e
let pp pe f renaming = let pp pe f renaming =
let pp_triple f (e1, e2, e3) = let pp_triple f (e1, e2, e3) =
@ -928,15 +928,15 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const _), Sil.Var id2 | Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const _), Sil.Var id2
| Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const _) | Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const _)
when ident_same_kind_primed_footprint id1 id2 -> when ident_same_kind_primed_footprint id1 id2 ->
Rename.extend e1 e2 Rename.ExtFresh Rename.extend e1 e2 Rename.ExtFresh
| Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const (Sil.Cint c1)), Sil.Const (Sil.Cint c2) | Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const (Sil.Cint c1)), Sil.Const (Sil.Cint c2)
when can_rename id1 -> when can_rename id1 ->
let c2' = c2 -- c1 in let c2' = c2 -- c1 in
let e_res = Rename.extend (Sil.Var id1) (Sil.exp_int c2') Rename.ExtFresh in let e_res = Rename.extend (Sil.Var id1) (Sil.exp_int c2') Rename.ExtFresh in
Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c1) Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c1)
| Sil.Const (Sil.Cint c1), Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint c2)) | Sil.Const (Sil.Cint c1), Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint c2))
when can_rename id2 -> when can_rename id2 ->
let c1' = c1 -- c2 in let c1' = c1 -- c2 in
let e_res = Rename.extend (Sil.exp_int c1') (Sil.Var id2) Rename.ExtFresh in let e_res = Rename.extend (Sil.exp_int c1') (Sil.Var id2) Rename.ExtFresh in
Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c2) Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c2)
@ -1062,10 +1062,10 @@ let run_without_absval f e1 e2 =
e e
end end
with exn -> with exn ->
begin begin
Config.abs_val := old_abs_val; Config.abs_val := old_abs_val;
raise exn raise exn
end end
let exp_partial_join_without_absval e1 e2 = let exp_partial_join_without_absval e1 e2 =
run_without_absval exp_partial_join e1 e2 run_without_absval exp_partial_join e1 e2
@ -1187,7 +1187,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st
let inst = Sil.inst_partial_meet inst1 inst2 in let inst = Sil.inst_partial_meet inst1 inst2 in
f_fld_se_list inst [] fld_se_list1 fld_se_list2 f_fld_se_list inst [] fld_se_list1 fld_se_list2
| Sil.Earray (size1, idx_se_list1, inst1), Sil.Earray (size2, idx_se_list2, inst2) | Sil.Earray (size1, idx_se_list1, inst1), Sil.Earray (size2, idx_se_list2, inst2)
when Sil.exp_equal size1 size2 -> when Sil.exp_equal size1 size2 ->
let inst = Sil.inst_partial_meet inst1 inst2 in let inst = Sil.inst_partial_meet inst1 inst2 in
f_idx_se_list inst size1 [] idx_se_list1 idx_se_list2 f_idx_se_list inst size1 [] idx_se_list1 idx_se_list2
| _ -> (L.d_strln "failure reason 52"; raise Fail) | _ -> (L.d_strln "failure reason 52"; raise Fail)
@ -1250,7 +1250,7 @@ let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpr
let shared' = exp_list_partial_join shared1 shared2 in let shared' = exp_list_partial_join shared1 shared2 in
Prop.mk_lseg (kind_join k1 k2) hpara' e next' shared' Prop.mk_lseg (kind_join k1 k2) hpara' e next' shared'
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1), | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1),
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
let fwd1 = Sil.exp_equal e1 iF1 in let fwd1 = Sil.exp_equal e1 iF1 in
let fwd2 = Sil.exp_equal e2 iF2 in let fwd2 = Sil.exp_equal e2 iF2 in
let hpara' = hpara_dll_partial_join para1 para2 in let hpara' = hpara_dll_partial_join para1 para2 in
@ -1278,7 +1278,7 @@ let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (
let shared' = exp_list_partial_meet shared1 shared2 in let shared' = exp_list_partial_meet shared1 shared2 in
Prop.mk_lseg (kind_meet k1 k2) hpara' e next' shared' Prop.mk_lseg (kind_meet k1 k2) hpara' e next' shared'
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1), | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1),
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
let fwd1 = Sil.exp_equal e1 iF1 in let fwd1 = Sil.exp_equal e1 iF1 in
let fwd2 = Sil.exp_equal e2 iF2 in let fwd2 = Sil.exp_equal e2 iF2 in
let hpara' = hpara_dll_partial_meet para1 para2 in let hpara' = hpara_dll_partial_meet para1 para2 in
@ -1321,11 +1321,11 @@ let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool =
| _ -> false | _ -> false
(* check that applying renaming to the lhs / rhs of [sigma_new] (* check that applying renaming to the lhs / rhs of [sigma_new]
* gives [sigma] and that the renaming is injective *) * gives [sigma] and that the renaming is injective *)
let sigma_renaming_check (lhs: side) (sigma: sigma) (sigma_new: sigma) = let sigma_renaming_check (lhs: side) (sigma: sigma) (sigma_new: sigma) =
(* apply the lhs / rhs of the renaming to sigma, (* apply the lhs / rhs of the renaming to sigma,
* and check that the renaming of primed vars is injective *) * and check that the renaming of primed vars is injective *)
let fav_sigma = Prop.sigma_fav sigma_new in let fav_sigma = Prop.sigma_fav sigma_new in
let sub = Rename.to_subst_proj lhs fav_sigma in let sub = Rename.to_subst_proj lhs fav_sigma in
let sigma' = Prop.sigma_sub sub sigma_new in let sigma' = Prop.sigma_sub sub sigma_new in
@ -1352,7 +1352,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) | Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iF e -> when Sil.exp_equal iF e ->
let oF' = do_side side exp_partial_join oF opposite in let oF' = do_side side exp_partial_join oF opposite in
let shared' = Rename.lookup_list side shared in let shared' = Rename.lookup_list side shared in
let oB', iB' = lookup_and_expand side oB iB in let oB', iB' = lookup_and_expand side oB iB in
@ -1365,7 +1365,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared') Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) | Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iB e -> when Sil.exp_equal iB e ->
let oB' = do_side side exp_partial_join oB opposite in let oB' = do_side side exp_partial_join oB opposite in
let shared' = Rename.lookup_list side shared in let shared' = Rename.lookup_list side shared in
let oF', iF' = lookup_and_expand side oF iF in let oF', iF' = lookup_and_expand side oF iF in
@ -1397,8 +1397,8 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
| _ -> assert false in | _ -> assert false in
(* Drop the part of 'other' sigma corresponding to 'target' sigma if possible. (* Drop the part of 'other' sigma corresponding to 'target' sigma if possible.
'side' describes that target is Lhs or Rhs. 'side' describes that target is Lhs or Rhs.
'todo' describes the start point. *) 'todo' describes the start point. *)
let cut_sigma side todo (target: sigma) (other: sigma) = let cut_sigma side todo (target: sigma) (other: sigma) =
let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise Fail) in let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise Fail) in
@ -1482,7 +1482,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
sigma_partial_join' mode sigma_acc' sigma1' sigma2 sigma_partial_join' mode sigma_acc' sigma1' sigma2
| Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2) | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2)
when Sil.exp_equal e1 iF1 -> when Sil.exp_equal e1 iF1 ->
let iB_res = exp_partial_join iB1 e2 in let iB_res = exp_partial_join iB1 e2 in
let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2:: sigma2) in let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2:: sigma2) in
let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in
@ -1498,7 +1498,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
sigma_partial_join' mode sigma_acc' sigma1 sigma2' sigma_partial_join' mode sigma_acc' sigma1 sigma2'
| Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) | Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg)
when Sil.exp_equal e2 iF2 -> when Sil.exp_equal e2 iF2 ->
let iB_res = exp_partial_join e1 iB2 in let iB_res = exp_partial_join e1 iB2 in
let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1:: sigma1) in let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1:: sigma1) in
let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in
@ -1516,9 +1516,9 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
assert false (* Should be handled by a guarded case *) assert false (* Should be handled by a guarded case *)
with Todo.Empty -> with Todo.Empty ->
match sigma1_in, sigma2_in with match sigma1_in, sigma2_in with
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail | _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
| _ -> sigma_acc, sigma1_in, sigma2_in | _ -> sigma_acc, sigma1_in, sigma2_in
let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * sigma) = let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * sigma) =
CheckJoin.init mode sigma1 sigma2; CheckJoin.init mode sigma1 sigma2;
@ -1568,9 +1568,9 @@ let rec sigma_partial_meet' (sigma_acc: sigma) (sigma1_in: sigma) (sigma2_in: si
(L.d_strln "failure reason 65"; raise Fail) (L.d_strln "failure reason 65"; raise Fail)
with Todo.Empty -> with Todo.Empty ->
match sigma1_in, sigma2_in with match sigma1_in, sigma2_in with
| [], [] -> sigma_acc | [], [] -> sigma_acc
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail | _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
let sigma_partial_meet (sigma1: sigma) (sigma2: sigma) : sigma = let sigma_partial_meet (sigma1: sigma) (sigma2: sigma) : sigma =
sigma_partial_meet' [] sigma1 sigma2 sigma_partial_meet' [] sigma1 sigma2
@ -1582,7 +1582,7 @@ let widening_bottom = Sil.Int.of_int64 Int64.min_int ++ Sil.Int.of_int 1000 (* n
let pi_partial_join mode let pi_partial_join mode
(ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t)
(pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list (pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list
= =
let exp_is_const = function let exp_is_const = function
(* | Sil.Var id -> is_normal id *) (* | Sil.Var id -> is_normal id *)
| Sil.Const _ -> true | Sil.Const _ -> true
@ -1668,19 +1668,19 @@ let pi_partial_join mode
match join_atom size p_op pi_op a with match join_atom size p_op pi_op a with
| None -> | None ->
(match widening_atom a with (match widening_atom a with
| None -> atom_list | None -> atom_list
| Some a' -> | Some a' ->
(match join_atom size p_op pi_op a' with (match join_atom size p_op pi_op a' with
| None -> atom_list | None -> atom_list
| Some a' -> a' :: atom_list)) | Some a' -> a' :: atom_list))
| Some a' -> a' :: atom_list in | Some a' -> a' :: atom_list in
let filter_atom = function let filter_atom = function
| Sil.Aneq(e, e') | Sil.Aeq(e, e') | Sil.Aneq(e, e') | Sil.Aeq(e, e')
when (exp_is_const e && exp_is_const e') -> when (exp_is_const e && exp_is_const e') ->
true true
| Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id) | Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id)
| Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id) | Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id)
when (exp_is_const e') -> when (exp_is_const e') ->
true true
| Sil.Aneq _ -> false | Sil.Aneq _ -> false
| e -> Prop.atom_is_inequality e in | e -> Prop.atom_is_inequality e in
@ -1769,12 +1769,12 @@ let prop_partial_meet p1 p2 =
Rename.final (); FreshVarExp.final (); Todo.final (); Rename.final (); FreshVarExp.final (); Todo.final ();
Some res Some res
with exn -> with exn ->
begin begin
Rename.final (); FreshVarExp.final (); Todo.final (); Rename.final (); FreshVarExp.final (); Todo.final ();
match exn with match exn with
| Fail -> None | Fail -> None
| _ -> raise exn | _ -> raise exn
end end
let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t = let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
SymOp.pay(); (* pay one symop *) SymOp.pay(); (* pay one symop *)
@ -1872,11 +1872,11 @@ let prop_partial_join pname tenv mode p1 p2 =
Rename.final (); FreshVarExp.final (); Todo.final (); Rename.final (); FreshVarExp.final (); Todo.final ();
res res
with exn -> with exn ->
begin begin
Rename.final (); FreshVarExp.final (); Todo.final (); Rename.final (); FreshVarExp.final (); Todo.final ();
(if !Config.footprint then JoinState.set_footprint false); (if !Config.footprint then JoinState.set_footprint false);
(match exn with Fail -> None | _ -> raise exn) (match exn with Fail -> None | _ -> raise exn)
end end
end end
| Some _ -> res_by_implication_only | Some _ -> res_by_implication_only
@ -1894,19 +1894,19 @@ let list_reduce name dd f list =
let rec element_list_reduce acc (x, p1) = function let rec element_list_reduce acc (x, p1) = function
| [] -> ((x, p1), list_rev acc) | [] -> ((x, p1), list_rev acc)
| (y, p2):: ys -> begin | (y, p2):: ys -> begin
L.d_strln ("COMBINE[" ^ name ^ "] ...."); L.d_strln ("COMBINE[" ^ name ^ "] ....");
L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln (); L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln ();
L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln (); L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln ();
L.d_ln (); L.d_ln ();
match f x y with match f x y with
| None -> | None ->
L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ..."); L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ...");
element_list_reduce ((y, p2):: acc) (x, p1) ys element_list_reduce ((y, p2):: acc) (x, p1) ys
| Some x' -> | Some x' ->
L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ...."); L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ....");
L.d_strln "RESULT:"; dd x'; L.d_ln (); L.d_strln "RESULT:"; dd x'; L.d_ln ();
element_list_reduce acc (x', p1) ys element_list_reduce acc (x', p1) ys
end in end in
let rec reduce acc = function let rec reduce acc = function
| [] -> list_rev acc | [] -> list_rev acc
| x:: xs -> | x:: xs ->
@ -1966,7 +1966,7 @@ let join_time = ref 0.0
let pathset_join let pathset_join
pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t)
: Paths.PathSet.t * Paths.PathSet.t = : Paths.PathSet.t * Paths.PathSet.t =
let mode = JoinState.Post in let mode = JoinState.Post in
let initial_time = Unix.gettimeofday () in let initial_time = Unix.gettimeofday () in
let pset_to_plist pset = let pset_to_plist pset =
@ -1977,18 +1977,18 @@ let pathset_join
let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function
| [] -> (ppa2, list_rev ppalist2_acc) | [] -> (ppa2, list_rev ppalist2_acc)
| ((p2', pa2') as ppa2') :: ppalist2_rest -> begin | ((p2', pa2') as ppa2') :: ppalist2_rest -> begin
L.d_strln ".... JOIN ...."; L.d_strln ".... JOIN ....";
L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln (); L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln ();
L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln (); L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln ();
match prop_partial_join pname tenv mode p2 p2' with match prop_partial_join pname tenv mode p2 p2' with
| None -> | None ->
L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln (); L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln ();
join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest
| Some p2'' -> | Some p2'' ->
L.d_strln_color Green ".... JOIN SUCCEEDED ...."; L.d_strln_color Green ".... JOIN SUCCEEDED ....";
L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln (); L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln ();
join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest
end in end in
let rec join ppalist1_cur ppalist2_acc = function let rec join ppalist1_cur ppalist2_acc = function
| [] -> (ppalist1_cur, ppalist2_acc) | [] -> (ppalist1_cur, ppalist2_acc)
| ppa2:: ppalist2_rest -> | ppa2:: ppalist2_rest ->
@ -2004,14 +2004,14 @@ let pathset_join
res res
(** (**
The meet operator does two things: The meet operator does two things:
1) makes the result logically stronger (just like additive conjunction) 1) makes the result logically stronger (just like additive conjunction)
2) makes the result spatially larger (just like multiplicative conjunction). 2) makes the result spatially larger (just like multiplicative conjunction).
Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means
that the results are more predictable), try to combine every element of plist with any other element. that the results are more predictable), try to combine every element of plist with any other element.
Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic. Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic.
The operation is dependent on the order in which elements are combined; there is a straightforward The operation is dependent on the order in which elements are combined; there is a straightforward
order - independent algorithm but it is exponential. order - independent algorithm but it is exponential.
*) *)
let proplist_meet_generate plist = let proplist_meet_generate plist =
let props_done = ref Propset.empty in let props_done = ref Propset.empty in
@ -2031,9 +2031,9 @@ let proplist_meet_generate plist =
let rec proplist_meet = function let rec proplist_meet = function
| [] -> () | [] -> ()
| (porig, pcombined) :: pplist -> | (porig, pcombined) :: pplist ->
(* use porig instead of pcombined because it might be combinable with more othe props *) (* use porig instead of pcombined because it might be combinable with more othe props *)
(* e.g. porig might contain a global var to add to the ture branch of a conditional *) (* e.g. porig might contain a global var to add to the ture branch of a conditional *)
(* but pcombined might have been combined with the false branch already *) (* but pcombined might have been combined with the false branch already *)
let pplist' = list_map (combine porig) pplist in let pplist' = list_map (combine porig) pplist in
props_done := Propset.add pcombined !props_done; props_done := Propset.add pcombined !props_done;
proplist_meet pplist' in proplist_meet pplist' in

330
infer/src/backend/dotty.ml
Unescape View File

@ -264,32 +264,32 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list
incr dotty_state_count; incr dotty_state_count;
let coo = mk_coordinate n lambda in let coo = mk_coordinate n lambda in
(match hpred with (match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) ->
let e_color_str = color_to_str (exp_color hpred e) in let e_color_str = color_to_str (exp_color hpred e) in
[Dotdangling(coo, e, e_color_str)] [Dotdangling(coo, e, e_color_str)]
| Sil.Hlseg (k, hpara, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> | Sil.Hlseg (k, hpara, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) ->
let e2_color_str = color_to_str (exp_color hpred e2) in let e2_color_str = color_to_str (exp_color hpred e2) in
[Dotdangling(coo, e2, e2_color_str)] [Dotdangling(coo, e2, e2_color_str)]
| Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist) -> | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist) ->
let e2_color_str = color_to_str (exp_color hpred e2) in let e2_color_str = color_to_str (exp_color hpred e2) in
let e3_color_str = color_to_str (exp_color hpred e3) in let e3_color_str = color_to_str (exp_color hpred e3) in
let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then
[Dotdangling(coo, e2, e2_color_str)] [Dotdangling(coo, e2, e2_color_str)]
else [] in else [] in
if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll
else ll else ll
| Sil.Hpointsto (_, _, _) | Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings*) | _ -> [] (* arrays and struct do not give danglings*)
) in ) in
let is_allocated d = let is_allocated d =
match d with match d with
| Dotdangling(_, e, _) -> | Dotdangling(_, e, _) ->
list_exists (fun a -> match a with list_exists (fun a -> match a with
| Dotpointsto(_, e', _) | Dotpointsto(_, e', _)
| Dotarray(_, _, e', _, _, _) | Dotarray(_, _, e', _, _, _)
| Dotlseg(_, e', _, _, _, _) | Dotlseg(_, e', _, _, _, _)
| Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e' | Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e'
| _ -> false | _ -> false
) allocated_nodes ) allocated_nodes
| _ -> false (*this should never happen since d must be a dangling node *) in | _ -> false (*this should never happen since d must be a dangling node *) in
let rec filter_duplicate l seen_exp = let rec filter_duplicate l seen_exp =
@ -353,7 +353,7 @@ let set_exps_neq_zero pi =
let box_dangling e = let box_dangling e =
let entry_e = list_filter (fun b -> match b with let entry_e = list_filter (fun b -> match b with
| Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in | Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in
match entry_e with match entry_e with
|[] -> None |[] -> None
| Dotdangling(coo, _, _):: _ -> Some coo.id | Dotdangling(coo, _, _):: _ -> Some coo.id
@ -417,20 +417,20 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda =
end else end else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
(match nodes_e with (match nodes_e with
| [] -> | [] ->
(match box_dangling e with (match box_dangling e with
| None -> [] | None -> []
| Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")] | Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")]
) )
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)] [(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)]
end else end else
[(LinkStructToExp, Ident.fieldname_to_string fn, n,"")] [(LinkStructToExp, Ident.fieldname_to_string fn, n,"")]
| _ -> (* by construction there must be at most 2 nodes for an expression*) | _ -> (* by construction there must be at most 2 nodes for an expression*)
L.out "@\n Too many nodes! Error! @\n@.@."; assert false L.out "@\n Too many nodes! Error! @\n@.@."; assert false
) )
| Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ ->[] (* inner arrays are printed by print_array function *) | Sil.Earray _ ->[] (* inner arrays are printed by print_array function *)
@ -453,20 +453,20 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
end else end else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
(match nodes_e with (match nodes_e with
| [] -> | [] ->
(match box_dangling e with (match box_dangling e with
| None -> [] | None -> []
| Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")] | Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")]
) )
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)] [(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)]
end else end else
[(LinkArrayToExp, Sil.exp_to_string idx, n,"")] [(LinkArrayToExp, Sil.exp_to_string idx, n,"")]
| _ -> (* by construction there must be at most 2 nodes for an expression*) | _ -> (* by construction there must be at most 2 nodes for an expression*)
L.out "@\n Too many nodes! Error! @\n@.@."; assert false L.out "@\n Too many nodes! Error! @\n@.@."; assert false
) )
| Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ ->[] (* inner arrays are printed by print_array function *) | Sil.Earray _ ->[] (* inner arrays are printed by print_array function *)
@ -486,12 +486,12 @@ let rec compute_target_from_eexp dotnodes e p f lambda =
let nodes_e_no_struct = list_filter is_not_struct nodes_e in let nodes_e_no_struct = list_filter is_not_struct nodes_e in
let trg = list_map get_coordinate_id nodes_e_no_struct in let trg = list_map get_coordinate_id nodes_e_no_struct in
(match trg with (match trg with
| [] -> | [] ->
(match box_dangling e with (match box_dangling e with
| None -> [] | None -> []
| Some n -> [(LinkExpToExp, n, "")] | Some n -> [(LinkExpToExp, n, "")]
) )
| _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg | _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg
) )
(* build the set of edges between nodes *) (* build the set of edges between nodes *)
@ -516,60 +516,60 @@ let rec dotty_mk_set_links dotnodes sigma p f =
| (Sil.Hpointsto (e, Sil.Estruct (lfld, _), t), lambda):: sigma' -> | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), t), lambda):: sigma' ->
let src = look_up dotnodes e lambda in let src = look_up dotnodes e lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| nl -> | nl ->
(* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *) (* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *)
let target_list = compute_target_struct_fields dotnodes lfld p f lambda in let target_list = compute_target_struct_fields dotnodes lfld p f lambda in
let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let address_struct_id = let address_struct_id =
try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e)) try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e))
with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*) (* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= list_filter (fun id -> address_struct_id != id) nl in let nl'= list_filter (fun id -> address_struct_id != id) nl in
let links_from_fields = list_flatten (list_map ff nl') in let links_from_fields = list_flatten (list_map ff nl') in
let trg_label = strip_special_chars (Sil.exp_to_string e) in let trg_label = strip_special_chars (Sil.exp_to_string e) in
let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in
lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f
) )
| (Sil.Hpointsto (e, Sil.Eexp (e', inst'), t), lambda):: sigma' -> | (Sil.Hpointsto (e, Sil.Eexp (e', inst'), t), lambda):: sigma' ->
let src = look_up dotnodes e lambda in let src = look_up dotnodes e lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| nl -> | nl ->
let target_list = compute_target_from_eexp dotnodes e' p f lambda in let target_list = compute_target_from_eexp dotnodes e' p f lambda in
let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in
let ll = list_flatten (list_map ff nl) in let ll = list_flatten (list_map ff nl) in
ll @ dotty_mk_set_links dotnodes sigma' p f ll @ dotty_mk_set_links dotnodes sigma' p f
) )
| (Sil.Hlseg (_, pred, e1, e2, elist), lambda):: sigma' -> | (Sil.Hlseg (_, pred, e1, e2, elist), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in let src = look_up dotnodes e1 lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| n:: _ -> | n:: _ ->
let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in
let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in
lnk:: dotty_mk_set_links dotnodes sigma' p f lnk:: dotty_mk_set_links dotnodes sigma' p f
) )
| (Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist), lambda):: sigma' -> | (Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in let src = look_up dotnodes e1 lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| n:: _ -> (* n is e1's box and n+1 is e4's box *) | n:: _ -> (* n is e1's box and n+1 is e4's box *)
let targetF = look_up dotnodes e3 lambda in let targetF = look_up dotnodes e3 lambda in
let target_Flink = (match targetF with let target_Flink = (match targetF with
| [] -> [] | [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""] | m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""]
) in ) in
let targetB = look_up dotnodes e2 lambda in let targetB = look_up dotnodes e2 lambda in
let target_Blink = (match targetB with let target_Blink = (match targetB with
| [] -> [] | [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] | m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""]
) in ) in
target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f
) )
let print_kind f kind = let print_kind f kind =
@ -628,8 +628,8 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let remove_links_from ln = list_filter (fun n' -> not (list_mem Pervasives.(=) n' ln)) !tmp_links in let remove_links_from ln = list_filter (fun n' -> not (list_mem Pervasives.(=) n' ln)) !tmp_links in
let remove_node n ns = let remove_node n ns =
list_filter (fun n' -> match n' with list_filter (fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n) | Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n)
| _ -> true | _ -> true
) ns in ) ns in
let rec boxes_pointed_by n lns = let rec boxes_pointed_by n lns =
match lns with match lns with
@ -758,11 +758,11 @@ and build_visual_graph f pe p =
compute_fields_struct sigma; compute_fields_struct sigma;
compute_struct_exp_nodes sigma; compute_struct_exp_nodes sigma;
(* L.out "@\n@\n Computed fields structs: "; (* L.out "@\n@\n Computed fields structs: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs; list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs;
L.out "@\n@."; L.out "@\n@.";
L.out "@\n@\n Computed exp structs nodes: "; L.out "@\n@\n Computed exp structs nodes: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes; list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes;
L.out "@\n@."; *) L.out "@\n@."; *)
let sigma_lambda = list_map (fun hp -> (hp,!lambda_counter)) sigma in let sigma_lambda = list_map (fun hp -> (hp,!lambda_counter)) sigma in
let nodes = (dotty_mk_node pe) sigma_lambda in let nodes = (dotty_mk_node pe) sigma_lambda in
make_dangling_boxes pe nodes sigma_lambda; make_dangling_boxes pe nodes sigma_lambda;
@ -833,10 +833,10 @@ let pp_dotty_one_spec f pre posts =
pp_dotty f (Spec_precondition) pre; pp_dotty f (Spec_precondition) pre;
invisible_arrows:= false; invisible_arrows:= false;
list_iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po; list_iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po;
for j = 1 to 4 do for j = 1 to 4 do
F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre; F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre;
done done
) posts; ) posts;
F.fprintf f "\n } \n" F.fprintf f "\n } \n"
(* this is used to print a list of proposition when considered in a path of nodes *) (* this is used to print a list of proposition when considered in a path of nodes *)
@ -851,7 +851,7 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n =
if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n; if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n;
F.fprintf f "\n } \n" F.fprintf f "\n } \n"
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
() ()
(* create a dotty file with a single proposition *) (* create a dotty file with a single proposition *)
let dotty_prop_to_dotty_file fname prop = let dotty_prop_to_dotty_file fname prop =
@ -865,7 +865,7 @@ let dotty_prop_to_dotty_file fname prop =
Format.fprintf fmt_dot "@\n}"; Format.fprintf fmt_dot "@\n}";
close_out out_dot close_out out_dot
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
() ()
(* this is used only to print a list of prop parsed with the external parser. Basically deprecated.*) (* this is used only to print a list of prop parsed with the external parser. Basically deprecated.*)
let pp_proplist_parsed2dotty_file filename plist = let pp_proplist_parsed2dotty_file filename plist =
@ -882,7 +882,7 @@ let pp_proplist_parsed2dotty_file filename plist =
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist; F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist;
close_out outc close_out outc
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
() ()
(********** START of Print interprocedural cfgs in dotty format *) (********** START of Print interprocedural cfgs in dotty format *)
(********** Print control flow graph (in dot form) for fundec to *) (********** Print control flow graph (in dot form) for fundec to *)
@ -893,19 +893,19 @@ let pp_cfgnodename fmt (n : Cfg.Node.t) =
let pp_etlist fmt etl = let pp_etlist fmt etl =
list_iter (fun (id, ty) -> list_iter (fun (id, ty) ->
Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl
let pp_local_list fmt etl = let pp_local_list fmt etl =
list_iter (fun (id, ty) -> list_iter (fun (id, ty) ->
Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl
let pp_cfgnodelabel fmt (n : Cfg.Node.t) = let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
let pp_label fmt n = let pp_label fmt n =
match Cfg.Node.get_kind n with match Cfg.Node.get_kind n with
| Cfg.Node.Start_node (pdesc) -> | Cfg.Node.Start_node (pdesc) ->
let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in
(* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *) (* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *)
(* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *) (* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *)
Format.fprintf fmt "Start %s%s\\nFormals: %a\\nLocals: %a" Format.fprintf fmt "Start %s%s\\nFormals: %a\\nLocals: %a"
(Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc))
gen gen
@ -1025,7 +1025,7 @@ let pp_speclist_to_file (filename : DB.filename) spec_list =
let pp_speclist_dotty_file (filename : DB.filename) spec_list = let pp_speclist_dotty_file (filename : DB.filename) spec_list =
try pp_speclist_to_file filename spec_list try pp_speclist_to_file filename spec_list
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
() ()
(**********************************************************************) (**********************************************************************)
(* Code prodicing a xml version of a graph *) (* Code prodicing a xml version of a graph *)
@ -1077,7 +1077,7 @@ let atom_to_xml_string a =
(* return the dangling node corresponding to an expression it exists or None *) (* return the dangling node corresponding to an expression it exists or None *)
let exp_dangling_node e = let exp_dangling_node e =
let entry_e = list_filter (fun b -> match b with let entry_e = list_filter (fun b -> match b with
| VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in | VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in
match entry_e with match entry_e with
|[] -> None |[] -> None
| VH_dangling(n, e') :: _ -> Some (VH_dangling(n, e')) | VH_dangling(n, e') :: _ -> Some (VH_dangling(n, e'))
@ -1126,7 +1126,7 @@ let rec select_node_at_address nodes e =
(* look-up the ids in the list of nodes corresponding to expression e*) (* look-up the ids in the list of nodes corresponding to expression e*)
(* let look_up_nodes_ids nodes e = (* let look_up_nodes_ids nodes e =
list_map get_node_id (select_nodes_exp nodes e) *) list_map get_node_id (select_nodes_exp nodes e) *)
(* create a list of dangling nodes *) (* create a list of dangling nodes *)
let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
@ -1136,22 +1136,22 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
VH_dangling(n, e) in VH_dangling(n, e) in
let get_rhs_predicate hpred = let get_rhs_predicate hpred =
(match hpred with (match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e] | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e]
| Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2] | Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2]
| Sil.Hdllseg (_, _, e1, e2, e3, _, _) -> | Sil.Hdllseg (_, _, e1, e2, e3, _, _) ->
if (Sil.exp_equal e2 Sil.exp_zero) then if (Sil.exp_equal e2 Sil.exp_zero) then
if (Sil.exp_equal e3 Sil.exp_zero) then [] if (Sil.exp_equal e3 Sil.exp_zero) then []
else [e3] else [e3]
else [e2; e3] else [e2; e3]
| Sil.Hpointsto (_, _, _) | Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*) | _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*)
) in ) in
let is_not_allocated e = let is_not_allocated e =
let allocated = list_exists (fun a -> match a with let allocated = list_exists (fun a -> match a with
| VH_pointsto(_, e', _, _) | VH_pointsto(_, e', _, _)
| VH_lseg(_, e', _ , _) | VH_lseg(_, e', _ , _)
| VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e' | VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e'
| _ -> false ) allocated_nodes in | _ -> false ) allocated_nodes in
not allocated in not allocated in
let rec filter_duplicate l seen_exp = let rec filter_duplicate l seen_exp =
match l with match l with
@ -1173,27 +1173,27 @@ let rec compute_target_nodes_from_sexp nodes se prop field_lab =
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, inst) ->
let e_node = select_node_at_address nodes e in let e_node = select_node_at_address nodes e in
(match e_node with (match e_node with
| None -> | None ->
(match exp_dangling_node e with (match exp_dangling_node e with
| None -> [] | None -> []
| Some dang_node -> [(dang_node, field_lab)] | Some dang_node -> [(dang_node, field_lab)]
) )
| Some n -> [(n, field_lab)] | Some n -> [(n, field_lab)]
) )
| Sil.Estruct (lfld, inst) -> | Sil.Estruct (lfld, inst) ->
(match lfld with (match lfld with
| [] -> [] | [] -> []
| (fn, se2):: l' -> | (fn, se2):: l' ->
compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @ compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @
compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop "" compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop ""
) )
| Sil.Earray(size, lie, inst) -> | Sil.Earray(size, lie, inst) ->
(match lie with (match lie with
| [] -> [] | [] -> []
| (idx, se2):: l' -> | (idx, se2):: l' ->
let lab ="["^exp_to_xml_string idx^"]" in let lab ="["^exp_to_xml_string idx^"]" in
compute_target_nodes_from_sexp nodes se2 prop lab @ compute_target_nodes_from_sexp nodes se2 prop lab @
compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop "" compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop ""
) )
@ -1206,32 +1206,32 @@ let rec make_visual_heap_edges nodes sigma prop =
| Sil.Hpointsto (e, se, t):: sigma' -> | Sil.Hpointsto (e, se, t):: sigma' ->
let e_node = select_node_at_address nodes e in let e_node = select_node_at_address nodes e in
(match e_node with (match e_node with
| None -> assert false | None -> assert false
| Some n -> | Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop ll @ make_visual_heap_edges nodes sigma' prop
) )
| Sil.Hlseg (_, pred, e1, e2, elist):: sigma' -> | Sil.Hlseg (_, pred, e1, e2, elist):: sigma' ->
let e1_node = select_node_at_address nodes e1 in let e1_node = select_node_at_address nodes e1 in
(match e1_node with (match e1_node with
| None -> assert false | None -> assert false
| Some n -> | Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop ll @ make_visual_heap_edges nodes sigma' prop
) )
| Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist):: sigma' -> | Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist):: sigma' ->
let e1_node = select_node_at_address nodes e1 in let e1_node = select_node_at_address nodes e1 in
(match e1_node with (match e1_node with
| None -> assert false | None -> assert false
| Some n -> | Some n ->
let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in
let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let llF = list_map (combine_source_target_label n) target_nodesF in let llF = list_map (combine_source_target_label n) target_nodesF in
let llB = list_map (combine_source_target_label n) target_nodesB in let llB = list_map (combine_source_target_label n) target_nodesB in
llF @ llB @ make_visual_heap_edges nodes sigma' prop llF @ llB @ make_visual_heap_edges nodes sigma' prop
) )
(* from a prop generate and return visual proposition *) (* from a prop generate and return visual proposition *)
@ -1348,8 +1348,8 @@ let print_specs_xml signature specs loc fmt =
let list_of_specs_xml = let list_of_specs_xml =
list_map list_map
(fun s -> (fun s ->
j:=!j + 1; j:=!j + 1;
do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j) do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j)
specs in specs in
let xml_specifications = Io_infer.Xml.create_tree "specifications" [] list_of_specs_xml in let xml_specifications = Io_infer.Xml.create_tree "specifications" [] list_of_specs_xml in
let xml_signature = Io_infer.Xml.create_tree "signature" [("name", signature)] [] in let xml_signature = Io_infer.Xml.create_tree "signature" [("name", signature)] [] in

234
infer/src/backend/errdesc.ml
Unescape View File

@ -21,8 +21,8 @@ let pvar_to_string pvar =
let hpred_is_open_resource prop = function let hpred_is_open_resource prop = function
| Sil.Hpointsto(e, _, _) -> | Sil.Hpointsto(e, _, _) ->
(match Prop.get_resource_undef_attribute prop e with (match Prop.get_resource_undef_attribute prop e with
| Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res | Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res
| _ -> None) | _ -> None)
| _ -> | _ ->
None None
@ -69,9 +69,9 @@ let find_other_prune_node node =
match Cfg.Node.get_preds node with match Cfg.Node.get_preds node with
| [n_pre] -> | [n_pre] ->
(match Cfg.Node.get_succs n_pre with (match Cfg.Node.get_succs n_pre with
| [n1; n2] -> | [n1; n2] ->
if Cfg.Node.equal n1 node then Some n2 else Some n1 if Cfg.Node.equal n1 node then Some n2 else Some n1
| _ -> None) | _ -> None)
| _ -> None | _ -> None
(** Return true if [id] is assigned to a program variable which is then nullified *) (** Return true if [id] is assigned to a program variable which is then nullified *)
@ -84,15 +84,15 @@ let id_is_assigned_then_dead node id =
let prune_check = function (* if prune node, check that it's also nullified in the other branch *) let prune_check = function (* if prune node, check that it's also nullified in the other branch *)
| Some node' -> | Some node' ->
(match Cfg.Node.get_instrs node' with (match Cfg.Node.get_instrs node' with
| instr':: _ -> find_nullify_after_instr node' instr' pvar | instr':: _ -> find_nullify_after_instr node' instr' pvar
| _ -> false) | _ -> false)
| _ -> false in | _ -> false in
find_nullify_after_instr node instr pvar find_nullify_after_instr node instr pvar
&& (not is_prune || prune_check (find_other_prune_node node)) && (not is_prune || prune_check (find_other_prune_node node))
| _ -> false | _ -> false
(** Find the function call instruction used to initialize normal variable [id], (** Find the function call instruction used to initialize normal variable [id],
and return the function name and arguments *) and return the function name and arguments *)
let find_normal_variable_funcall let find_normal_variable_funcall
(node: Cfg.Node.t) (node: Cfg.Node.t)
(id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option = (id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option =
@ -105,7 +105,7 @@ let find_normal_variable_funcall
| _ -> false in | _ -> false in
ignore (list_exists find_declaration node_instrs); ignore (list_exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_funcall could not find " ^ if !verbose && !res == None then (L.d_str ("find_normal_variable_funcall could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res !res
(** Find a program variable assignment in the current node or predecessors. *) (** Find a program variable assignment in the current node or predecessors. *)
@ -129,8 +129,8 @@ let find_program_variable_assignment node pvar : (Cfg.Node.t * Ident.t) option =
find pred_node find pred_node
| [pn1; pn2] -> | [pn1; pn2] ->
(match find pn1 with (match find pn1 with
| None -> find pn2 | None -> find pn2
| x -> x) | x -> x)
| _ -> None (* either 0 or >2 predecessors *) | _ -> None (* either 0 or >2 predecessors *)
end in end in
find node find node
@ -156,14 +156,14 @@ let find_ident_assignment node id : (Cfg.Node.t * Sil.exp) option =
find pred_node find pred_node
| [pn1; pn2] -> | [pn1; pn2] ->
(match find pn1 with (match find pn1 with
| None -> find pn2 | None -> find pn2
| x -> x) | x -> x)
| _ -> None (* either 0 or >2 predecessors *) | _ -> None (* either 0 or >2 predecessors *)
end in end in
find node find node
(** Find a boolean assignment to a temporary variable holding a boolean condition. (** Find a boolean assignment to a temporary variable holding a boolean condition.
The boolean parameter indicates whether the true or false branch is required. *) The boolean parameter indicates whether the true or false branch is required. *)
let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option = let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option =
let find_instr n = let find_instr n =
let filter = function let filter = function
@ -213,7 +213,7 @@ let pvar_is_frontend_tmp pvar =
else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar
(** Find the Letderef instruction used to declare normal variable [id], (** Find the Letderef instruction used to declare normal variable [id],
and return the expression dereferenced to initialize [id] *) and return the expression dereferenced to initialize [id] *)
let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp option = let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp option =
let res = ref None in let res = ref None in
let node_instrs = Cfg.Node.get_instrs node in let node_instrs = Cfg.Node.get_instrs node in
@ -227,7 +227,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp
res := _exp_rv_dexp seen node e; res := _exp_rv_dexp seen node e;
true true
| Sil.Call ([id0], (Sil.Const (Sil.Cfun pname) as fun_exp), args, loc, call_flags) | Sil.Call ([id0], (Sil.Const (Sil.Cfun pname) as fun_exp), args, loc, call_flags)
when Ident.equal id id0 -> when Ident.equal id id0 ->
if !verbose then (L.d_str "find_normal_variable_letderef function call "; Sil.d_exp fun_exp; L.d_ln ()); if !verbose then (L.d_str "find_normal_variable_letderef function call "; Sil.d_exp fun_exp; L.d_ln ());
let fun_dexp = Sil.Dconst (Sil.Cfun pname) in let fun_dexp = Sil.Dconst (Sil.Cfun pname) in
@ -244,7 +244,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp
| _ -> false in | _ -> false in
ignore (list_exists find_declaration node_instrs); ignore (list_exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_letderef could not find " ^ if !verbose && !res == None then (L.d_str ("find_normal_variable_letderef could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res !res
(** describe lvalue [e] as a dexp *) (** describe lvalue [e] as a dexp *)
@ -260,13 +260,13 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
| Sil.BinOp(Sil.PlusPI, e1, e2) -> | Sil.BinOp(Sil.PlusPI, e1, e2) ->
if !verbose then (L.d_str "exp_lv_dexp: (e1 +PI e2) "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_lv_dexp: (e1 +PI e2) "; Sil.d_exp e; L.d_ln ());
(match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with (match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2)) | Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2))
| _ -> None) | _ -> None)
| Sil.Var id when Ident.is_normal id -> | Sil.Var id when Ident.is_normal id ->
if !verbose then (L.d_str "exp_lv_dexp: normal var "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_lv_dexp: normal var "; Sil.d_exp e; L.d_ln ());
(match _find_normal_variable_letderef seen node id with (match _find_normal_variable_letderef seen node id with
| None -> None | None -> None
| Some de -> Some (Sil.Dderef de)) | Some de -> Some (Sil.Dderef de))
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
if !verbose then (L.d_str "exp_lv_dexp: program var "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_lv_dexp: program var "; Sil.d_exp e; L.d_ln ());
if pvar_is_frontend_tmp pvar then if pvar_is_frontend_tmp pvar then
@ -302,8 +302,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln () L.d_ln ()
end; end;
(match _find_normal_variable_letderef seen node id with (match _find_normal_variable_letderef seen node id with
| None -> None | None -> None
| Some de -> Some (Sil.Darrow (de, f))) | Some de -> Some (Sil.Darrow (de, f)))
| Sil.Lfield (e1, f, typ) -> | Sil.Lfield (e1, f, typ) ->
if !verbose then if !verbose then
begin begin
@ -313,8 +313,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln () L.d_ln ()
end; end;
(match _exp_lv_dexp seen node e1 with (match _exp_lv_dexp seen node e1 with
| None -> None | None -> None
| Some de -> Some (Sil.Ddot (de, f))) | Some de -> Some (Sil.Ddot (de, f)))
| Sil.Lindex (e1, e2) -> | Sil.Lindex (e1, e2) ->
if !verbose then if !verbose then
begin begin
@ -325,11 +325,11 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln () L.d_ln ()
end; end;
(match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with (match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ -> None | None, _ -> None
| Some de1, None -> | Some de1, None ->
(* even if the index is unknown, the array info is useful for bound errors *) (* even if the index is unknown, the array info is useful for bound errors *)
Some (Sil.Darray (de1, Sil.Dunknown)) Some (Sil.Darray (de1, Sil.Dunknown))
| Some de1, Some de2 -> Some (Sil.Darray (de1, de2))) | Some de1, Some de2 -> Some (Sil.Darray (de1, de2)))
| _ -> | _ ->
if !verbose then (L.d_str "exp_lv_dexp: no match for "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_lv_dexp: no match for "; Sil.d_exp e; L.d_ln ());
None None
@ -361,8 +361,8 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln () L.d_ln ()
end; end;
(match _exp_rv_dexp seen node e1 with (match _exp_rv_dexp seen node e1 with
| None -> None | None -> None
| Some de -> Some (Sil.Ddot(de, f))) | Some de -> Some (Sil.Ddot(de, f)))
| Sil.Lindex (e1, e2) -> | Sil.Lindex (e1, e2) ->
if !verbose then if !verbose then
begin begin
@ -373,18 +373,18 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln () L.d_ln ()
end; end;
(match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with (match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ | _, None -> None | None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Darray(de1, de2))) | Some de1, Some de2 -> Some (Sil.Darray(de1, de2)))
| Sil.BinOp (op, e1, e2) -> | Sil.BinOp (op, e1, e2) ->
if !verbose then (L.d_str "exp_rv_dexp: BinOp "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_rv_dexp: BinOp "; Sil.d_exp e; L.d_ln ());
(match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with (match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ | _, None -> None | None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2))) | Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2)))
| Sil.UnOp (op, e1, _) -> | Sil.UnOp (op, e1, _) ->
if !verbose then (L.d_str "exp_rv_dexp: UnOp "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_rv_dexp: UnOp "; Sil.d_exp e; L.d_ln ());
(match _exp_rv_dexp seen node e1 with (match _exp_rv_dexp seen node e1 with
| None -> None | None -> None
| Some de1 -> Some (Sil.Dunop (op, de1))) | Some de1 -> Some (Sil.Dunop (op, de1)))
| Sil.Cast (_, e1) -> | Sil.Cast (_, e1) ->
if !verbose then (L.d_str "exp_rv_dexp: Cast "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_rv_dexp: Cast "; Sil.d_exp e; L.d_ln ());
_exp_rv_dexp seen node e1 _exp_rv_dexp seen node e1
@ -453,9 +453,9 @@ let find_pvar_typ_without_ptr tenv prop pvar =
!res !res
(** Produce a description of a leak by looking at the current state. (** Produce a description of a leak by looking at the current state.
If the current instruction is a variable nullify, blame the variable. If the current instruction is a variable nullify, blame the variable.
If it is an abstraction, blame any variable nullify at the current node. If it is an abstraction, blame any variable nullify at the current node.
If there is an alloc attribute, print the function call and line number. *) If there is an alloc attribute, print the function call and line number. *)
let explain_leak tenv hpred prop alloc_att_opt bucket = let explain_leak tenv hpred prop alloc_att_opt bucket =
let instro = State.get_instr () in let instro = State.get_instr () in
let loc = State.get_loc () in let loc = State.get_loc () in
@ -486,9 +486,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
match hpred_typ_opt, find_pvar_typ_without_ptr tenv prop pvar with match hpred_typ_opt, find_pvar_typ_without_ptr tenv prop pvar with
| Some (Sil.Sizeof (t1, st1)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), st2)) -> | Some (Sil.Sizeof (t1, st1)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), st2)) ->
(try (try
let t2 = Sil.expand_type tenv _t2 in let t2 = Sil.expand_type tenv _t2 in
Sil.typ_equal t1 t2 Sil.typ_equal t1 t2
with exn when exn_not_timeout exn -> false) with exn when exn_not_timeout exn -> false)
| Some (Sil.Sizeof (Sil.Tint _, _)), Some (Sil.Sizeof (Sil.Tint _, _)) when is_file -> (* must be a file opened with "open" *) | Some (Sil.Sizeof (Sil.Tint _, _)), Some (Sil.Sizeof (Sil.Tint _, _)) when is_file -> (* must be a file opened with "open" *)
true true
| _ -> false in | _ -> false in
@ -499,8 +499,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| Some (Sil.Nullify (pvar, loc, _)) when check_pvar pvar -> | Some (Sil.Nullify (pvar, loc, _)) when check_pvar pvar ->
if !verbose then (L.d_str "explain_leak: current instruction is Nullify for pvar "; Sil.d_pvar pvar; L.d_ln ()); if !verbose then (L.d_str "explain_leak: current instruction is Nullify for pvar "; Sil.d_pvar pvar; L.d_ln ());
(match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with (match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with
| None -> None | None -> None
| Some de -> Some (Sil.dexp_to_string de)) | Some de -> Some (Sil.dexp_to_string de))
| Some (Sil.Abstract _) -> | Some (Sil.Abstract _) ->
if !verbose then (L.d_str "explain_leak: current instruction is Abstract"; L.d_ln ()); if !verbose then (L.d_str "explain_leak: current instruction is Abstract"; L.d_ln ());
let get_nullify = function let get_nullify = function
@ -514,8 +514,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| Some (Sil.Set (lexp, _, _, _)) when vpath = None -> | Some (Sil.Set (lexp, _, _, _)) when vpath = None ->
if !verbose then (L.d_str "explain_leak: current instruction Set for "; Sil.d_exp lexp; L.d_ln ()); if !verbose then (L.d_str "explain_leak: current instruction Set for "; Sil.d_exp lexp; L.d_ln ());
(match exp_lv_dexp node lexp with (match exp_lv_dexp node lexp with
| Some dexp -> Some (Sil.dexp_to_string dexp) | Some dexp -> Some (Sil.dexp_to_string dexp)
| None -> None) | None -> None)
| Some instr -> | Some instr ->
if !verbose then (L.d_str "explain_leak: case not matched in instr "; Sil.d_instr instr; L.d_ln()); if !verbose then (L.d_str "explain_leak: case not matched in instr "; Sil.d_instr instr; L.d_ln());
value_str_from_pvars_vpath [] vpath in value_str_from_pvars_vpath [] vpath in
@ -530,7 +530,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
exn_cat, Localise.desc_leak value_str resource_opt res_action_opt loc bucket exn_cat, Localise.desc_leak value_str resource_opt res_action_opt loc bucket
(** find the dexp, if any, where the given value is stored (** find the dexp, if any, where the given value is stored
also return the type of the value if found *) also return the type of the value if found *)
let vpath_find prop _exp : Sil.dexp option * Sil.typ option = let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
if !verbose then (L.d_str "in vpath_find exp:"; Sil.d_exp _exp; L.d_ln ()); if !verbose then (L.d_str "in vpath_find exp:"; Sil.d_exp _exp; L.d_ln ());
let rec find sigma_acc sigma_todo exp = let rec find sigma_acc sigma_todo exp =
@ -538,38 +538,38 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
| Sil.Eexp (e, _) when Sil.exp_equal exp e -> | Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in let sigma' = (list_rev_append sigma_acc' sigma_todo') in
(match lexp with (match lexp with
| Sil.Lvar pv -> | Sil.Lvar pv ->
let typo = match texp with let typo = match texp with
| Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) -> | Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) ->
(try (try
let _, t, _ = list_find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in let _, t, _ = list_find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in
Some t Some t
with Not_found -> None) with Not_found -> None)
| _ -> None in | _ -> None in
res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo
| Sil.Var id -> | Sil.Var id ->
(match find [] sigma' (Sil.Var id) with (match find [] sigma' (Sil.Var id) with
| None, _ -> () | None, _ -> ()
| Some de, typo -> res := Some (Sil.Darrow (de, f)), typo) | Some de, typo -> res := Some (Sil.Darrow (de, f)), typo)
| lexp -> | lexp ->
if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ())) if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()))
| _ -> () in | _ -> () in
let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with
| Sil.Eexp (e, _) when Sil.exp_equal exp e -> | Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in let sigma' = (list_rev_append sigma_acc' sigma_todo') in
(match lexp with (match lexp with
| Sil.Lvar pv when not (pvar_is_frontend_tmp pv) -> | Sil.Lvar pv when not (pvar_is_frontend_tmp pv) ->
let typo = match texp with let typo = match texp with
| Sil.Sizeof (typ, _) -> Some typ | Sil.Sizeof (typ, _) -> Some typ
| _ -> None in | _ -> None in
Some (Sil.Dpvar pv), typo Some (Sil.Dpvar pv), typo
| Sil.Var id -> | Sil.Var id ->
(match find [] sigma' (Sil.Var id) with (match find [] sigma' (Sil.Var id) with
| None, typo -> None, typo | None, typo -> None, typo
| Some de, typo -> Some (Sil.Dderef de), typo) | Some de, typo -> Some (Sil.Dderef de), typo)
| lexp -> | lexp ->
if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()); if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ());
None, None) None, None)
| Sil.Estruct (fsel, _) -> | Sil.Estruct (fsel, _) ->
let res = ref (None, None) in let res = ref (None, None) in
list_iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel; list_iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
@ -588,14 +588,14 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
| Sil.Hpointsto (Sil.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> | Sil.Hpointsto (Sil.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) ->
do_sexp sigma_acc' sigma_todo' (Sil.Var id) sexp texp do_sexp sigma_acc' sigma_todo' (Sil.Var id) sexp texp
| hpred -> | hpred ->
(* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *) (* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *)
None, None in None, None in
match sigma_todo with match sigma_todo with
| [] -> None, None | [] -> None, None
| hpred:: sigma_todo' -> | hpred:: sigma_todo' ->
(match do_hpred sigma_acc sigma_todo' hpred with (match do_hpred sigma_acc sigma_todo' hpred with
| Some de, typo -> Some de, typo | Some de, typo -> Some de, typo
| None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in | None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in
let res = find [] (Prop.get_sigma prop) _exp in let res = find [] (Prop.get_sigma prop) _exp in
if !verbose then begin if !verbose then begin
match res with match res with
@ -644,45 +644,45 @@ let explain_dexp_access prop dexp is_nullable =
Some (Sil.Eexp (Sil.Const c, Sil.inst_none)) Some (Sil.Eexp (Sil.Const c, Sil.inst_none))
| Sil.Darray (de1, de2) -> | Sil.Darray (de1, de2) ->
(match lookup de1, lookup de2 with (match lookup de1, lookup de2 with
| None, _ | _, None -> None | None, _ | _, None -> None
| Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) -> | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) ->
lookup_esel esel e lookup_esel esel e
| Some se1, Some se2 -> | Some se1, Some se2 ->
if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln()); if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln());
None) None)
| Sil.Darrow (de1, f) -> | Sil.Darrow (de1, f) ->
(match lookup (Sil.Dderef de1) with (match lookup (Sil.Dderef de1) with
| None -> None | None -> None
| Some Sil.Estruct (fsel, _) -> | Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f lookup_fld fsel f
| Some _ -> | Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ()); if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ());
None) None)
| Sil.Ddot (de1, f) -> | Sil.Ddot (de1, f) ->
(match lookup de1 with (match lookup de1 with
| None -> None | None -> None
| Some Sil.Estruct (fsel, _) -> | Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f lookup_fld fsel f
| Some _ -> | Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ()); if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ());
None) None)
| Sil.Dpvar pvar -> | Sil.Dpvar pvar ->
if !verbose then (L.d_str "lookup: found Dpvar "; L.d_ln ()); if !verbose then (L.d_str "lookup: found Dpvar "; L.d_ln ());
(find_ptsto (Sil.Lvar pvar)) (find_ptsto (Sil.Lvar pvar))
| Sil.Dderef de -> | Sil.Dderef de ->
(match lookup de with (match lookup de with
| None -> None | None -> None
| Some (Sil.Eexp (e, _)) -> find_ptsto e | Some (Sil.Eexp (e, _)) -> find_ptsto e
| Some _ -> None) | Some _ -> None)
| (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar pvar, Sil.Dconst c) as de) -> | (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar pvar, Sil.Dconst c) as de) ->
if !verbose then (L.d_strln ("lookup: case )pvar + constant) " ^ Sil.dexp_to_string de)); if !verbose then (L.d_strln ("lookup: case )pvar + constant) " ^ Sil.dexp_to_string de));
None None
| Sil.Dfcall (Sil.Dconst c, _, loc, _) -> | Sil.Dfcall (Sil.Dconst c, _, loc, _) ->
if !verbose then (L.d_strln "lookup: found Dfcall "); if !verbose then (L.d_strln "lookup: found Dfcall ");
(match c with (match c with
| Sil.Cfun pn -> (* Treat function as an update *) | Sil.Cfun pn -> (* Treat function as an update *)
Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line)) Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line))
| _ -> None) | _ -> None)
| de -> | de ->
if !verbose then (L.d_strln ("lookup: unknown case not matched " ^ Sil.dexp_to_string de)); if !verbose then (L.d_strln ("lookup: unknown case not matched " ^ Sil.dexp_to_string de));
None in None in
@ -749,17 +749,17 @@ let create_dereference_desc
| Some (Sil.Dpvar pvar) | Some (Sil.Dpvar pvar)
| Some (Sil.Dpvaraddr pvar) -> | Some (Sil.Dpvaraddr pvar) ->
(match Prop.get_objc_null_attribute prop (Sil.Lvar pvar) with (match Prop.get_objc_null_attribute prop (Sil.Lvar pvar) with
| Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info | Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info
| _ -> desc) | _ -> desc)
| _ -> desc | _ -> desc
else desc in else desc in
if use_buckets then Buckets.classify_access desc access_opt' de_opt is_nullable if use_buckets then Buckets.classify_access desc access_opt' de_opt is_nullable
else desc else desc
(** explain memory access performed by the current instruction (** explain memory access performed by the current instruction
if outermost_array is true, the outermost array access is removed if outermost_array is true, the outermost array access is removed
if outermost_dereference is true, stop at the outermost dereference if outermost_dereference is true, stop at the outermost dereference
(skipping e.g. outermost field access) *) (skipping e.g. outermost field access) *)
let _explain_access let _explain_access
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
?outermost_array: (outermost_array = false) ?outermost_array: (outermost_array = false)
@ -824,7 +824,7 @@ let _explain_access
de_opt deref_str prop loc de_opt deref_str prop loc
(** Produce a description of which expression is dereferenced in the current instruction, if any. (** Produce a description of which expression is dereferenced in the current instruction, if any.
The subexpression to focus on is obtained by removing field and index accesses. *) The subexpression to focus on is obtained by removing field and index accesses. *)
let explain_dereference let explain_dereference
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
?is_nullable: (is_nullable = false) ?is_nullable: (is_nullable = false)
@ -835,7 +835,7 @@ let explain_dereference
deref_str prop loc deref_str prop loc
(** Produce a description of the array access performed in the current instruction, if any. (** Produce a description of the array access performed in the current instruction, if any.
The subexpression to focus on is obtained by removing the outermost array access. *) The subexpression to focus on is obtained by removing the outermost array access. *)
let explain_array_access deref_str prop loc = let explain_array_access deref_str prop loc =
_explain_access ~outermost_array: true deref_str prop loc _explain_access ~outermost_array: true deref_str prop loc
@ -859,21 +859,21 @@ let dexp_apply_pvar_off dexp pvar_off =
| Fstruct [] -> dexp (* case should not happen *) | Fstruct [] -> dexp (* case should not happen *)
(** Produce a description of the nth parameter of the function call, if the current instruction (** Produce a description of the nth parameter of the function call, if the current instruction
is a function call with that parameter *) is a function call with that parameter *)
let explain_nth_function_parameter use_buckets deref_str prop n pvar_off = let explain_nth_function_parameter use_buckets deref_str prop n pvar_off =
let node = State.get_node () in let node = State.get_node () in
let loc = State.get_loc () in let loc = State.get_loc () in
match State.get_instr () with match State.get_instr () with
| Some Sil.Call (_, _, args, _, _) -> | Some Sil.Call (_, _, args, _, _) ->
(try (try
let arg = fst (list_nth args (n - 1)) in let arg = fst (list_nth args (n - 1)) in
let dexp_opt = exp_rv_dexp node arg in let dexp_opt = exp_rv_dexp node arg in
let dexp_opt' = match dexp_opt with let dexp_opt' = match dexp_opt with
| Some de -> | Some de ->
Some (dexp_apply_pvar_off de pvar_off) Some (dexp_apply_pvar_off de pvar_off)
| None -> None in | None -> None in
create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc
with exn when exn_not_timeout exn -> Localise.no_desc) with exn when exn_not_timeout exn -> Localise.no_desc)
| _ -> Localise.no_desc | _ -> Localise.no_desc
(** Find a program variable whose value is [exp] or pointing to a struct containing [exp] *) (** Find a program variable whose value is [exp] or pointing to a struct containing [exp] *)
@ -902,7 +902,7 @@ let find_pvar_with_exp prop exp =
!res !res
(** return a description explaining value [exp] in [prop] in terms of a source expression (** return a description explaining value [exp] in [prop] in terms of a source expression
using the formal parameters of the call *) using the formal parameters of the call *)
let explain_dereference_as_caller_expression let explain_dereference_as_caller_expression
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
deref_str actual_pre spec_pre exp node loc formal_params = deref_str actual_pre spec_pre exp node loc formal_params =

42
infer/src/backend/errlog.ml
Unescape View File

@ -55,8 +55,8 @@ module ErrLogHash = Hashtbl.Make (struct
end) end)
(** Type of the error log, to be reset once per function. (** Type of the error log, to be reset once per function.
Map err_kind, fotprint / re - execution flag, error name, Map err_kind, fotprint / re - execution flag, error name,
error description, severity, to set of err_data. *) error description, severity, to set of err_data. *)
type t = ErrDataSet.t ErrLogHash.t type t = ErrDataSet.t ErrLogHash.t
(** Empty error log *) (** Empty error log *)
@ -70,19 +70,19 @@ type iter_fun =
(** Apply f to nodes and error names *) (** Apply f to nodes and error names *)
let iter (f: iter_fun) (err_log: t) = let iter (f: iter_fun) (err_log: t) =
ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set -> ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set ->
ErrDataSet.iter ErrDataSet.iter
(fun (node_id_key, section, loc, mloco, ltr, pre_opt, eclass) -> (fun (node_id_key, section, loc, mloco, ltr, pre_opt, eclass) ->
f f
node_id_key loc ekind in_footprint err_name node_id_key loc ekind in_footprint err_name
desc severity ltr pre_opt eclass) desc severity ltr pre_opt eclass)
set) set)
err_log err_log
(** Return the number of elements in the error log which satisfy [filter] *) (** Return the number of elements in the error log which satisfy [filter] *)
let size filter (err_log: t) = let size filter (err_log: t) =
let count = ref 0 in let count = ref 0 in
ErrLogHash.iter (fun (ekind, in_footprint, _, _, _) eds -> ErrLogHash.iter (fun (ekind, in_footprint, _, _, _) eds ->
if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log; if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log;
!count !count
(** Print an error log *) (** Print an error log *)
@ -125,7 +125,7 @@ let severity_to_str severity = match severity with
| Exceptions.Low -> "LOW" | Exceptions.Low -> "LOW"
(** Add an error description to the error log unless there is (** Add an error description to the error log unless there is
one already at the same node + session; return true if added *) one already at the same node + session; return true if added *)
let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool = let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool =
try try
let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in
@ -138,16 +138,16 @@ let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataS
true true
end end
with Not_found -> with Not_found ->
begin begin
ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds; ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds;
true true
end end
(** Update an old error log with a new one *) (** Update an old error log with a new one *)
let update errlog_old errlog_new = let update errlog_old errlog_new =
ErrLogHash.iter ErrLogHash.iter
(fun (ekind, infp, s, desc, severity) l -> (fun (ekind, infp, s, desc, severity) l ->
ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new
let log_issue _ekind err_log loc node_id_key session ltr pre_opt exn = let log_issue _ekind err_log loc node_id_key session ltr pre_opt exn =
@ -237,26 +237,26 @@ module Err_table = struct
let err_list = LocMap.find nslm !map in let err_list = LocMap.find nslm !map in
map := LocMap.add nslm ((err_name, desc) :: err_list) !map map := LocMap.add nslm ((err_name, desc) :: err_list) !map
with Not_found -> with Not_found ->
map := LocMap.add nslm [(err_name, desc)] !map in map := LocMap.add nslm [(err_name, desc)] !map in
let f err_name eds = let f err_name eds =
ErrDataSet.iter (fun loc -> add_err loc err_name) eds in ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
ErrLogHash.iter f err_table; ErrLogHash.iter f err_table;
let pp ekind (nodeidkey, session, loc, mloco, ltr, pre_opt, eclass) fmt err_names = let pp ekind (nodeidkey, session, loc, mloco, ltr, pre_opt, eclass) fmt err_names =
list_iter (fun (err_name, desc) -> list_iter (fun (err_name, desc) ->
Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in
F.fprintf fmt "@.Detailed errors during footprint phase:@."; F.fprintf fmt "@.Detailed errors during footprint phase:@.";
LocMap.iter (fun nslm err_names -> LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp; F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
F.fprintf fmt "@.Detailed errors during re-execution phase:@."; F.fprintf fmt "@.Detailed errors during re-execution phase:@.";
LocMap.iter (fun nslm err_names -> LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re; F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re;
F.fprintf fmt "@.Detailed warnings during footprint phase:@."; F.fprintf fmt "@.Detailed warnings during footprint phase:@.";
LocMap.iter (fun nslm err_names -> LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp; F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp;
F.fprintf fmt "@.Detailed warnings during re-execution phase:@."; F.fprintf fmt "@.Detailed warnings during re-execution phase:@.";
LocMap.iter (fun nslm err_names -> LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re
end end
type err_table = Err_table.t type err_table = Err_table.t

44
infer/src/backend/exe_env.ml
Unescape View File

@ -27,10 +27,10 @@ type file_data =
(** get the path to the tenv file, which either one tenv file per source file or a global tenv file *) (** get the path to the tenv file, which either one tenv file per source file or a global tenv file *)
let tenv_filename file_base = let tenv_filename file_base =
let per_source_tenv_filename = DB.filename_add_suffix file_base ".tenv" in let per_source_tenv_filename = DB.filename_add_suffix file_base ".tenv" in
if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then
per_source_tenv_filename per_source_tenv_filename
else else
DB.global_tenv_fname () DB.global_tenv_fname ()
(** create a new file_data *) (** create a new file_data *)
let new_file_data source nLOC cg_fname = let new_file_data source nLOC cg_fname =
@ -90,14 +90,14 @@ let add_callee (exe_env: t) (source_file : DB.source_file) (pname: Procname.t) =
let file_data_opt = let file_data_opt =
try Some (Hashtbl.find exe_env.file_map source_file) try Some (Hashtbl.find exe_env.file_map source_file)
with Not_found -> with Not_found ->
let source_dir = DB.source_dir_from_source_file source_file in let source_dir = DB.source_dir_from_source_file source_file in
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
(match Cg.load_from_file cg_fname with (match Cg.load_from_file cg_fname with
| None -> None | None -> None
| Some cg -> | Some cg ->
let nLOC = Cg.get_nLOC cg in let nLOC = Cg.get_nLOC cg in
let file_data = new_file_data source_file nLOC cg_fname in let file_data = new_file_data source_file nLOC cg_fname in
Some file_data) in Some file_data) in
match file_data_opt with match file_data_opt with
| None -> () | None -> ()
| Some file_data -> | Some file_data ->
@ -120,14 +120,14 @@ let add_cg_exclude_fun (exe_env: t) (source_dir : DB.source_dir) exclude_fun =
let file_data = new_file_data source nLOC cg_fname in let file_data = new_file_data source nLOC cg_fname in
let defined_procs = Cg.get_defined_nodes cg in let defined_procs = Cg.get_defined_nodes cg in
list_iter (fun pname -> list_iter (fun pname ->
let should_update = let should_update =
if Procname.Hash.mem exe_env.proc_map pname then if Procname.Hash.mem exe_env.proc_map pname then
let old_source = (Procname.Hash.find exe_env.proc_map pname).source in let old_source = (Procname.Hash.find exe_env.proc_map pname).source in
exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files; exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files;
(* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *) (* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *)
source < old_source (* when a procedure is defined in several files, map to the first alphabetically *) source < old_source (* when a procedure is defined in several files, map to the first alphabetically *)
else true in else true in
if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs; if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs;
Hashtbl.add exe_env.file_map source file_data; Hashtbl.add exe_env.file_map source file_data;
Some cg Some cg
@ -160,8 +160,8 @@ let get_file_data exe_env pname =
try try
Procname.Hash.find exe_env.proc_map pname Procname.Hash.find exe_env.proc_map pname
with Not_found -> with Not_found ->
L.err "can't find tenv_cfg_object for %a@." Procname.pp pname; L.err "can't find tenv_cfg_object for %a@." Procname.pp pname;
raise Not_found raise Not_found
(** return the source file associated to the procedure *) (** return the source file associated to the procedure *)
let get_source exe_env pname = let get_source exe_env pname =

126
infer/src/backend/fork.ml
Unescape View File

@ -137,8 +137,8 @@ module Process_fork : Process_signature = struct
let (summ : Specs.summary) = Marshal.from_channel p_str.c2p_in in let (summ : Specs.summary) = Marshal.from_channel p_str.c2p_in in
(p_str, summ) (p_str, summ)
with Not_found -> with Not_found ->
L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid; L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid;
receive_from_child () (* wait for communication from the next process *) receive_from_child () (* wait for communication from the next process *)
let receive_from_parent p_str : val_t = let receive_from_parent p_str : val_t =
Marshal.from_channel p_str.p2c_in Marshal.from_channel p_str.p2c_in
@ -290,20 +290,20 @@ let compute_weighed_pnameset gr =
!pnameset !pnameset
(* Return true if there are no children of [pname] whose specs (* Return true if there are no children of [pname] whose specs
have changed since [pname] was last analyzed. *) have changed since [pname] was last analyzed. *)
let proc_is_up_to_date gr pname = let proc_is_up_to_date gr pname =
match Specs.get_summary pname with match Specs.get_summary pname with
| None -> false | None -> false
| Some summary -> | Some summary ->
let filter dependent_proc = Specs.get_timestamp summary = let filter dependent_proc = Specs.get_timestamp summary =
Procname.Map.find dependent_proc summary.Specs.dependency_map in Procname.Map.find dependent_proc summary.Specs.dependency_map in
let res = let res =
Specs.is_inactive pname && Specs.is_inactive pname &&
Procname.Set.for_all filter (Cg.get_defined_children gr pname) in Procname.Set.for_all filter (Cg.get_defined_children gr pname) in
res res
(** Return the list of procedures which should perform a phase (** Return the list of procedures which should perform a phase
transition from [FOOTPRINT] to [RE_EXECUTION] *) transition from [FOOTPRINT] to [RE_EXECUTION] *)
let should_perform_transition gr proc_name : Procname.t list = let should_perform_transition gr proc_name : Procname.t list =
let recursive_dependents = Cg.get_recursive_dependents gr proc_name in let recursive_dependents = Cg.get_recursive_dependents gr proc_name in
let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in
@ -332,10 +332,10 @@ let transition_footprint_re_exe proc_name joined_pres =
let specs = let specs =
list_map list_map
(fun jp -> (fun jp ->
Specs.spec_normalize Specs.spec_normalize
{ Specs.pre = jp; { Specs.pre = jp;
Specs.posts = []; Specs.posts = [];
Specs.visited = Specs.Visitedset.empty }) Specs.visited = Specs.Visitedset.empty })
joined_pres in joined_pres in
Specs.PrePosts specs Specs.PrePosts specs
} in } in
@ -355,11 +355,11 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
let current_specs = let current_specs =
ref ref
(list_fold_left (list_fold_left
(fun map spec -> (fun map spec ->
SpecMap.add SpecMap.add
spec.Specs.pre spec.Specs.pre
(Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map) (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map)
SpecMap.empty old_specs) in SpecMap.empty old_specs) in
let re_exe_filter old_spec = (* filter out pres which failed re-exe *) let re_exe_filter old_spec = (* filter out pres which failed re-exe *)
if phase == Specs.RE_EXECUTION && not (list_exists (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) new_specs) if phase == Specs.RE_EXECUTION && not (list_exists (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) new_specs)
then begin then begin
@ -381,9 +381,9 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
current_specs := SpecMap.add spec.Specs.pre (new_post, new_visited) (SpecMap.remove spec.Specs.pre !current_specs) end current_specs := SpecMap.add spec.Specs.pre (new_post, new_visited) (SpecMap.remove spec.Specs.pre !current_specs) end
with Not_found -> with Not_found ->
changed := true; changed := true;
L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre; L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre;
current_specs := current_specs :=
SpecMap.add SpecMap.add
spec.Specs.pre spec.Specs.pre
((Paths.PathSet.from_renamed_list spec.Specs.posts), spec.Specs.visited) ((Paths.PathSet.from_renamed_list spec.Specs.posts), spec.Specs.visited)
@ -391,10 +391,10 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
let res = ref [] in let res = ref [] in
let convert pre (post_set, visited) = let convert pre (post_set, visited) =
res := res :=
Specs.spec_normalize Specs.spec_normalize
{ Specs.pre = pre; { Specs.pre = pre;
Specs.posts = Paths.PathSet.elements post_set; Specs.posts = Paths.PathSet.elements post_set;
Specs.visited = visited }:: !res in Specs.visited = visited }:: !res in
list_iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *) list_iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *)
list_iter add_spec new_specs; (* add new specs *) list_iter add_spec new_specs; (* add new specs *)
SpecMap.iter convert !current_specs; SpecMap.iter convert !current_specs;
@ -420,10 +420,10 @@ let procs_become_done gr pname : Procname.t list =
let nonrecursive_dependents = Cg.get_nonrecursive_dependents gr pname in let nonrecursive_dependents = Cg.get_nonrecursive_dependents gr pname in
let summary = Specs.get_summary_unsafe pname in let summary = Specs.get_summary_unsafe pname in
let is_done = Specs.get_timestamp summary <> 0 && let is_done = Specs.get_timestamp summary <> 0 &&
Specs.is_inactive pname && Specs.is_inactive pname &&
(!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) && (!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) &&
Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents && Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents &&
Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in
if !trace then L.err "proc is%s done@." (if is_done then "" else " not"); if !trace then L.err "proc is%s done@." (if is_done then "" else " not");
if is_done if is_done
then then
@ -441,30 +441,30 @@ let post_process_procs exe_env procs_done =
end in end in
let cg = Exe_env.get_cg exe_env in let cg = Exe_env.get_cg exe_env in
list_iter (fun pn -> list_iter (fun pn ->
let elem = (pn, Cg.get_calls cg pn) in let elem = (pn, Cg.get_calls cg pn) in
if WeightedPnameSet.mem elem !wpnames_todo then if WeightedPnameSet.mem elem !wpnames_todo then
begin begin
incr num_procs_done; incr num_procs_done;
wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo; wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo;
let whole_seconds = false in let whole_seconds = false in
check_no_specs pn; check_no_specs pn;
Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn
end end
) procs_done ) procs_done
(** Activate a check which ensures that multi-core mode gives the same result as one-core. (** Activate a check which ensures that multi-core mode gives the same result as one-core.
If true, detect when a dependent proc is active (analyzed concurrently) If true, detect when a dependent proc is active (analyzed concurrently)
and in that case wait for a process to terminate next *) and in that case wait for a process to terminate next *)
let one_core_compatibility_mode = ref true let one_core_compatibility_mode = ref true
(** Find the max string in the [set] which satisfies [filter], and count the number of attempts. (** Find the max string in the [set] which satisfies [filter], and count the number of attempts.
Precedence is given to strings in [priority_set] *) Precedence is given to strings in [priority_set] *)
let filter_max exe_env cg filter set priority_set = let filter_max exe_env cg filter set priority_set =
let rec find_max n filter set = let rec find_max n filter set =
let elem = WeightedPnameSet.max_elt set in let elem = WeightedPnameSet.max_elt set in
let check_one_core_compatibility () = let check_one_core_compatibility () =
if !one_core_compatibility_mode && if !one_core_compatibility_mode &&
Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem)) Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem))
then raise Not_found in then raise Not_found in
check_one_core_compatibility (); check_one_core_compatibility ();
if filter elem then if filter elem then
@ -499,8 +499,8 @@ end = struct
match Config.os_type with match Config.os_type with
| Config.Unix | Config.Cygwin -> | Config.Unix | Config.Cygwin ->
ignore (Unix.setitimer Unix.ITIMER_REAL ignore (Unix.setitimer Unix.ITIMER_REAL
{ Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *) { Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *)
Unix.it_value = float_of_int nsecs }) Unix.it_value = float_of_int nsecs })
| Config.Win32 -> | Config.Win32 ->
SymOp.set_wallclock_alarm nsecs SymOp.set_wallclock_alarm nsecs
@ -522,14 +522,14 @@ end = struct
raise (Timeout_exe (TOtime)) raise (Timeout_exe (TOtime))
let () = begin let () = begin
match Config.os_type with match Config.os_type with
| Config.Unix | Config.Cygwin -> | Config.Unix | Config.Cygwin ->
Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action); Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action);
Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action) Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action)
| Config.Win32 -> | Config.Win32 ->
SymOp.set_wallclock_timeout_handler timeout_action; SymOp.set_wallclock_timeout_handler timeout_action;
ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *) ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *)
end end
let exe_timeout iterations f x = let exe_timeout iterations f x =
try try
@ -555,8 +555,8 @@ end
module Process = Process_fork module Process = Process_fork
(** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures). (** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures).
The algorithm computes dependencies between procedures, spawns processes if required, The algorithm computes dependencies between procedures, spawns processes if required,
propagates results, and handles fixpoints in the call graph. *) propagates results, and handles fixpoints in the call graph. *)
let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit = let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit =
parallel_mode := num_processes > 1 || !Config.max_num_proc > 0; parallel_mode := num_processes > 1 || !Config.max_num_proc > 0;
let call_graph = Exe_env.get_cg exe_env in let call_graph = Exe_env.get_cg exe_env in
@ -579,7 +579,7 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
Procname.Set.for_all Procname.Set.for_all
(fun child -> Specs.is_inactive child) (Cg.get_defined_children call_graph pname) && (fun child -> Specs.is_inactive child) (Cg.get_defined_children call_graph pname) &&
(Specs.get_timestamp (Specs.get_summary_unsafe pname) = 0 (Specs.get_timestamp (Specs.get_summary_unsafe pname) = 0
|| not (proc_is_up_to_date call_graph pname)) in || not (proc_is_up_to_date call_graph pname)) in
let process_one_proc pname (calls: Cg.in_out_calls) = let process_one_proc pname (calls: Cg.in_out_calls) =
DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file; DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file;
if !trace then if !trace then
@ -634,9 +634,9 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
| Some (p_str, summ) -> | Some (p_str, summ) ->
let (pname, weight) = Process.get_last_input p_str in let (pname, weight) = Process.get_last_input p_str in
(try (try
DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file; DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file;
process_result exe_env (pname, weight) summ process_result exe_env (pname, weight) summ
with exn -> assert false); with exn -> assert false);
Timing_log.event_finish (Procname.to_string pname); Timing_log.event_finish (Procname.to_string pname);
Process.kill_process p_str; Process.kill_process p_str;
incr avail_num incr avail_num
@ -654,21 +654,21 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
let pname, calls = filter_max exe_env call_graph wpname_can_be_analyzed !wpnames_todo wpnames_address_of in (** find max analyzable proc *) let pname, calls = filter_max exe_env call_graph wpname_can_be_analyzed !wpnames_todo wpnames_address_of in (** find max analyzable proc *)
process_one_proc pname calls process_one_proc pname calls
with Not_found -> (* no analyzable procs *) with Not_found -> (* no analyzable procs *)
if !avail_num < num_processes (* some other process is doing work *) if !avail_num < num_processes (* some other process is doing work *)
then wait_for_next_result () then wait_for_next_result ()
else else
(L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@." (Specs.pp_spec_table pe_text false) (); (L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@." (Specs.pp_spec_table pe_text false) ();
raise (Failure "Stopping")) raise (Failure "Stopping"))
end end
else else
wait_for_next_result () wait_for_next_result ()
done done
(** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out] (** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out]
executes [analyze_proc] in parallel as much as possible as allowed executes [analyze_proc] in parallel as much as possible as allowed
by the call graph, and applies [process_result] to the result as by the call graph, and applies [process_result] to the result as
soon as it is returned by a child process. If [filter_out] returns soon as it is returned by a child process. If [filter_out] returns
true, no execution. *) true, no execution. *)
let parallel_iter_nodes (exe_env: Exe_env.t) (_analyze_proc: Exe_env.t -> Procname.t -> 'a) (_process_result: Exe_env.t -> (Procname.t * Cg.in_out_calls) -> 'a -> unit) (filter_out: Cg.t -> Procname.t -> bool) : unit = let parallel_iter_nodes (exe_env: Exe_env.t) (_analyze_proc: Exe_env.t -> Procname.t -> 'a) (_process_result: Exe_env.t -> (Procname.t * Cg.in_out_calls) -> 'a -> unit) (filter_out: Cg.t -> Procname.t -> bool) : unit =
let analyze_proc exe_env pname = (* wrap _analyze_proc and handle exceptions *) let analyze_proc exe_env pname = (* wrap _analyze_proc and handle exceptions *)
try _analyze_proc exe_env pname with try _analyze_proc exe_env pname with

30
infer/src/backend/ident.ml
Unescape View File

@ -73,10 +73,10 @@ let ident_list_equal ids1 ids2 = (ident_list_compare ids1 ids2 = 0)
(** {2 Set for identifiers} *) (** {2 Set for identifiers} *)
module IdentSet = Set.Make module IdentSet = Set.Make
(struct (struct
type t = _ident type t = _ident
let compare = compare let compare = compare
end) end)
module IdentHash = module IdentHash =
Hashtbl.Make(struct Hashtbl.Make(struct
@ -86,14 +86,14 @@ module IdentHash =
end) end)
module FieldSet = Set.Make(struct module FieldSet = Set.Make(struct
type t = fieldname type t = fieldname
let compare = fieldname_compare let compare = fieldname_compare
end) end)
module FieldMap = Map.Make(struct module FieldMap = Map.Make(struct
type t = fieldname type t = fieldname
let compare = fieldname_compare let compare = fieldname_compare
end) end)
let idlist_to_idset ids = let idlist_to_idset ids =
list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids
@ -136,8 +136,8 @@ let fieldname_to_simplified_string fn =
match string_split_character s '.' with match string_split_character s '.' with
| Some s1, s2 -> | Some s1, s2 ->
(match string_split_character s1 '.' with (match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2 | Some s3, s4 -> s4 ^ "." ^ s2
| _ -> s) | _ -> s)
| _ -> s | _ -> s
(** Convert a fieldname to a flat string without path. *) (** Convert a fieldname to a flat string without path. *)
@ -221,7 +221,7 @@ let create_with_stamp kind name stamp =
let new_stamp = max curr_stamp stamp in let new_stamp = max curr_stamp stamp in
NameHash.replace name_map name new_stamp NameHash.replace name_map name new_stamp
with Not_found -> with Not_found ->
NameHash.add name_map name stamp in NameHash.add name_map name stamp in
update_name_hash (); update_name_hash ();
{ kind = kind; name = name; stamp = stamp } { kind = kind; name = name; stamp = stamp }
@ -290,8 +290,8 @@ let create_fresh_ident kind name =
NameHash.replace name_map name (stamp + 1); NameHash.replace name_map name (stamp + 1);
stamp + 1 stamp + 1
with Not_found -> with Not_found ->
NameHash.add name_map name 0; NameHash.add name_map name 0;
0 in 0 in
{ kind = kind; name = name; stamp = stamp } { kind = kind; name = name; stamp = stamp }
(** Create a fresh identifier with default name for the given kind. *) (** Create a fresh identifier with default name for the given kind. *)

198
infer/src/backend/inferanalyze.ml
Unescape View File

@ -93,9 +93,9 @@ let objc_ml_buckets_arg = ref "cf"
let allow_specs_cleanup = ref false let allow_specs_cleanup = ref false
(** Compute the exclude function from excluded_files and source_path. (** Compute the exclude function from excluded_files and source_path.
The exclude function builds an exclude list of file path prefixes, and checks if one The exclude function builds an exclude list of file path prefixes, and checks if one
of them is a prefix of the given source file. of them is a prefix of the given source file.
Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *) Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *)
let compute_exclude_fun () : DB.source_file -> bool = let compute_exclude_fun () : DB.source_file -> bool =
let prepend_source_path s = let prepend_source_path s =
if Filename.is_relative s then Filename.concat !source_path s if Filename.is_relative s then Filename.concat !source_path s
@ -133,53 +133,53 @@ let arg_desc =
let desc = let desc =
base_arg_desc @ base_arg_desc @
[ [
"-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel"; "-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel";
"-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file"; "-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file";
"-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis"; "-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis";
"-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies"; "-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies";
"-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)"; "-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)";
"-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise."; "-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise.";
"-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel"; "-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel";
"-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit"; "-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit";
"-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude."; "-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude.";
(* TODO: merge with the -project_root option *) (* TODO: merge with the -project_root option *)
"-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java"; "-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java";
"-version", Arg.Unit print_version, None, "print version information and exit"; "-version", Arg.Unit print_version, None, "print version information and exit";
"-version_json", Arg.Unit print_version_json, None, "print version json formatted"; "-version_json", Arg.Unit print_version_json, None, "print version json formatted";
"-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model"; "-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model";
"-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets", "-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets",
"memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)"; "memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)";
] in ] in
Arg2.create_options_desc false "Analysis Options" desc in Arg2.create_options_desc false "Analysis Options" desc in
let reserved_arg = let reserved_arg =
let desc = let desc =
reserved_arg_desc @ reserved_arg_desc @
[ [
"-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops"; "-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops";
"-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls."; "-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls.";
"-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis"; "-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis";
"-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed"; "-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed";
"-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query"; "-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query";
"-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations"; "-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations";
"-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated"; "-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated";
"-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only"; "-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only";
"-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis"; "-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis";
"-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)"; "-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)";
"-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs"; "-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs";
"-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file"; "-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file";
"-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)"; "-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)";
"-simulate", Arg.Set simulate, None, " run a simulation of the analysis only"; "-simulate", Arg.Set simulate, None, " run a simulation of the analysis only";
"-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain"; "-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain";
"-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values"; "-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values";
"-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string"; "-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string";
"-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")"; "-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")";
"-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis"; "-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis";
"-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None, "-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None,
"Report error traces for runtime exceptions (Only for Java)"; "Report error traces for runtime exceptions (Only for Java)";
"-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None, "-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None,
"Allow to remove existing specs before running analysis when it's not incremental"; "Allow to remove existing specs before running analysis when it's not incremental";
"-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None, "-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None,
"Add buckets to issue descriptions, useful when developing infer" "Add buckets to issue descriptions, useful when developing infer"
] in ] in
Arg2.create_options_desc false "Reserved Options: Experimental features, use with caution!" desc in Arg2.create_options_desc false "Reserved Options: Experimental features, use with caution!" desc in
base_arg @ reserved_arg base_arg @ reserved_arg
@ -210,7 +210,7 @@ module Simulator = struct (** Simulate the analysis only *)
(Cg.get_nodes_and_calls cg) (Cg.get_nodes_and_calls cg)
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
the procedures enabled after the analysis of [proc_name] *) the procedures enabled after the analysis of [proc_name] *)
let perform_transition exe_env proc_name = let perform_transition exe_env proc_name =
let proc_names = Fork.should_perform_transition (Exe_env.get_cg exe_env) proc_name in let proc_names = Fork.should_perform_transition (Exe_env.get_cg exe_env) proc_name in
let f proc_name = let f proc_name =
@ -242,23 +242,23 @@ let analyze exe_env =
Random.self_init (); Random.self_init ();
let line_reader = Printer.LineReader.create () in let line_reader = Printer.LineReader.create () in
if !checkers then (* run the checkers only *) if !checkers then (* run the checkers only *)
begin begin
let call_graph = Exe_env.get_cg exe_env in let call_graph = Exe_env.get_cg exe_env in
Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env
end end
else if !simulate then (* simulate the analysis *) else if !simulate then (* simulate the analysis *)
begin begin
Simulator.reset_summaries (Exe_env.get_cg exe_env); Simulator.reset_summaries (Exe_env.get_cg exe_env);
Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out
end end
else (* full analysis *) else (* full analysis *)
begin begin
Interproc.do_analysis exe_env; Interproc.do_analysis exe_env;
Printer.c_files_write_html line_reader exe_env; Printer.c_files_write_html line_reader exe_env;
Interproc.print_stats exe_env; Interproc.print_stats exe_env;
let elapsed = Unix.gettimeofday () -. init_time in let elapsed = Unix.gettimeofday () -. init_time in
L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed
end end
(** add [x] to list [l] at position [nth] *) (** add [x] to list [l] at position [nth] *)
let list_add_nth x l nth = let list_add_nth x l nth =
@ -270,7 +270,7 @@ let list_add_nth x l nth =
add [] l nth add [] l nth
(** sort a list weakly w.r.t. a compare function which doest not have to be a total order (** sort a list weakly w.r.t. a compare function which doest not have to be a total order
the number returned by [compare x y] indicates 'how strongly' x should come before y *) the number returned by [compare x y] indicates 'how strongly' x should come before y *)
let weak_sort compare list = let weak_sort compare list =
let weak_add l x = let weak_add l x =
let length = list_length l in let length = list_length l in
@ -280,14 +280,14 @@ let weak_sort compare list =
let best_value = ref (fitness.(0)) in let best_value = ref (fitness.(0)) in
let i = ref 0 in let i = ref 0 in
list_iter (fun y -> list_iter (fun y ->
incr i; incr i;
let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in
fitness.(!i) <- new_value; fitness.(!i) <- new_value;
if new_value < !best_value then if new_value < !best_value then
begin begin
best_value := new_value; best_value := new_value;
best_position := !i best_position := !i
end) end)
l; l;
list_add_nth x l !best_position in list_add_nth x l !best_position in
list_fold_left weak_add [] list list_fold_left weak_add [] list
@ -316,8 +316,8 @@ let weak_sort_nodes cg =
weak_sort cmp nodes weak_sort cmp nodes
(** cluster element: the file name, the number of procedures defined in it, and the list of active procedures (** cluster element: the file name, the number of procedures defined in it, and the list of active procedures
A procedure is active if it is defined only in this file, or if it is defined in several files and this A procedure is active if it is defined only in this file, or if it is defined in several files and this
is the representative file for it (see Exe_env.add_cg) *) is the representative file for it (see Exe_env.add_cg) *)
type cluster_elem = type cluster_elem =
{ ce_file : DB.source_file; { ce_file : DB.source_file;
ce_naprocs : int; (** number of active procedures defined in the file *) ce_naprocs : int; (** number of active procedures defined in the file *)
@ -364,7 +364,7 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio
match Cg.load_from_file cg_fname with match Cg.load_from_file cg_fname with
| None -> { ce_file = source_file; ce_naprocs = 0; ce_active_procs = []; ce_source_map = Procname.Map.empty } | None -> { ce_file = source_file; ce_naprocs = 0; ce_active_procs = []; ce_source_map = Procname.Map.empty }
| Some cg -> | Some cg ->
(* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *) (* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *)
let proc_is_selected pname = match !select_proc with let proc_is_selected pname = match !select_proc with
| None -> true | None -> true
| Some pattern_str -> string_is_prefix pattern_str (Procname.to_unique_id pname) in | Some pattern_str -> string_is_prefix pattern_str (Procname.to_unique_id pname) in
@ -411,9 +411,9 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio
let cluster, list'' = list_partition (fun node -> Procname.Set.mem node cluster_set) list in let cluster, list'' = list_partition (fun node -> Procname.Set.mem node cluster_set) list in
seen := Procname.Set.union !seen cluster_set; seen := Procname.Set.union !seen cluster_set;
let files_to_analyze = list_filter (fun node -> let files_to_analyze = list_filter (fun node ->
match only_analyze with match only_analyze with
| None -> true | None -> true
| Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in | Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in
if files_to_analyze <> [] then if files_to_analyze <> [] then
begin begin
let cluster = list_map create_cluster_elem files_to_analyze in let cluster = list_map create_cluster_elem files_to_analyze in
@ -553,7 +553,7 @@ module ClusterMakefile = struct
list_iter (fun ce -> file_to_cluster := DB.SourceFileMap.add ce.ce_file !cluster_nr !file_to_cluster) cluster; list_iter (fun ce -> file_to_cluster := DB.SourceFileMap.add ce.ce_file !cluster_nr !file_to_cluster) cluster;
list_iter do_file cluster; list_iter do_file cluster;
pp_cluster_dependency !cluster_nr tot_clusters_nr cluster print_files fmt (IntSet.elements !dependent_clusters); pp_cluster_dependency !cluster_nr tot_clusters_nr cluster print_files fmt (IntSet.elements !dependent_clusters);
(* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in (* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in
pp_prolog fmt tot_clusters_nr; pp_prolog fmt tot_clusters_nr;
list_iter do_cluster clusters; list_iter do_cluster clusters;
pp_epilog fmt (); pp_epilog fmt ();
@ -590,12 +590,12 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list =
if !incremental_mode != ANALYZE_ALL then if !incremental_mode != ANALYZE_ALL then
begin begin
Procname.Set.iter (fun c_file -> Procname.Set.iter (fun c_file ->
let ancestors = let ancestors =
try Cg.get_ancestors file_cg c_file with try Cg.get_ancestors file_cg c_file with
| Not_found -> | Not_found ->
L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file); L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file);
Procname.Set.empty in Procname.Set.empty in
files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed; files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed;
L.err "Number of files changed since the last analysis: %d.@." (Procname.Set.cardinal files_changed) L.err "Number of files changed since the last analysis: %d.@." (Procname.Set.cardinal files_changed)
end end
else L.err ".@."; else L.err ".@.";
@ -625,7 +625,7 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list =
clusters' clusters'
(** Check whether the cg file is changed. It is unchanged if for each defined procedure, the .specs (** Check whether the cg file is changed. It is unchanged if for each defined procedure, the .specs
file exists and is more recent than the cg file. *) file exists and is more recent than the cg file. *)
let cg_check_changed exe_env source_dir cg = let cg_check_changed exe_env source_dir cg =
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
let defined_nodes = Cg.get_defined_nodes cg in let defined_nodes = Cg.get_defined_nodes cg in
@ -637,7 +637,7 @@ let cg_check_changed exe_env source_dir cg =
let spec_fname = Specs.res_dir_specs_filename pname in let spec_fname = Specs.res_dir_specs_filename pname in
if is_active then if is_active then
changed := (!changed || not (Sys.file_exists (DB.filename_to_string spec_fname)) || changed := (!changed || not (Sys.file_exists (DB.filename_to_string spec_fname)) ||
DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in
list_iter check_needs_update defined_nodes; list_iter check_needs_update defined_nodes;
!changed !changed
@ -658,13 +658,13 @@ let load_cg_files _exe_env check_changed (source_dirs : DB.source_dir list) excl
let check_cg_changed (source_dir, cg) = let check_cg_changed (source_dir, cg) =
let is_changed = cg_check_changed exe_env source_dir cg in let is_changed = cg_check_changed exe_env source_dir cg in
if is_changed then files_changed := if is_changed then files_changed :=
Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in
list_iter check_cg_changed !cg_list in list_iter check_cg_changed !cg_list in
list_iter (fun source_dir -> list_iter (fun source_dir ->
match load_cg_file _exe_env source_dir exclude_fun with match load_cg_file _exe_env source_dir exclude_fun with
| None -> () | None -> ()
| Some cg -> | Some cg ->
if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs; if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs;
let exe_env = Exe_env.freeze _exe_env in let exe_env = Exe_env.freeze _exe_env in
if check_changed then check_cgs_changed exe_env; if check_changed then check_cgs_changed exe_env;
!files_changed, exe_env !files_changed, exe_env
@ -706,14 +706,14 @@ let process_cluster_cmdline_exit () =
| None -> () | None -> ()
| Some fname -> | Some fname ->
(match load_cluster_from_file (DB.filename_from_string fname) with (match load_cluster_from_file (DB.filename_from_string fname) with
| None -> | None ->
L.err "Cannot find cluster file %s@." fname; L.err "Cannot find cluster file %s@." fname;
exit 0 exit 0
| Some (nr, tot_nr, cluster) -> | Some (nr, tot_nr, cluster) ->
Fork.tot_files_done := (nr - 1) * list_length cluster; Fork.tot_files_done := (nr - 1) * list_length cluster;
Fork.tot_files := tot_nr * list_length cluster; Fork.tot_files := tot_nr * list_length cluster;
analyze_cluster (ref (nr -1)) tot_nr cluster; analyze_cluster (ref (nr -1)) tot_nr cluster;
exit 0) exit 0)
let open_output_file f fname = let open_output_file f fname =
try try
@ -722,8 +722,8 @@ let open_output_file f fname =
f fmt; f fmt;
Some (fmt, cout) Some (fmt, cout)
with Sys_error _ -> with Sys_error _ ->
Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname; Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname;
exit(-1) exit(-1)
let close_output_file = function let close_output_file = function
| None -> () | None -> ()

98
infer/src/backend/inferconfig.ml
Unescape View File

@ -66,13 +66,13 @@ let load_filters analyzer =
let is_matching patterns = let is_matching patterns =
fun source_file -> fun source_file ->
let path = DB.source_file_to_rel_path source_file in let path = DB.source_file_to_rel_path source_file in
Utils.list_exists Utils.list_exists
(fun pattern -> (fun pattern ->
try try
(Str.search_forward pattern path 0) = 0 (Str.search_forward pattern path 0) = 0
with Not_found -> false) with Not_found -> false)
patterns patterns
module FileContainsStringMatcher = struct module FileContainsStringMatcher = struct
type matcher = DB.source_file -> bool type matcher = DB.source_file -> bool
@ -96,16 +96,16 @@ module FileContainsStringMatcher = struct
let regexp = let regexp =
Str.regexp (join_strings "\\|" s_patterns) in Str.regexp (join_strings "\\|" s_patterns) in
fun source_file -> fun source_file ->
try
DB.SourceFileMap.find source_file !source_map
with Not_found ->
try try
DB.SourceFileMap.find source_file !source_map let file_in = open_in (DB.source_file_to_string source_file) in
with Not_found -> let pattern_found = file_contains regexp file_in in
try close_in file_in;
let file_in = open_in (DB.source_file_to_string source_file) in source_map := DB.SourceFileMap.add source_file pattern_found !source_map;
let pattern_found = file_contains regexp file_in in pattern_found
close_in file_in; with Sys_error _ -> false
source_map := DB.SourceFileMap.add source_file pattern_found !source_map;
pattern_found
with Sys_error _ -> false
end end
let filters_from_inferconfig inferconfig : filters = let filters_from_inferconfig inferconfig : filters =
@ -118,13 +118,13 @@ let filters_from_inferconfig inferconfig : filters =
let blacklist_files_containing_filter : path_filter = let blacklist_files_containing_filter : path_filter =
FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in
function source_file -> function source_file ->
whitelist_filter source_file && whitelist_filter source_file &&
not (blacklist_filter source_file) && not (blacklist_filter source_file) &&
not (blacklist_files_containing_filter source_file) in not (blacklist_files_containing_filter source_file) in
let error_filter = let error_filter =
function error_name -> function error_name ->
let error_str = Localise.to_string error_name in let error_str = Localise.to_string error_name in
not (list_exists (string_equal error_str) inferconfig.suppress_errors) in not (list_exists (string_equal error_str) inferconfig.suppress_errors) in
{ {
path_filter = path_filter; path_filter = path_filter;
error_filter = error_filter; error_filter = error_filter;
@ -268,25 +268,25 @@ module NeverReturnNull = struct
let pattern_map = let pattern_map =
list_fold_left list_fold_left
(fun map pattern -> (fun map pattern ->
let previous = let previous =
try try
StringMap.find pattern.class_name map StringMap.find pattern.class_name map
with Not_found -> [] in with Not_found -> [] in
StringMap.add pattern.class_name (pattern:: previous) map) StringMap.add pattern.class_name (pattern:: previous) map)
StringMap.empty StringMap.empty
m_patterns in m_patterns in
fun source_file proc_name -> fun source_file proc_name ->
let class_name = Procname.java_get_class proc_name let class_name = Procname.java_get_class proc_name
and method_name = Procname.java_get_method proc_name in and method_name = Procname.java_get_method proc_name in
try try
let class_patterns = StringMap.find class_name pattern_map in let class_patterns = StringMap.find class_name pattern_map in
list_exists list_exists
(fun p -> (fun p ->
match p.method_name with match p.method_name with
| None -> true | None -> true
| Some m -> string_equal m method_name) | Some m -> string_equal m method_name)
class_patterns class_patterns
with Not_found -> false with Not_found -> false
let create_file_matcher language patterns = let create_file_matcher language patterns =
let s_patterns, m_patterns = let s_patterns, m_patterns =
@ -301,7 +301,7 @@ module NeverReturnNull = struct
fun source_file proc_name -> matcher source_file fun source_file proc_name -> matcher source_file
and m_matcher = create_method_matcher language m_patterns in and m_matcher = create_method_matcher language m_patterns in
fun source_file proc_name -> fun source_file proc_name ->
m_matcher source_file proc_name || s_matcher source_file proc_name m_matcher source_file proc_name || s_matcher source_file proc_name
let load_matcher language = let load_matcher language =
try try
@ -313,7 +313,7 @@ module NeverReturnNull = struct
list_fold_left translate [] found in list_fold_left translate [] found in
create_file_matcher language patterns create_file_matcher language patterns
with Sys_error _ -> with Sys_error _ ->
default_matcher default_matcher
end (* of module NeverReturnNull *) end (* of module NeverReturnNull *)
@ -330,14 +330,14 @@ let test () =
[] filters in [] filters in
Utils.directory_iter Utils.directory_iter
(fun path -> (fun path ->
if DB.is_source_file path then if DB.is_source_file path then
let source_file = (DB.source_file_from_string path) in let source_file = (DB.source_file_from_string path) in
let matching = matching_analyzers source_file in let matching = matching_analyzers source_file in
if matching <> [] then if matching <> [] then
let matching_s = let matching_s =
Utils.join_strings ", " Utils.join_strings ", "
(Utils.list_map Utils.string_of_analyzer matching) in (Utils.list_map Utils.string_of_analyzer matching) in
Logging.stderr "%s -> {%s}@." Logging.stderr "%s -> {%s}@."
(DB.source_file_to_rel_path source_file) (DB.source_file_to_rel_path source_file)
matching_s) matching_s)
(Sys.getcwd ()) (Sys.getcwd ())

172
infer/src/backend/inferprint.ml
Unescape View File

@ -91,38 +91,38 @@ let arg_desc =
let base_arg = let base_arg =
let desc = let desc =
[ [
"-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format"; "-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format";
"-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format"; "-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format";
"-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format"; "-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format";
"-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format"; "-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format";
"-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv"; "-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv";
"-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar"; "-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar";
"-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format"; "-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format";
"-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format"; "-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format";
"-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir"; "-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir";
"-q", Arg.Set quiet, None, "quiet: do not print specs on standard output"; "-q", Arg.Set quiet, None, "quiet: do not print specs on standard output";
"-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar"; "-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar";
"-unit_test", Arg.Set unit_test, None, "print unit test code"; "-unit_test", Arg.Set unit_test, None, "print unit test code";
"-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml"; "-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml";
"-test_filtering", Arg.Set test_filtering, None, "-test_filtering", Arg.Set test_filtering, None,
"list all the files Infer can report on (should be call at the root of the procject, where "list all the files Infer can report on (should be call at the root of the procject, where
.inferconfig lives)."; .inferconfig lives).";
"-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer", "-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer",
"setup the analyzer for the path filtering"; "setup the analyzer for the path filtering";
"-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir", "-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir",
"Path to the .inferconfig file"; "Path to the .inferconfig file";
] in ] in
Arg2.create_options_desc false "Options" desc in Arg2.create_options_desc false "Options" desc in
let reserved_arg = let reserved_arg =
let desc = let desc =
[ [
"-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex"; "-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output"; "-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output";
"-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results"; "-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results";
"-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory"; "-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory";
"-svg", Arg.Set svg, None, "generate .dot and .svg"; "-svg", Arg.Set svg, None, "generate .dot and .svg";
"-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only"; "-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only";
] in ] in
Arg2.create_options_desc false "Reserved Options" desc in Arg2.create_options_desc false "Reserved Options" desc in
base_arg @ reserved_arg base_arg @ reserved_arg
@ -196,7 +196,7 @@ let loc_trace_to_jsonbug_record trace_list ekind =
match ekind with match ekind with
| Exceptions.Kinfo -> [] | Exceptions.Kinfo -> []
| _ -> | _ ->
(* writes a trace as a record for atdgen conversion *) (* writes a trace as a record for atdgen conversion *)
let node_tags_to_records tags_list = let node_tags_to_records tags_list =
list_map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in list_map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in
let trace_item_to_record trace_item = let trace_item_to_record trace_item =
@ -251,7 +251,7 @@ let summary_values top_proc_set summary =
list_iter do_spec specs; list_iter do_spec specs;
let visited_lines = ref IntSet.empty in let visited_lines = ref IntSet.empty in
Specs.Visitedset.iter (fun (n, ls) -> Specs.Visitedset.iter (fun (n, ls) ->
list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls) list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
!visited; !visited;
Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in
let proof_trace = let proof_trace =
@ -337,26 +337,26 @@ module ProcsXml = struct
let attributes = [("id", string_of_int !xml_procs_id) ] in let attributes = [("id", string_of_int !xml_procs_id) ] in
let forest = let forest =
[ [
subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname); subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname);
subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id); subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id);
subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs); subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs);
subtree Io_infer.Xml.tag_time sv.vtime; subtree Io_infer.Xml.tag_time sv.vtime;
subtree Io_infer.Xml.tag_to sv.vto; subtree Io_infer.Xml.tag_to sv.vto;
subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop); subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop);
subtree Io_infer.Xml.tag_err (string_of_int sv.verr); subtree Io_infer.Xml.tag_err (string_of_int sv.verr);
subtree Io_infer.Xml.tag_file sv.vfile; subtree Io_infer.Xml.tag_file sv.vfile;
subtree Io_infer.Xml.tag_line (string_of_int sv.vline); subtree Io_infer.Xml.tag_line (string_of_int sv.vline);
subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc); subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc);
subtree Io_infer.Xml.tag_top sv.vtop; subtree Io_infer.Xml.tag_top sv.vtop;
subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature); subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature);
subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight); subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight);
subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage; subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage;
subtree Io_infer.Xml.tag_rank sv.vrank; subtree Io_infer.Xml.tag_rank sv.vrank;
subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls); subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls); subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace; subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace;
subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic); subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic);
subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags)); subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags));
] in ] in
Io_infer.Xml.create_tree "procedure" attributes forest in Io_infer.Xml.create_tree "procedure" attributes forest in
Io_infer.Xml.pp_inner_node fmt tree Io_infer.Xml.pp_inner_node fmt tree
@ -506,11 +506,11 @@ module BugsXml = struct
| None -> "" in | None -> "" in
Io_infer.Xml.create_tree Io_infer.Xml.tag_loc [("num", string_of_int !num)] Io_infer.Xml.create_tree Io_infer.Xml.tag_loc [("num", string_of_int !num)]
[(level_to_xml lt.Errlog.lt_level); [(level_to_xml lt.Errlog.lt_level);
(file_to_xml (DB.source_file_to_string loc.Sil.file)); (file_to_xml (DB.source_file_to_string loc.Sil.file));
(line_to_xml loc.Sil.line); (line_to_xml loc.Sil.line);
(code_to_xml code); (code_to_xml code);
(description_to_xml lt.Errlog.lt_description); (description_to_xml lt.Errlog.lt_description);
(node_tags_to_xml lt.Errlog.lt_node_tags)] in (node_tags_to_xml lt.Errlog.lt_node_tags)] in
list_rev (list_rev_map loc_to_xml ltr) list_rev (list_rev_map loc_to_xml ltr)
(** print bugs from summary in xml *) (** print bugs from summary in xml *)
@ -539,19 +539,19 @@ module BugsXml = struct
let bug_hash = get_bug_hash kind type_str procedure_id filename node_key error_desc in let bug_hash = get_bug_hash kind type_str procedure_id filename node_key error_desc in
let forest = let forest =
[ [
subtree Io_infer.Xml.tag_class error_class; subtree Io_infer.Xml.tag_class error_class;
subtree Io_infer.Xml.tag_kind kind; subtree Io_infer.Xml.tag_kind kind;
subtree Io_infer.Xml.tag_type type_str; subtree Io_infer.Xml.tag_type type_str;
subtree Io_infer.Xml.tag_qualifier err_desc_string; subtree Io_infer.Xml.tag_qualifier err_desc_string;
subtree Io_infer.Xml.tag_severity severity; subtree Io_infer.Xml.tag_severity severity;
subtree Io_infer.Xml.tag_line error_line; subtree Io_infer.Xml.tag_line error_line;
subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name); subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name);
subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id); subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id);
subtree Io_infer.Xml.tag_file filename; subtree Io_infer.Xml.tag_file filename;
Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr); Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr);
subtree Io_infer.Xml.tag_key (string_of_int node_key); subtree Io_infer.Xml.tag_key (string_of_int node_key);
Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc); Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc);
subtree Io_infer.Xml.tag_hash (string_of_int bug_hash) subtree Io_infer.Xml.tag_hash (string_of_int bug_hash)
] ]
@ @
(if include_precondition_tree then precondition_tree () else []) in (if include_precondition_tree then precondition_tree () else []) in
@ -614,7 +614,7 @@ module UnitTest = struct
end end
(** Module to compute the top procedures. (** Module to compute the top procedures.
A procedure is top if it has specs and any procedure calling it has no specs *) A procedure is top if it has specs and any procedure calling it has no specs *)
module TopProcedures : sig module TopProcedures : sig
type t type t
val create : unit -> t val create : unit -> t
@ -675,8 +675,8 @@ module Stats = struct
let process_loc loc stats = let process_loc loc stats =
try Hashtbl.find stats.files loc.Sil.file try Hashtbl.find stats.files loc.Sil.file
with Not_found -> with Not_found ->
stats.nLOC <- stats.nLOC + loc.Sil.nLOC; stats.nLOC <- stats.nLOC + loc.Sil.nLOC;
Hashtbl.add stats.files loc.Sil.file () Hashtbl.add stats.files loc.Sil.file ()
let loc_trace_to_string_list linereader indent_num ltr = let loc_trace_to_string_list linereader indent_num ltr =
let res = ref [] in let res = ref [] in
@ -810,7 +810,7 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let always_report () = let always_report () =
Localise.error_desc_extract_tag_value error_desc "always_report" = "true" in Localise.error_desc_extract_tag_value error_desc "always_report" = "true" in
(filters.Inferconfig.path_filter summary.Specs.loc.Sil.file (filters.Inferconfig.path_filter summary.Specs.loc.Sil.file
|| always_report ()) && || always_report ()) &&
filters.Inferconfig.error_filter error_name in filters.Inferconfig.error_filter error_name in
do_outf procs_csv (fun outf -> F.fprintf outf.fmt "%a" (ProcsCsv.pp_summary fname top_proc_set) summary); do_outf procs_csv (fun outf -> F.fprintf outf.fmt "%a" (ProcsCsv.pp_summary fname top_proc_set) summary);
do_outf calls_csv (fun outf -> F.fprintf outf.fmt "%a" (CallsCsv.pp_calls fname) summary); do_outf calls_csv (fun outf -> F.fprintf outf.fmt "%a" (CallsCsv.pp_calls fname) summary);
@ -829,11 +829,11 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let dot_file = DB.filename_add_suffix base ".dot" in let dot_file = DB.filename_add_suffix base ".dot" in
let svg_file = DB.filename_add_suffix base ".svg" in let svg_file = DB.filename_add_suffix base ".svg" in
if not (DB.file_exists dot_file) if not (DB.file_exists dot_file)
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file
then then
Dotty.pp_speclist_dotty_file base specs; Dotty.pp_speclist_dotty_file base specs;
if not (DB.file_exists svg_file) if not (DB.file_exists svg_file)
|| DB.file_modified_time dot_file > DB.file_modified_time svg_file || DB.file_modified_time dot_file > DB.file_modified_time svg_file
then then
ignore (Sys.command ("dot -Tsvg \"" ^ (DB.filename_to_string dot_file) ^ "\" >\"" ^ (DB.filename_to_string svg_file) ^"\"")) ignore (Sys.command ("dot -Tsvg \"" ^ (DB.filename_to_string dot_file) ^ "\" >\"" ^ (DB.filename_to_string svg_file) ^"\""))
end; end;
@ -841,13 +841,13 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let xml_file = DB.filename_add_suffix base ".xml" in let xml_file = DB.filename_add_suffix base ".xml" in
let specs = Specs.get_specs_from_payload summary in let specs = Specs.get_specs_from_payload summary in
if not (DB.file_exists xml_file) if not (DB.file_exists xml_file)
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file
then then
begin begin
let xml_out = ref (create_outfile (DB.filename_to_string xml_file)) in let xml_out = ref (create_outfile (DB.filename_to_string xml_file)) in
do_outf xml_out (fun outf -> do_outf xml_out (fun outf ->
Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt; Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt;
close_outf outf) close_outf outf)
end end
end end
(* ignore (Sys.command ("open " ^ base ^ ".svg")) *) (* ignore (Sys.command ("open " ^ base ^ ".svg")) *)
@ -868,11 +868,11 @@ module AnalysisResults = struct
exit(0) exit(0)
end; end;
list_append (if !args = ["."] then begin list_append (if !args = ["."] then begin
let arr = Sys.readdir "." in let arr = Sys.readdir "." in
let all_files = Array.to_list arr in let all_files = Array.to_list arr in
list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files
end end
else !args) (results_dir_specsfiles ()) else !args) (results_dir_specsfiles ())
(** apply [f] to [arg] with the gc compaction disabled during the execution *) (** apply [f] to [arg] with the gc compaction disabled during the execution *)
let apply_without_gc f arg = let apply_without_gc f arg =
@ -925,7 +925,7 @@ module AnalysisResults = struct
Serialization.to_file analysis_results_serializer filename analysis_results Serialization.to_file analysis_results_serializer filename analysis_results
(** Return an iterator over all the summaries. (** Return an iterator over all the summaries.
If options - load_results or - save_results are used, all the summaries are loaded in memory *) If options - load_results or - save_results are used, all the summaries are loaded in memory *)
let get_summary_iterator () = let get_summary_iterator () =
let iterator_of_summary_list r = let iterator_of_summary_list r =
fun f -> list_iter f r in fun f -> list_iter f r in
@ -987,10 +987,10 @@ let () =
do_outf bugs_txt close_outf; do_outf bugs_txt close_outf;
do_outf bugs_xml (fun outf -> BugsXml.pp_bugs_close outf.fmt (); close_outf outf); do_outf bugs_xml (fun outf -> BugsXml.pp_bugs_close outf.fmt (); close_outf outf);
do_outf latex (fun outf -> do_outf latex (fun outf ->
Latex.pp_end outf.fmt (); Latex.pp_end outf.fmt ();
close_outf outf; close_outf outf;
pdflatex outf.fname; pdflatex outf.fname;
let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in
ignore (Sys.command ("open " ^ pdf_name))); ignore (Sys.command ("open " ^ pdf_name)));
do_outf report (fun outf -> F.fprintf outf.fmt "%a@?" Report.pp_stats stats; close_outf outf); do_outf report (fun outf -> F.fprintf outf.fmt "%a@?" Report.pp_stats stats; close_outf outf);
if !precondition_stats then PreconditionStats.pp_stats () if !precondition_stats then PreconditionStats.pp_stats ()

242
infer/src/backend/interproc.ml
Unescape View File

@ -67,9 +67,9 @@ module Worklist = struct
map := NodeMap.add min.node (min.visits + 1) !map; (* increase the visits *) map := NodeMap.add min.node (min.visits + 1) !map; (* increase the visits *)
min.node min.node
with Not_found -> begin with Not_found -> begin
L.out "@\n...Work list is empty! Impossible to remove edge...@\n"; L.out "@\n...Work list is empty! Impossible to remove edge...@\n";
assert false assert false
end end
end end
(* =============== END of module Worklist =============== *) (* =============== END of module Worklist =============== *)
@ -100,8 +100,8 @@ let htable_retrieve (htable : (int, Paths.PathSet.t) Hashtbl.t) (key : int) : Pa
try try
Hashtbl.find htable key Hashtbl.find htable key
with Not_found -> with Not_found ->
Hashtbl.replace htable key Paths.PathSet.empty; Hashtbl.replace htable key Paths.PathSet.empty;
Paths.PathSet.empty Paths.PathSet.empty
let path_set_get_visited (sid: int) : Paths.PathSet.t = let path_set_get_visited (sid: int) : Paths.PathSet.t =
htable_retrieve path_set_visited sid htable_retrieve path_set_visited sid
@ -130,8 +130,8 @@ let path_set_checkout_todo (node: Cfg.node) : Paths.PathSet.t =
Hashtbl.replace path_set_visited sid new_visited; Hashtbl.replace path_set_visited sid new_visited;
todo todo
with Not_found -> with Not_found ->
L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node; L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node;
assert false assert false
(* =============== END of the edge_set object =============== *) (* =============== END of the edge_set object =============== *)
@ -166,11 +166,11 @@ let pp_path_dotty f path =
let pp_complete_path_dotty_file = let pp_complete_path_dotty_file =
let counter = ref 0 in let counter = ref 0 in
fun path -> fun path ->
incr counter; incr counter;
let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in
let fmt = F.formatter_of_out_channel outc in let fmt = F.formatter_of_out_channel outc in
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path; F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path;
close_out outc close_out outc
(* =============== END: Print a complete path in a dotty file =============== *) (* =============== END: Print a complete path in a dotty file =============== *)
@ -306,10 +306,10 @@ let do_symexec_join pname tenv curr_node (edgeset_todo : Paths.PathSet.t) =
let old_dset', new_dset' = Dom.pathset_join curr_pname tenv old_dset new_dset in let old_dset', new_dset' = Dom.pathset_join curr_pname tenv old_dset new_dset in
Join_table.put curr_id (Paths.PathSet.union old_dset' new_dset'); Join_table.put curr_id (Paths.PathSet.union old_dset' new_dset');
list_iter (fun node -> list_iter (fun node ->
Paths.PathSet.iter (fun prop path -> Paths.PathSet.iter (fun prop path ->
State.set_path path None; State.set_path path None;
propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node) propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node)
new_dset') succ_nodes new_dset') succ_nodes
let prop_max_size = ref (0, Prop.prop_emp) let prop_max_size = ref (0, Prop.prop_emp)
let prop_max_chain_size = ref (0, Prop.prop_emp) let prop_max_chain_size = ref (0, Prop.prop_emp)
@ -319,9 +319,9 @@ let check_prop_size p path =
let size = Prop.Metrics.prop_size p in let size = Prop.Metrics.prop_size p in
if size > fst !prop_max_size then if size > fst !prop_max_size then
(prop_max_size := (size, p); (prop_max_size := (size, p);
L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":"); L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":");
Prop.d_prop p; Prop.d_prop p;
L.d_ln ()) L.d_ln ())
(* Check prop size and filter out possible unabstracted lists *) (* Check prop size and filter out possible unabstracted lists *)
let check_prop_size edgeset_todo = let check_prop_size edgeset_todo =
@ -342,8 +342,8 @@ let d_path (path, pos_opt) =
incr step; incr step;
(* Propset.pp_proplist_dotty_file ("path" ^ (string_of_int !count) ^ ".dot") plist; *) (* Propset.pp_proplist_dotty_file ("path" ^ (string_of_int !count) ^ ".dot") plist; *)
L.d_strln ("Path Step #" ^ string_of_int !step ^ L.d_strln ("Path Step #" ^ string_of_int !step ^
" node " ^ string_of_int (Cfg.Node.get_id curr_node) ^ " node " ^ string_of_int (Cfg.Node.get_id curr_node) ^
" session " ^ string_of_int session ^ ":"); " session " ^ string_of_int session ^ ":");
Propset.d !prop_last_step (Propset.from_proplist plist); L.d_ln (); Propset.d !prop_last_step (Propset.from_proplist plist); L.d_ln ();
Cfg.Node.d_instrs true None curr_node; L.d_ln (); L.d_ln (); Cfg.Node.d_instrs true None curr_node; L.d_ln (); L.d_ln ();
prop_last_step := (match plist with | [prop] -> prop | _ -> Prop.prop_emp) in prop_last_step := (match plist with | [prop] -> prop | _ -> Prop.prop_emp) in
@ -435,13 +435,13 @@ let check_assignement_guard node =
let succs_loc = list_map (fun n -> Cfg.Node.get_loc n) succs in let succs_loc = list_map (fun n -> Cfg.Node.get_loc n) succs in
let succs_are_all_prune_nodes () = let succs_are_all_prune_nodes () =
list_for_all (fun n -> match Cfg.Node.get_kind n with list_for_all (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Prune_node(_) -> true | Cfg.Node.Prune_node(_) -> true
| _ -> false) succs in | _ -> false) succs in
let succs_same_loc_as_node () = let succs_same_loc_as_node () =
if verbose then (L.d_str ("LOCATION NODE: line: "^(string_of_int l_node.Sil.line)^" nLOC: "^(string_of_int l_node.Sil.nLOC)); L.d_strln " "); if verbose then (L.d_str ("LOCATION NODE: line: "^(string_of_int l_node.Sil.line)^" nLOC: "^(string_of_int l_node.Sil.nLOC)); L.d_strln " ");
list_for_all (fun l -> list_for_all (fun l ->
if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " "); if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " ");
Sil.loc_equal l l_node) succs_loc in Sil.loc_equal l l_node) succs_loc in
let succs_have_simple_guards () = (* check that the guards of the succs are a var or its negation *) let succs_have_simple_guards () = (* check that the guards of the succs are a var or its negation *)
let check_instr = function let check_instr = function
| Sil.Prune (Sil.Var _, _, _, _) -> true | Sil.Prune (Sil.Var _, _, _, _) -> true
@ -453,20 +453,20 @@ let check_assignement_guard node =
list_for_all check_guard succs in list_for_all check_guard succs in
if !Sil.curr_language = Sil.C_CPP && succs_are_all_prune_nodes () && succs_same_loc_as_node () && succs_have_simple_guards () then if !Sil.curr_language = Sil.C_CPP && succs_are_all_prune_nodes () && succs_same_loc_as_node () && succs_have_simple_guards () then
(let instr = Cfg.Node.get_instrs node in (let instr = Cfg.Node.get_instrs node in
match succs_loc with match succs_loc with
| loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*) | loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*)
let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in
(match set_instr_at_succs_loc with (match set_instr_at_succs_loc with
| [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*) | [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*)
if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then ( if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then (
let desc = Errdesc.explain_condition_is_assignment l_node in let desc = Errdesc.explain_condition_is_assignment l_node in
let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn
) )
else () else ()
| _ -> ()) | _ -> ())
| _ -> if verbose then L.d_strln "NOT FOUND loc_succ" | _ -> if verbose then L.d_strln "NOT FOUND loc_succ"
) else () ) else ()
(** Perform symbolic execution for a node starting from an initial prop *) (** Perform symbolic execution for a node starting from an initial prop *)
@ -503,9 +503,9 @@ let forward_tabulate cfg tenv =
let pre_opt = (* precondition leading to error, if any *) let pre_opt = (* precondition leading to error, if any *)
State.get_normalized_pre (Abs.abstract_no_symop curr_pname) in State.get_normalized_pre (Abs.abstract_no_symop curr_pname) in
(match pre_opt with (match pre_opt with
| Some pre -> | Some pre ->
L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln () L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln ()
| None -> ()); | None -> ());
L.d_strln "SIL INSTR:"; L.d_strln "SIL INSTR:";
Cfg.Node.d_instrs ~sub_instrs: true (State.get_instr ()) curr_node; L.d_ln (); Cfg.Node.d_instrs ~sub_instrs: true (State.get_instr ()) curr_node; L.d_ln ();
Reporting.log_error ~pre: pre_opt curr_pname exn; Reporting.log_error ~pre: pre_opt curr_pname exn;
@ -544,10 +544,10 @@ let forward_tabulate cfg tenv =
handled_some_exception := false; handled_some_exception := false;
check_prop_size pathset_todo; check_prop_size pathset_todo;
L.d_strln ("**** " ^ (log_string proc_name) ^ " " ^ L.d_strln ("**** " ^ (log_string proc_name) ^ " " ^
"Node: " ^ string_of_int sid_curr_node ^ ", " ^ "Node: " ^ string_of_int sid_curr_node ^ ", " ^
"Procedure: " ^ Procname.to_string proc_name ^ ", " ^ "Procedure: " ^ Procname.to_string proc_name ^ ", " ^
"Session: " ^ string_of_int session ^ ", " ^ "Session: " ^ string_of_int session ^ ", " ^
"Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****"); "Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****");
L.d_increase_indent 1; L.d_increase_indent 1;
Propset.d Prop.prop_emp (Paths.PathSet.to_propset pathset_todo); Propset.d Prop.prop_emp (Paths.PathSet.to_propset pathset_todo);
L.d_strln ".... Instructions: .... "; L.d_strln ".... Instructions: .... ";
@ -563,24 +563,24 @@ let forward_tabulate cfg tenv =
| Cfg.Node.Start_node _ -> | Cfg.Node.Start_node _ ->
exe_iter exe_iter
(fun prop path cnt num_paths -> (fun prop path cnt num_paths ->
try try
L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths); L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths);
L.d_increase_indent 1; L.d_increase_indent 1;
State.reset_diverging_states_goto_node (); State.reset_diverging_states_goto_node ();
let pset = let pset =
do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in
L.d_decrease_indent 1; L.d_ln(); L.d_decrease_indent 1; L.d_ln();
propagate_nodes_divergence tenv proc_desc pset path kind_curr_node succ_nodes exn_nodes; propagate_nodes_divergence tenv proc_desc pset path kind_curr_node succ_nodes exn_nodes;
with exn when Exceptions.handle_exception exn && !Config.footprint -> with exn when Exceptions.handle_exception exn && !Config.footprint ->
handle_exn curr_node exn; handle_exn curr_node exn;
if !Config.nonstop then propagate_nodes_divergence tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)]) path kind_curr_node succ_nodes exn_nodes; if !Config.nonstop then propagate_nodes_divergence tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)]) path kind_curr_node succ_nodes exn_nodes;
L.d_decrease_indent 1; L.d_ln ()) L.d_decrease_indent 1; L.d_ln ())
pathset_todo in pathset_todo in
try begin try begin
doit(); doit();
if !handled_some_exception then Printer.force_delayed_prints (); if !handled_some_exception then Printer.force_delayed_prints ();
do_after_node curr_node do_after_node curr_node
end end
with with
| exn when Exceptions.handle_exception exn -> | exn when Exceptions.handle_exception exn ->
handle_exn curr_node exn; handle_exn curr_node exn;
@ -709,9 +709,9 @@ let create_seed_vars sigma =
list_fold_left hpred_add_seed [] sigma list_fold_left hpred_add_seed [] sigma
(** Initialize proposition for execution given formal and global (** Initialize proposition for execution given formal and global
parameters. The footprint is initialized according to the parameters. The footprint is initialized according to the
execution mode. The prop is not necessarily emp, so it execution mode. The prop is not necessarily emp, so it
should be incorporated when the footprint is constructed. *) should be incorporated when the footprint is constructed. *)
let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t = let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t =
let sigma_new_formals = let sigma_new_formals =
let do_formal (pv, typ) = let do_formal (pv, typ) =
@ -726,17 +726,17 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
let new_pi = let new_pi =
let pi = Prop.get_pi prop in let pi = Prop.get_pi prop in
pi pi
(* inactive until it becomes necessary, as it pollutes props (* inactive until it becomes necessary, as it pollutes props
let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in
let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in
let pi_undef = list_map mk_undef_atom fav_ids in let pi_undef = list_map mk_undef_atom fav_ids in
pi_undef @ pi *) in pi_undef @ pi *) in
let prop' = let prop' =
Prop.replace_pi new_pi (Prop.prop_sigma_star prop sigma) in Prop.replace_pi new_pi (Prop.prop_sigma_star prop sigma) in
Prop.replace_sigma_footprint (Prop.get_sigma_footprint prop' @ sigma_new_formals) prop' Prop.replace_sigma_footprint (Prop.get_sigma_footprint prop' @ sigma_new_formals) prop'
(** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true (** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true
as well as seed variables *) as well as seed variables *)
let initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t = let initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t =
let construct_decl (x, typ) = let construct_decl (x, typ) =
(Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in (Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in
@ -766,7 +766,7 @@ let initial_prop_from_pre tenv curr_f pre =
(** Re-execute one precondition and return some spec if there was no re-execution error. *) (** Re-execute one precondition and return some spec if there was no re-execution error. *)
let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Specs.Jprop.t) let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Specs.Jprop.t)
: Prop.normal Specs.spec option = : Prop.normal Specs.spec option =
let proc_name = Cfg.Procdesc.get_proc_name pdesc in let proc_name = Cfg.Procdesc.get_proc_name pdesc in
do_before_node 0 init_node; do_before_node 0 init_node;
L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####"); L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####");
@ -800,16 +800,16 @@ let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Spe
do_after_node init_node; do_after_node init_node;
Some spec Some spec
with RE_EXE_ERROR -> with RE_EXE_ERROR ->
do_before_node 0 init_node; do_before_node 0 init_node;
Printer.force_delayed_prints (); Printer.force_delayed_prints ();
L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR"); L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR");
L.d_increase_indent 1; L.d_increase_indent 1;
L.d_strln "when starting from pre:"; L.d_strln "when starting from pre:";
Prop.d_prop (Specs.Jprop.to_prop precondition); Prop.d_prop (Specs.Jprop.to_prop precondition);
L.d_strln "This precondition is filtered out."; L.d_strln "This precondition is filtered out.";
L.d_decrease_indent 1; L.d_decrease_indent 1;
do_after_node init_node; do_after_node init_node;
None None
(** get all the nodes in the current call graph with their defined children *) (** get all the nodes in the current call graph with their defined children *)
let get_procs_and_defined_children call_graph = let get_procs_and_defined_children call_graph =
@ -822,12 +822,12 @@ let pp_intra_stats cfg proc_desc fmt proc_name =
F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates
(** Return functions to perform one phase of the analysis for a procedure. (** Return functions to perform one phase of the analysis for a procedure.
Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase
and [get_results ()] returns the results computed. and [get_results ()] returns the results computed.
This function is architected so that [get_results ()] can be called even after This function is architected so that [get_results ()] can be called even after
[go ()] was interrupted by and exception. *) [go ()] was interrupted by and exception. *)
let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t) let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t)
: (unit -> unit) * (unit -> Prop.normal Specs.spec list) = : (unit -> unit) * (unit -> Prop.normal Specs.spec list) =
let start_node = Cfg.Procdesc.get_start_node pdesc in let start_node = Cfg.Procdesc.get_start_node pdesc in
let check_recursion_level () = let check_recursion_level () =
@ -878,7 +878,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
| Exceptions.Leak _ -> | Exceptions.Leak _ ->
let exn = let exn =
Exceptions.Internal_error Exceptions.Internal_error
(Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in (Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_error pname ~pre: pre_opt exn; Reporting.log_error pname ~pre: pre_opt exn;
[] (* retuning no specs *) in [] (* retuning no specs *) in
@ -975,7 +975,7 @@ let remove_this_not_null prop =
| hpred -> (var_option, hpred:: hpreds) in | hpred -> (var_option, hpred:: hpreds) in
let collect_atom var atoms = function let collect_atom var atoms = function
| Sil.Aneq (Sil.Var v, e) | Sil.Aneq (Sil.Var v, e)
when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms
| a -> a:: atoms in | a -> a:: atoms in
match list_fold_left collect_hpred (None, []) (Prop.get_sigma prop) with match list_fold_left collect_hpred (None, []) (Prop.get_sigma prop) with
| None, _ -> prop | None, _ -> prop
@ -988,8 +988,8 @@ let remove_this_not_null prop =
(** Detects if there are specs of the form {precondition} proc {runtime exception} and report (** Detects if there are specs of the form {precondition} proc {runtime exception} and report
an error in that case, generating the trace that lead to the runtime exception if the method is an error in that case, generating the trace that lead to the runtime exception if the method is
called in the context { precondition } *) called in the context { precondition } *)
let report_runtime_exceptions tenv cfg pdesc summary = let report_runtime_exceptions tenv cfg pdesc summary =
let pname = Specs.get_proc_name summary in let pname = Specs.get_proc_name summary in
let is_public_method = let is_public_method =
@ -1043,8 +1043,8 @@ let update_summary prev_summary specs proc_name elapsed res =
(** Analyze [proc_name] and return the updated summary. Use module (** Analyze [proc_name] and return the updated summary. Use module
[Timeout] to call [perform_analysis_phase] with a time limit, and [Timeout] to call [perform_analysis_phase] with a time limit, and
then return the updated summary. Executed as a child process. *) then return the updated summary. Executed as a child process. *)
let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary = let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
if !Config.trace_anal then L.err "===analyze_proc@."; if !Config.trace_anal then L.err "===analyze_proc@.";
let init_time = Unix.gettimeofday () in let init_time = Unix.gettimeofday () in
@ -1067,7 +1067,7 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
updated_summary updated_summary
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
the procedures enabled after the analysis of [proc_name] *) the procedures enabled after the analysis of [proc_name] *)
let perform_transition exe_env cg proc_name = let perform_transition exe_env cg proc_name =
let proc_names = Fork.should_perform_transition cg proc_name in let proc_names = Fork.should_perform_transition cg proc_name in
let transition pname = let transition pname =
@ -1090,19 +1090,19 @@ let perform_transition exe_env cg proc_name =
apply_start_node do_after_node; apply_start_node do_after_node;
res res
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
apply_start_node do_after_node; apply_start_node do_after_node;
Config.allowleak := allowleak; Config.allowleak := allowleak;
L.err "Error in collect_preconditions for %a@." Procname.pp proc_name; L.err "Error in collect_preconditions for %a@." Procname.pp proc_name;
let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in
let err_str = "exception raised " ^ (Localise.to_string err_name) in let err_str = "exception raised " ^ (Localise.to_string err_name) in
L.err "Error: %s %a@." err_str pp_ml_location_opt mloco; L.err "Error: %s %a@." err_str pp_ml_location_opt mloco;
[] in [] in
Fork.transition_footprint_re_exe pname joined_pres in Fork.transition_footprint_re_exe pname joined_pres in
list_iter transition proc_names list_iter transition proc_names
(** Process the result of the analysis of [proc_name]: update the (** Process the result of the analysis of [proc_name]: update the
returned summary and add it to the spec table. Executed in the returned summary and add it to the spec table. Executed in the
parent process as soon as a child process returns a result. *) parent process as soon as a child process returns a result. *)
let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary) : unit = let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary) : unit =
if !Config.trace_anal then L.err "===process_result@."; if !Config.trace_anal then L.err "===process_result@.";
Ident.reset_name_generator (); (* for consistency with multi-core mode *) Ident.reset_name_generator (); (* for consistency with multi-core mode *)
@ -1112,14 +1112,14 @@ let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary
perform_transition exe_env call_graph proc_name; perform_transition exe_env call_graph proc_name;
if !Config.only_footprint || summ.Specs.phase != Specs.FOOTPRINT then if !Config.only_footprint || summ.Specs.phase != Specs.FOOTPRINT then
(try Specs.store_summary proc_name summ with (try Specs.store_summary proc_name summ with
Sys_error s -> Sys_error s ->
L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s); L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s);
let procs_done = Fork.procs_become_done call_graph proc_name in let procs_done = Fork.procs_become_done call_graph proc_name in
Fork.post_process_procs exe_env procs_done Fork.post_process_procs exe_env procs_done
(** Return true if the analysis of [proc_name] should be (** Return true if the analysis of [proc_name] should be
skipped. Called by the parent process before attempting to analyze a skipped. Called by the parent process before attempting to analyze a
proc. *) proc. *)
let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool = let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool =
if !Config.trace_anal then L.err "===filter_out@."; if !Config.trace_anal then L.err "===filter_out@.";
let slice_out = (* filter out if slicing is active and [proc_name] not in slice *) let slice_out = (* filter out if slicing is active and [proc_name] not in slice *)
@ -1192,16 +1192,16 @@ let do_analysis exe_env =
Callbacks.proc_inline_synthetic_methods cfg pdesc; Callbacks.proc_inline_synthetic_methods cfg pdesc;
Specs.init_summary Specs.init_summary
(pname, ret_type, formals, dep, loc, nodes, proc_flags, (pname, ret_type, formals, dep, loc, nodes, proc_flags,
static_err_log, calls, cyclomatic, None, attributes) in static_err_log, calls, cyclomatic, None, attributes) in
let filter = let filter =
if !Config.only_skips then (filter_skipped_procs cg procs_and_defined_children) if !Config.only_skips then (filter_skipped_procs cg procs_and_defined_children)
else if !Config.only_nospecs then filter_nospecs else if !Config.only_nospecs then filter_nospecs
else (fun _ -> true) in else (fun _ -> true) in
list_iter (fun x -> if filter x then init_proc x) procs_and_defined_children; list_iter (fun x -> if filter x then init_proc x) procs_and_defined_children;
(try Fork.parallel_iter_nodes exe_env analyze_proc process_result filter_out with (try Fork.parallel_iter_nodes exe_env analyze_proc process_result filter_out with
exe when do_parallel -> exe when do_parallel ->
L.out "@.@. ERROR exception raised in parallel execution@."; L.out "@.@. ERROR exception raised in parallel execution@.";
raise exe) raise exe)
let visited_and_total_nodes cfg = let visited_and_total_nodes cfg =
let all_nodes = let all_nodes =
@ -1218,7 +1218,7 @@ let visited_and_total_nodes cfg =
Cfg.NodeSet.elements visited_nodes_re, Cfg.NodeSet.elements counted_nodes Cfg.NodeSet.elements visited_nodes_re, Cfg.NodeSet.elements counted_nodes
(** Print the stats for the given cfg; consider every defined proc unless a proc with the same name (** Print the stats for the given cfg; consider every defined proc unless a proc with the same name
was defined in another module, and was the one which was analyzed *) was defined in another module, and was the one which was analyzed *)
let print_stats_cfg proc_shadowed proc_is_active cfg = let print_stats_cfg proc_shadowed proc_is_active cfg =
let err_table = Errlog.create_err_table () in let err_table = Errlog.create_err_table () in
let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in
@ -1248,9 +1248,9 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
tot_specs := (list_length specs) + !tot_specs; tot_specs := (list_length specs) + !tot_specs;
let () = let () =
match specs, match specs,
Errlog.size Errlog.size
(fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint) (fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint)
stats.Specs.err_log with stats.Specs.err_log with
| [], 0 -> incr num_nospec_noerror_proc | [], 0 -> incr num_nospec_noerror_proc
| _, 0 -> incr num_spec_noerror_proc | _, 0 -> incr num_spec_noerror_proc
| [], _ -> incr num_nospec_error_proc | [], _ -> incr num_nospec_error_proc
@ -1264,7 +1264,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
let num_infos = Errlog.err_table_size_footprint Exceptions.Kinfo err_table in let num_infos = Errlog.err_table_size_footprint Exceptions.Kinfo err_table in
let num_ok_proc = !num_spec_noerror_proc + !num_spec_error_proc in let num_ok_proc = !num_spec_noerror_proc + !num_spec_error_proc in
(* F.fprintf fmt "VISITED: %a@\n" (pp_seq pp_node) nodes_visited; (* F.fprintf fmt "VISITED: %a@\n" (pp_seq pp_node) nodes_visited;
F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *) F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *)
F.fprintf fmt "@\n++++++++++++++++++++++++++++++++++++++++++++++++++@\n"; F.fprintf fmt "@\n++++++++++++++++++++++++++++++++++++++++++++++++++@\n";
F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (list_length nodes_visited) (list_length nodes_total) !tot_symops; F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (list_length nodes_visited) (list_length nodes_total) !tot_symops;
F.fprintf fmt "+ num_procs: %d (%d ok, %d timeouts, %d errors, %d warnings, %d infos)@\n" !num_proc num_ok_proc !num_timeout num_errors num_warnings num_infos; F.fprintf fmt "+ num_procs: %d (%d ok, %d timeouts, %d errors, %d warnings, %d infos)@\n" !num_proc num_ok_proc !num_timeout num_errors num_warnings num_infos;
@ -1297,8 +1297,8 @@ let print_stats exe_env =
let proc_is_active proc_desc = let proc_is_active proc_desc =
Exe_env.proc_is_active exe_env (Cfg.Procdesc.get_proc_name proc_desc) in Exe_env.proc_is_active exe_env (Cfg.Procdesc.get_proc_name proc_desc) in
Exe_env.iter_files (fun fname tenv cfg -> Exe_env.iter_files (fun fname tenv cfg ->
let proc_shadowed proc_desc = let proc_shadowed proc_desc =
(** return true if a proc with the same name in another module was analyzed instead *) (** return true if a proc with the same name in another module was analyzed instead *)
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
Exe_env.get_source exe_env proc_name <> fname in Exe_env.get_source exe_env proc_name <> fname in
print_stats_cfg proc_shadowed proc_is_active cfg) exe_env print_stats_cfg proc_shadowed proc_is_active cfg) exe_env

116
infer/src/backend/io_infer.ml
Unescape View File

@ -24,11 +24,11 @@ module Html : sig
val pp_end_color : Format.formatter -> unit -> unit (** Print end color *) val pp_end_color : Format.formatter -> unit -> unit (** Print end color *)
(** [pp_node_link path_to_root description isvisited isproof fmt id] prints an html link to the given node. (** [pp_node_link path_to_root description isvisited isproof fmt id] prints an html link to the given node.
[path_to_root] is the path to the dir for the procedure in the spec db. [path_to_root] is the path to the dir for the procedure in the spec db.
[description] is a string description. [description] is a string description.
[is_visited] indicates whether the node should be active or greyed out. [is_visited] indicates whether the node should be active or greyed out.
[is_proof] indicates whether the node is part of a proof and should be green. [is_proof] indicates whether the node is part of a proof and should be green.
[id] is the node identifier. *) [id] is the node identifier. *)
val pp_node_link : DB.Results_dir.path -> string -> int list -> int list -> int list -> bool -> bool -> Format.formatter -> int -> unit val pp_node_link : DB.Results_dir.path -> string -> int list -> int list -> int list -> bool -> bool -> Format.formatter -> int -> unit
val pp_proc_link : DB.Results_dir.path -> Procname.t -> Format.formatter -> string -> unit (** Print an html link to the given proc *) val pp_proc_link : DB.Results_dir.path -> Procname.t -> Format.formatter -> string -> unit (** Print an html link to the given proc *)
val pp_session_link : ?with_name: bool -> string list -> Format.formatter -> int * int * int -> unit (** Print an html link given node id and session *) val pp_session_link : ?with_name: bool -> string list -> Format.formatter -> int * int * int -> unit (** Print an html link given node id and session *)
@ -45,59 +45,59 @@ end = struct
let s = let s =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" ++ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" ++
"<html>\n<head>\n<title>" ^ fname ^ "</title>" ++ "<html>\n<head>\n<title>" ^ fname ^ "</title>" ++
"<style type=\"text/css\">" ++ "<style type=\"text/css\">" ++
"body { color:#000000; background-color:#ffffff }" ++ "body { color:#000000; background-color:#ffffff }" ++
"body { font-family:Helvetica, sans-serif; font-size:10pt }" ++ "body { font-family:Helvetica, sans-serif; font-size:10pt }" ++
"h1 { font-size:14pt }" ++ "h1 { font-size:14pt }" ++
".code { border-collapse:collapse; width:100%; }" ++ ".code { border-collapse:collapse; width:100%; }" ++
".code { font-family: \"Andale Mono\", monospace; font-size:10pt }" ++ ".code { font-family: \"Andale Mono\", monospace; font-size:10pt }" ++
".code { line-height: 1.2em }" ++ ".code { line-height: 1.2em }" ++
".comment { color: green; font-style: oblique }" ++ ".comment { color: green; font-style: oblique }" ++
".keyword { color: blue }" ++ ".keyword { color: blue }" ++
".string_literal { color: red }" ++ ".string_literal { color: red }" ++
".color_black { color: black }" ++ ".color_black { color: black }" ++
".color_blue { color: blue }" ++ ".color_blue { color: blue }" ++
".color_green { color: green }" ++ ".color_green { color: green }" ++
".color_red { color: red }" ++ ".color_red { color: red }" ++
".color_orange { color: orange }" ++ ".color_orange { color: orange }" ++
".directive { color: darkmagenta }" ++ ".directive { color: darkmagenta }" ++
".expansion { display: none; }" ++ ".expansion { display: none; }" ++
".visited:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++ ".visited:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visited { color: darkmagenta; background-color:LemonChiffon; position: relative }" ++ ".visited { color: darkmagenta; background-color:LemonChiffon; position: relative }" ++
".visitedproof:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++ ".visitedproof:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visitedproof { color: darkmagenta; background-color:lightgreen; position: relative }" ++ ".visitedproof { color: darkmagenta; background-color:lightgreen; position: relative }" ++
".dangling:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++ ".dangling:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".dangling { color: gray; background-color:white; position: relative }" ++ ".dangling { color: gray; background-color:white; position: relative }" ++
".num { width:2.5em; padding-right:2ex; background-color:#eeeeee }" ++ ".num { width:2.5em; padding-right:2ex; background-color:#eeeeee }" ++
".num { text-align:right; font-size: smaller }" ++ ".num { text-align:right; font-size: smaller }" ++
".num { color:#444444 }" ++ ".num { color:#444444 }" ++
".line { padding-left: 1ex; border-left: 3px solid #ccc }" ++ ".line { padding-left: 1ex; border-left: 3px solid #ccc }" ++
".line { white-space: pre }" ++ ".line { white-space: pre }" ++
".msg { background-color:#fff8b4; color:#000000 }" ++ ".msg { background-color:#fff8b4; color:#000000 }" ++
".msg { -webkit-box-shadow:1px 1px 7px #000 }" ++ ".msg { -webkit-box-shadow:1px 1px 7px #000 }" ++
".msg { -webkit-border-radius:5px }" ++ ".msg { -webkit-border-radius:5px }" ++
".msg { font-family:Helvetica, sans-serif; font-size: smaller }" ++ ".msg { font-family:Helvetica, sans-serif; font-size: smaller }" ++
".msg { font-weight: bold }" ++ ".msg { font-weight: bold }" ++
".msg { float:left }" ++ ".msg { float:left }" ++
".msg { padding:0.5em 1ex 0.5em 1ex }" ++ ".msg { padding:0.5em 1ex 0.5em 1ex }" ++
".msg { margin-top:10px; margin-bottom:10px }" ++ ".msg { margin-top:10px; margin-bottom:10px }" ++
".msg { max-width:60em; word-wrap: break-word; white-space: pre-wrap;}" ++ ".msg { max-width:60em; word-wrap: break-word; white-space: pre-wrap;}" ++
".mrange { background-color:#dfddf3 }" ++ ".mrange { background-color:#dfddf3 }" ++
".mrange { border-bottom:1px solid #6F9DBE }" ++ ".mrange { border-bottom:1px solid #6F9DBE }" ++
".PathIndex { font-weight: bold }" ++ ".PathIndex { font-weight: bold }" ++
"table.simpletable {" ++ "table.simpletable {" ++
"padding: 5px;" ++ "padding: 5px;" ++
"font-size:12pt;" ++ "font-size:12pt;" ++
"margin:20px;" ++ "margin:20px;" ++
"border-collapse: collapse; border-spacing: 0px;" ++ "border-collapse: collapse; border-spacing: 0px;" ++
"}" ++ "}" ++
"td.rowname {" ++ "td.rowname {" ++
"text-align:right; font-weight:bold; color:#444444;" ++ "text-align:right; font-weight:bold; color:#444444;" ++
"padding-right:2ex; }" ++ "padding-right:2ex; }" ++
"</style>" ++ "</style>" ++
"</head>" ++ "</head>" ++
"<body" ^ ">" ++ "<body" ^ ">" ++
"" in "" in
F.fprintf fmt "%s" s; F.fprintf fmt "%s" s;
(fd, fmt) (fd, fmt)

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

@ -142,7 +142,7 @@ module BucketLevel = struct
end end
(** takes in input a tag to extract from the given error_desc (** takes in input a tag to extract from the given error_desc
and returns its value *) and returns its value *)
let error_desc_extract_tag_value (_, _, tags) tag_to_extract = let error_desc_extract_tag_value (_, _, tags) tag_to_extract =
let find_value tag v = let find_value tag v =
match v with match v with
@ -286,7 +286,7 @@ let deref_str_undef (proc_name, loc) =
value_pre = Some (pointer_or_object ()); value_pre = Some (pointer_or_object ());
value_post = None; value_post = None;
problem_str = "could be assigned by a call to skip function " ^ proc_name_str ^ problem_str = "could be assigned by a call to skip function " ^ proc_name_str ^
at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; } at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; }
(** dereference strings for a freed pointer dereference *) (** dereference strings for a freed pointer dereference *)
let deref_str_freed ra = let deref_str_freed ra =
@ -403,8 +403,8 @@ let dereference_string deref_str value_str access_opt loc =
let problem_str = let problem_str =
match Tags.get !tags Tags.nullable_src with match Tags.get !tags Tags.nullable_src with
| Some nullable_src -> | Some nullable_src ->
if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check" if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check"
else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check" else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check"
| None -> deref_str.problem_str in | None -> deref_str.problem_str in
[(problem_str ^ " " ^ at_line tags loc)] in [(problem_str ^ " " ^ at_line tags loc)] in
value_desc:: access_desc @ problem_desc, None, !tags value_desc:: access_desc @ problem_desc, None, !tags

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

@ -181,7 +181,7 @@ let stdout fmt_string =
do_print F.std_formatter fmt_string do_print F.std_formatter fmt_string
(** print a warning with information of the position in the ml source where it oririnated. (** print a warning with information of the position in the ml source where it oririnated.
use as: warning_position "description" (try assert false with Assert_failure x -> x); *) use as: warning_position "description" (try assert false with Assert_failure x -> x); *)
let warning_position (s: string) (mloc: ml_location) = let warning_position (s: string) (mloc: ml_location) =
err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc) err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc)

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

@ -66,7 +66,7 @@ let pp f pn =
type mangled_t = t type mangled_t = t
module MangledSet = Set.Make module MangledSet = Set.Make
(struct (struct
type t = mangled_t type t = mangled_t
let compare = compare let compare = compare
end) end)

168
infer/src/backend/match.ml
Unescape View File

@ -18,8 +18,8 @@ let mem_idlist i l =
list_exists (Ident.equal i) l list_exists (Ident.equal i) l
(** Type for a hpred pattern. flag=false means that the implication (** Type for a hpred pattern. flag=false means that the implication
between hpreds is not considered, and flag = true means that it is between hpreds is not considered, and flag = true means that it is
considered during pattern matching *) considered during pattern matching *)
type hpred_pat = { hpred : Sil.hpred; flag : bool } type hpred_pat = { hpred : Sil.hpred; flag : bool }
let pp_hpat pe f hpat = let pp_hpat pe f hpat =
@ -33,7 +33,7 @@ let rec pp_hpat_list pe f = function
F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats
(** Checks e1 = e2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. (** Checks e1 = e2[sub ++ sub'] for some sub' with dom(sub') subseteq vars.
Returns (sub ++ sub', vars - dom(sub')). *) Returns (sub ++ sub', vars - dom(sub')). *)
let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option = let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
let check_equal sub vars e1 e2 = let check_equal sub vars e1 e2 =
let e2_inst = Sil.exp_sub sub e2 let e2_inst = Sil.exp_sub sub e2
@ -63,8 +63,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None (* Naive *) None (* Naive *)
| Sil.BinOp(b1, e1', e1''), Sil.BinOp(b2, e2', e2'') when Sil.binop_equal b1 b2 -> | Sil.BinOp(b1, e1', e1''), Sil.BinOp(b2, e2', e2'') when Sil.binop_equal b1 b2 ->
(match exp_match e1' sub vars e2' with (match exp_match e1' sub vars e2' with
| None -> None | None -> None
| Some (sub', vars') -> exp_match e1'' sub' vars' e2'') | Some (sub', vars') -> exp_match e1'' sub' vars' e2'')
| Sil.BinOp _, _ | _, Sil.BinOp _ -> | Sil.BinOp _, _ | _, Sil.BinOp _ ->
None (* Naive *) None (* Naive *)
| Sil.Lvar _, _ | _, Sil.Lvar _ -> | Sil.Lvar _, _ | _, Sil.Lvar _ ->
@ -75,8 +75,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None None
| Sil.Lindex(base1, idx1), Sil.Lindex(base2, idx2) -> | Sil.Lindex(base1, idx1), Sil.Lindex(base2, idx2) ->
(match exp_match base1 sub vars base2 with (match exp_match base1 sub vars base2 with
| None -> None | None -> None
| Some (sub', vars') -> exp_match idx1 sub' vars' idx2) | Some (sub', vars') -> exp_match idx1 sub' vars' idx2)
let exp_list_match es1 sub vars es2 = let exp_list_match es1 sub vars es2 =
let f res_acc (e1, e2) = match res_acc with let f res_acc (e1, e2) = match res_acc with
@ -87,9 +87,9 @@ let exp_list_match es1 sub vars es2 =
in es_match_res in es_match_res
(** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with (** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')).
WARNING: This function does not consider the fact that the analyzer WARNING: This function does not consider the fact that the analyzer
sometimes forgets fields of hpred. It can possibly cause a problem. *) sometimes forgets fields of hpred. It can possibly cause a problem. *)
let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option = let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
match sexp1, sexp2 with match sexp1, sexp2 with
| Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) -> | Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) ->
@ -102,12 +102,12 @@ let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
None None
| Sil.Earray (size1, isel1, _), Sil.Earray (size2, isel2, _) -> | Sil.Earray (size1, isel1, _), Sil.Earray (size2, isel2, _) ->
(match exp_match size1 sub vars size2 with (match exp_match size1 sub vars size2 with
| Some (sub', vars') -> isel_match isel1 sub' vars' isel2 | Some (sub', vars') -> isel_match isel1 sub' vars' isel2
| None -> None) | None -> None)
(** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with (** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
and fsel_match fsel1 sub vars fsel2 = and fsel_match fsel1 sub vars fsel2 =
match fsel1, fsel2 with match fsel1, fsel2 with
| [], [] -> Some (sub, vars) | [], [] -> Some (sub, vars)
@ -124,11 +124,11 @@ and fsel_match fsel1 sub vars fsel2 =
end end
else if (n < 0 && !Config.abs_struct > 0) then else if (n < 0 && !Config.abs_struct > 0) then
fsel_match fsel1' sub vars fsel2 fsel_match fsel1' sub vars fsel2
(* This can lead to great information loss *) (* This can lead to great information loss *)
else None else None
(** Checks isel1 = isel2[sub ++ sub'] for some sub' with (** Checks isel1 = isel2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
and isel_match isel1 sub vars isel2 = and isel_match isel1 sub vars isel2 =
match isel1, isel2 with match isel1, isel2 with
| [], [] -> Some (sub, vars) | [], [] -> Some (sub, vars)
@ -203,8 +203,8 @@ let rec instantiate_to_emp p condition sub vars = function
instantiate_to_emp p condition sub_new vars_leftover hpats instantiate_to_emp p condition sub_new vars_leftover hpats
(* This function has to be changed in order to (* This function has to be changed in order to
* implement the idea "All lsegs outside are NE, and all lsegs inside * implement the idea "All lsegs outside are NE, and all lsegs inside
* are PE" *) * are PE" *)
let rec iter_match_with_impl iter condition sub vars hpat hpats = let rec iter_match_with_impl iter condition sub vars hpat hpats =
(* (*
@ -243,8 +243,8 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let gen_filter_pointsto lexp2 strexp2 te2 = function let gen_filter_pointsto lexp2 strexp2 te2 = function
| Sil.Hpointsto (lexp1, strexp1, te1) when Sil.exp_equal te1 te2 -> | Sil.Hpointsto (lexp1, strexp1, te1) when Sil.exp_equal te1 te2 ->
(match (exp_match lexp1 sub vars lexp2) with (match (exp_match lexp1 sub vars lexp2) with
| None -> None | None -> None
| Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2) | Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2)
| _ -> None | _ -> None
in in
let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function
@ -328,19 +328,19 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| Some _ -> None | Some _ -> None
in begin match ((Prop.prop_iter_find iter filter), hpats) with in begin match ((Prop.prop_iter_find iter filter), hpats) with
| (None, _) when not hpat.flag -> | (None, _) when not hpat.flag ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
None None
| (None, _) when Sil.lseg_kind_equal k2 Sil.Lseg_NE -> | (None, _) when Sil.lseg_kind_equal k2 Sil.Lseg_NE ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
do_para_lseg () do_para_lseg ()
| (None, _) -> | (None, _) ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
execute_with_backtracking [do_emp_lseg; do_para_lseg] execute_with_backtracking [do_emp_lseg; do_para_lseg]
| (Some iter_cur, []) -> | (Some iter_cur, []) ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
do_empty_hpats iter_cur () do_empty_hpats iter_cur ()
| (Some iter_cur, _) -> | (Some iter_cur, _) ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur]
end end
| Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) ->
@ -460,10 +460,10 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
(** [prop_match_with_impl p condition vars hpat hpats] (** [prop_match_with_impl p condition vars hpat hpats]
returns [(subst, p_leftover)] such that returns [(subst, p_leftover)] such that
1) [dom(subst) = vars] 1) [dom(subst) = vars]
2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover]. 2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover].
Using the flag [field], we can control the strength of |-. *) Using the flag [field], we can control the strength of |-. *)
let prop_match_with_impl p condition vars hpat hpats = let prop_match_with_impl p condition vars hpat hpats =
prop_match_with_impl_sub p condition Sil.sub_empty vars hpat hpats prop_match_with_impl_sub p condition Sil.sub_empty vars hpat hpats
@ -571,10 +571,10 @@ let hpara_dll_iso para1 para2 =
(** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo]. (** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo].
The function [update] is used to get rid of hpred pairs from [sigma_todo]. The function [update] is used to get rid of hpred pairs from [sigma_todo].
[sigma_corres] records the isormophic copies discovered so far. The first [sigma_corres] records the isormophic copies discovered so far. The first
parameter determines how much flexibility we will allow during this partial parameter determines how much flexibility we will allow during this partial
isomorphism finding. *) isomorphism finding. *)
let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo = let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo =
match todos with match todos with
| [] -> | [] ->
@ -599,10 +599,10 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
| None, _ | _, None -> | None, _ | _, None ->
None None
| Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2)) | Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2))
when not (Sil.exp_equal te1 te2) -> when not (Sil.exp_equal te1 te2) ->
None None
| Some (Sil.Hpointsto (_, se1, _) as hpred1), | Some (Sil.Hpointsto (_, se1, _) as hpred1),
Some (Sil.Hpointsto (_, se2, _) as hpred2) -> Some (Sil.Hpointsto (_, se2, _) as hpred2) ->
begin begin
match generate_todos_from_strexp mode [] se1 se2 with match generate_todos_from_strexp mode [] se1 se2 with
| None -> None | None -> None
@ -620,51 +620,51 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
end end
| Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1), | Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1),
Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) -> Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ->
if k1 <> k2 || not (hpara_iso para1 para2) then None if k1 <> k2 || not (hpara_iso para1 para2) then None
else else
(try (try
let new_corres = match corres_extend_front e1 e2 corres with let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false | None -> assert false
| Some new_corres -> new_corres in | Some new_corres -> new_corres in
let new_sigma_corres = let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in (new_sigma1, new_sigma2) in
let new_todos = let new_todos =
let shared12 = list_combine shared1 shared2 in let shared12 = list_combine shared1 shared2 in
(root1, root2) :: (next1, next2) :: shared12 @ todos' in (root1, root2) :: (next1, next2) :: shared12 @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None) with Invalid_argument _ -> None)
| Some (Sil.Hdllseg(k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1), | Some (Sil.Hdllseg(k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1),
Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) -> Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ->
if k1 <> k2 || not (hpara_dll_iso para1 para2) then None if k1 <> k2 || not (hpara_dll_iso para1 para2) then None
else else
(try (try
let new_corres = match corres_extend_front e1 e2 corres with let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false | None -> assert false
| Some new_corres -> new_corres in | Some new_corres -> new_corres in
let new_sigma_corres = let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in (new_sigma1, new_sigma2) in
let new_todos = let new_todos =
let shared12 = list_combine shared1 shared2 in let shared12 = list_combine shared1 shared2 in
(iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in (iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None) with Invalid_argument _ -> None)
| _ -> None | _ -> None
end end
| _ -> None | _ -> None
(** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. (** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma.
The function returns a partial iso and three sigmas. The first sigma is the first The function returns a partial iso and three sigmas. The first sigma is the first
copy of the two isomorphic sigmas, so it uses expressions in the domain of copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas, the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third is the unused and it uses expressions in the range of the isomorphism. The third is the unused
part of the input sigma. *) part of the input sigma. *)
let find_partial_iso eq corres todos sigma = let find_partial_iso eq corres todos sigma =
let update e1 e2 sigma0 = let update e1 e2 sigma0 =
let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in
@ -675,11 +675,11 @@ let find_partial_iso eq corres todos sigma =
generic_find_partial_iso Exact update corres init_sigma_corres todos init_sigma_todo generic_find_partial_iso Exact update corres init_sigma_corres todos init_sigma_todo
(** [find_partial_iso_from_two_sigmas] finds isomorphic sub-sigmas inside two (** [find_partial_iso_from_two_sigmas] finds isomorphic sub-sigmas inside two
given sigmas. The function returns a partial iso and four sigmas. The first given sigmas. The function returns a partial iso and four sigmas. The first
sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas, the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third and fourth and it uses expressions in the range of the isomorphism. The third and fourth
are the unused parts of the two input sigmas. *) are the unused parts of the two input sigmas. *)
let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 = let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 =
let update e1 e2 sigma_todo = let update e1 e2 sigma_todo =
let sigma_todo1, sigma_todo2 = sigma_todo in let sigma_todo1, sigma_todo2 = sigma_todo in
@ -703,12 +703,12 @@ let sigma_lift_to_pe sigma =
list_map hpred_lift_to_pe sigma list_map hpred_lift_to_pe sigma
(** [generic_para_create] takes a correspondence, and a sigma (** [generic_para_create] takes a correspondence, and a sigma
and a list of expressions for the first part of this and a list of expressions for the first part of this
correspondence. Then, it creates a renaming of expressions correspondence. Then, it creates a renaming of expressions
in the domain of the given correspondence, and applies this in the domain of the given correspondence, and applies this
renaming to the given sigma. The result is a tuple of the renaming, renaming to the given sigma. The result is a tuple of the renaming,
the renamed sigma, ids for existentially quantified expressions, the renamed sigma, ids for existentially quantified expressions,
ids for shared expressions, and shared expressions. *) ids for shared expressions, and shared expressions. *)
let generic_para_create corres sigma1 elist1 = let generic_para_create corres sigma1 elist1 =
let corres_ids = let corres_ids =
let not_same_consts = function let not_same_consts = function
@ -732,9 +732,9 @@ let generic_para_create corres sigma1 elist1 =
(renaming, body, ids_exists, ids_shared, es_shared) (renaming, body, ids_exists, ids_shared, es_shared)
(** [hpara_create] takes a correspondence, and a sigma, a root (** [hpara_create] takes a correspondence, and a sigma, a root
and a next for the first part of this correspondence. Then, it creates a and a next for the first part of this correspondence. Then, it creates a
hpara and discovers a list of shared expressions that are hpara and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *) passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_create corres sigma1 root1 next1 = let hpara_create corres sigma1 root1 next1 =
let renaming, body, ids_exists, ids_shared, es_shared = let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; next1] in generic_para_create corres sigma1 [root1; next1] in
@ -755,9 +755,9 @@ let hpara_create corres sigma1 root1 next1 =
(hpara, es_shared) (hpara, es_shared)
(** [hpara_dll_create] takes a correspondence, and a sigma, a root, (** [hpara_dll_create] takes a correspondence, and a sigma, a root,
a blink and a flink for the first part of this correspondence. Then, it creates a a blink and a flink for the first part of this correspondence. Then, it creates a
hpara_dll and discovers a list of shared expressions that are hpara_dll and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *) passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_dll_create corres sigma1 root1 blink1 flink1 = let hpara_dll_create corres sigma1 root1 blink1 flink1 =
let renaming, body, ids_exists, ids_shared, es_shared = let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; blink1; flink1] in generic_para_create corres sigma1 [root1; blink1; flink1] in

22
infer/src/backend/objc_models.ml
Unescape View File

@ -12,7 +12,7 @@
open Utils open Utils
(** This module models special c struct types from the Apple's Core Foundation libraries (** This module models special c struct types from the Apple's Core Foundation libraries
for which there are particular rules for memory management. *) for which there are particular rules for memory management. *)
module Core_foundation_model = module Core_foundation_model =
struct struct
@ -57,7 +57,7 @@ struct
"__CFTree"; "__CFTree";
"__CFURLEnumerator"; "__CFURLEnumerator";
"__CFUUID" "__CFUUID"
] ]
let cf_network = [ let cf_network = [
"_CFHTTPAuthentication"; "_CFHTTPAuthentication";
@ -67,7 +67,7 @@ struct
"__CFNetService"; "__CFNetService";
"__CFNetServiceMonitor"; "__CFNetServiceMonitor";
"__CFNetServiceBrowser" "__CFNetServiceBrowser"
] ]
let core_media = [ let core_media = [
"OpaqueCMBlockBuffer"; "OpaqueCMBlockBuffer";
@ -79,7 +79,7 @@ struct
"opaqueCMSimpleQueue"; "opaqueCMSimpleQueue";
"OpaqueCMClock"; "OpaqueCMClock";
"OpaqueCMTimebase" "OpaqueCMTimebase"
] ]
let core_text = [ let core_text = [
"__CTFont"; "__CTFont";
@ -95,21 +95,21 @@ struct
"__CTRunDelegate"; "__CTRunDelegate";
"__CTTextTab"; "__CTTextTab";
"__CTTypesetter" "__CTTypesetter"
] ]
let core_video = [ let core_video = [
"__CVBuffer"; "__CVBuffer";
"__CVMetalTextureCache"; "__CVMetalTextureCache";
"__CVOpenGLESTextureCache"; "__CVOpenGLESTextureCache";
"__CVPixelBufferPool" "__CVPixelBufferPool"
] ]
let image_io = [ let image_io = [
"CGImageDestination"; "CGImageDestination";
"CGImageMetadata"; "CGImageMetadata";
"CGImageMetadataTag"; "CGImageMetadataTag";
"CGImageSource" "CGImageSource"
] ]
let security = [ let security = [
"__SecCertificate"; "__SecCertificate";
@ -121,7 +121,7 @@ struct
"__SecCode"; "__SecCode";
"__SecTrust"; "__SecTrust";
"__SecRequirement" "__SecRequirement"
] ]
let system_configuration = [ let system_configuration = [
"__SCDynamicStore"; "__SCDynamicStore";
@ -133,7 +133,7 @@ struct
"__SCNetworkConnection"; "__SCNetworkConnection";
"__SCNetworkReachability"; "__SCNetworkReachability";
"__SCPreferences" "__SCPreferences"
] ]
let core_graphics_types = [ let core_graphics_types = [
"CGAffineTransform"; "CGAffineTransform";
@ -165,7 +165,7 @@ struct
"CGPDFStream"; "CGPDFStream";
"CGPDFString"; "CGPDFString";
"CGShading" "CGShading"
] ]
let core_foundation_types = let core_foundation_types =
core_foundation @ core_foundation @
@ -227,7 +227,7 @@ struct
let is_core_lib_create typ funct = let is_core_lib_create typ funct =
is_core_lib_type typ && is_core_lib_type typ &&
((string_contains create funct) || ((string_contains create funct) ||
(string_contains copy funct )) (string_contains copy funct ))
let function_arg_is_cftype typ = let function_arg_is_cftype typ =
(string_contains cf_type typ) (string_contains cf_type typ)

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

@ -17,7 +17,7 @@ type procedure_type =
let print_map procname_map = let print_map procname_map =
Procname.Hash.iter Procname.Hash.iter
(fun pname redefined -> (fun pname redefined ->
print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined))) print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined)))
procname_map procname_map
let process_all_cfgs process_function default_value = let process_all_cfgs process_function default_value =
@ -86,13 +86,13 @@ let update_cfgs generated_proc_map =
with Not_found -> assert false in with Not_found -> assert false in
if is_redefined then if is_redefined then
(Cfg.Procdesc.remove cfg pname true; (Cfg.Procdesc.remove cfg pname true;
Cg.node_set_defined cg pname false; Cg.node_set_defined cg pname false;
true) true)
else need_updating in else need_updating in
let need_updating = list_fold_right update_cfg_procdesc generated_procs false in let need_updating = list_fold_right update_cfg_procdesc generated_procs false in
if need_updating then if need_updating then
(Cfg.store_cfg_to_file cfg_name false cfg; (Cfg.store_cfg_to_file cfg_name false cfg;
Cg.store_to_file cg_name cg) in Cg.store_to_file cg_name cg) in
process_all_cfgs update_cfg () process_all_cfgs update_cfg ()
let do_objc_preanalysis () = let do_objc_preanalysis () =

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

@ -17,7 +17,7 @@ open Utils
(* =============== START of the Path module ===============*) (* =============== START of the Path module ===============*)
module Path : sig module Path : sig
(** type for paths *) (** type for paths *)
type t type t
type session = int type session = int
@ -58,8 +58,8 @@ module Path : sig
val iter_all_nodes_nocalls : (Cfg.node -> unit) -> t -> unit val iter_all_nodes_nocalls : (Cfg.node -> unit) -> t -> unit
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given. (** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the given position. Do not iterate past the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *) [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *)
val iter_longest_sequence : (int -> t -> int -> Mangled.t option -> unit) -> Sil.path_pos option -> t -> unit val iter_longest_sequence : (int -> t -> int -> Mangled.t option -> unit) -> Sil.path_pos option -> t -> unit
(** join two paths *) (** join two paths *)
@ -164,100 +164,100 @@ end = struct
else p else p
module Invariant = (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *) module Invariant = (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *)
struct struct
(** check whether a stats is the dummy stats *) (** check whether a stats is the dummy stats *)
let stats_is_dummy stats = let stats_is_dummy stats =
stats.max_length == - 1 stats.max_length == - 1
(** return the stats of the path *) (** return the stats of the path *)
(** assumes that the stats are computed *) (** assumes that the stats are computed *)
let get_stats = function let get_stats = function
| Pstart (_, stats) -> stats | Pstart (_, stats) -> stats
| Pnode (_, _, _, _, stats, _) -> stats | Pnode (_, _, _, _, stats, _) -> stats
| Pjoin (_, _, stats) -> stats | Pjoin (_, _, stats) -> stats
| Pcall (_, _, _, stats) -> stats | Pcall (_, _, _, stats) -> stats
(** restore the invariant that all the stats are dummy, so the path is ready for another traversal *) (** restore the invariant that all the stats are dummy, so the path is ready for another traversal *)
(** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *) (** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *)
let rec reset_stats = function let rec reset_stats = function
| Pstart (node, stats) -> | Pstart (node, stats) ->
if not (stats_is_dummy stats) then set_dummy_stats stats if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (node, exn_opt, session, path, stats, _) -> | Pnode (node, exn_opt, session, path, stats, _) ->
if not (stats_is_dummy stats) then if not (stats_is_dummy stats) then
begin begin
reset_stats path; reset_stats path;
set_dummy_stats stats set_dummy_stats stats
end end
| Pjoin (path1, path2, stats) -> | Pjoin (path1, path2, stats) ->
if not (stats_is_dummy stats) then if not (stats_is_dummy stats) then
begin begin
reset_stats path1; reset_stats path1;
reset_stats path2; reset_stats path2;
set_dummy_stats stats set_dummy_stats stats
end end
| Pcall (path1, pname, path2, stats) -> | Pcall (path1, pname, path2, stats) ->
if not (stats_is_dummy stats) then if not (stats_is_dummy stats) then
begin begin
reset_stats path1; reset_stats path1;
reset_stats path2; reset_stats path2;
set_dummy_stats stats set_dummy_stats stats
end end
(** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *) (** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *)
(** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats (** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats
is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node. is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node.
max_length is 0 if the path was visited but no node satisfying [f] was found. *) max_length is 0 if the path was visited but no node satisfying [f] was found. *)
(** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *) (** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *)
(** Since this breaks the invariant, it must be followed by reset_stats. *) (** Since this breaks the invariant, it must be followed by reset_stats. *)
let rec compute_stats do_calls (f : Cfg.Node.t -> bool) = let rec compute_stats do_calls (f : Cfg.Node.t -> bool) =
let nodes_found stats = stats.max_length > 0 in let nodes_found stats = stats.max_length > 0 in
function function
| Pstart (node, stats) -> | Pstart (node, stats) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
let found = f node in let found = f node in
stats.max_length <- if found then 1 else 0; stats.max_length <- if found then 1 else 0;
stats.linear_num <- 1.0; stats.linear_num <- 1.0;
end end
| Pnode (node, exn_opt, session, path, stats, _) -> | Pnode (node, exn_opt, session, path, stats, _) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
compute_stats do_calls f path; compute_stats do_calls f path;
let stats1 = get_stats path in let stats1 = get_stats path in
let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in
stats.max_length <- if found then 1 + stats1.max_length else 0; stats.max_length <- if found then 1 + stats1.max_length else 0;
stats.linear_num <- stats1.linear_num; stats.linear_num <- stats1.linear_num;
end end
| Pjoin (path1, path2, stats) -> | Pjoin (path1, path2, stats) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
compute_stats do_calls f path1; compute_stats do_calls f path1;
compute_stats do_calls f path2; compute_stats do_calls f path2;
let stats1, stats2 = get_stats path1, get_stats path2 in let stats1, stats2 = get_stats path1, get_stats path2 in
stats.max_length <- max stats1.max_length stats2.max_length; stats.max_length <- max stats1.max_length stats2.max_length;
stats.linear_num <- stats1.linear_num +. stats2.linear_num stats.linear_num <- stats1.linear_num +. stats2.linear_num
end end
| Pcall (path1, pname, path2, stats) -> | Pcall (path1, pname, path2, stats) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
let stats2 = match do_calls with let stats2 = match do_calls with
| true -> | true ->
compute_stats do_calls f path2; compute_stats do_calls f path2;
get_stats path2 get_stats path2
| false -> | false ->
{ max_length = 0; { max_length = 0;
linear_num = 0.0 } in linear_num = 0.0 } in
let stats1 = let stats1 =
let f' = let f' =
if nodes_found stats2 if nodes_found stats2
then fun _ -> true (* already found in call, no need to search before the call *) then fun _ -> true (* already found in call, no need to search before the call *)
else f in else f in
compute_stats do_calls f' path1; compute_stats do_calls f' path1;
get_stats path1 in get_stats path1 in
stats.max_length <- stats1.max_length + stats2.max_length; stats.max_length <- stats1.max_length + stats2.max_length;
stats.linear_num <- stats1.linear_num; stats.linear_num <- stats1.linear_num;
end end
end (* End of module Invariant *) end (* End of module Invariant *)
(** iterate over each node in the path, excluding calls, once *) (** iterate over each node in the path, excluding calls, once *)
let iter_all_nodes_nocalls f path = let iter_all_nodes_nocalls f path =
@ -279,7 +279,7 @@ end = struct
!found !found
(** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element. (** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element.
if a node is reached via an exception, pass the exception information to [f] on the previous node *) if a node is reached via an exception, pass the exception information to [f] on the previous node *)
let iter_longest_sequence_filter (f : int -> t -> int -> Mangled.t option -> unit) (filter: Cfg.Node.t -> bool) (path: t) : unit = let iter_longest_sequence_filter (f : int -> t -> int -> Mangled.t option -> unit) (filter: Cfg.Node.t -> bool) (path: t) : unit =
let rec doit level session path prev_exn_opt = match path with let rec doit level session path prev_exn_opt = match path with
| Pstart _ -> f level path session prev_exn_opt | Pstart _ -> f level path session prev_exn_opt
@ -298,8 +298,8 @@ end = struct
Invariant.reset_stats path Invariant.reset_stats path
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given. (** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the last occurrence of the given position. Do not iterate past the last occurrence of the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *) [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *)
let iter_longest_sequence (f : int -> t -> int -> Mangled.t option -> unit) (pos_opt : Sil.path_pos option) (path: t) : unit = let iter_longest_sequence (f : int -> t -> int -> Mangled.t option -> unit) (pos_opt : Sil.path_pos option) (path: t) : unit =
let filter node = match pos_opt with let filter node = match pos_opt with
| None -> true | None -> true
@ -338,7 +338,7 @@ end = struct
let n = NodeMap.find node !map in let n = NodeMap.find node !map in
map := NodeMap.add node (n + 1) !map map := NodeMap.add node (n + 1) !map
with Not_found -> with Not_found ->
map := NodeMap.add node 1 !map in map := NodeMap.add node 1 !map in
iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path; iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path;
let max_rep_node = ref (Cfg.Node.dummy ()) in let max_rep_node = ref (Cfg.Node.dummy ()) in
let max_rep_num = ref 0 in let max_rep_num = ref 0 in
@ -372,8 +372,8 @@ end = struct
let delayed = ref PathMap.empty in let delayed = ref PathMap.empty in
let add_path p = let add_path p =
try ignore (PathMap.find p !delayed) with Not_found -> try ignore (PathMap.find p !delayed) with Not_found ->
incr delayed_num; incr delayed_num;
delayed := PathMap.add p !delayed_num !delayed in delayed := PathMap.add p !delayed_num !delayed in
let path_seen p = (* path seen before *) let path_seen p = (* path seen before *)
PathMap.mem p !delayed in PathMap.mem p !delayed in
let rec add_delayed path = let rec add_delayed path =
@ -392,11 +392,11 @@ end = struct
let num = PathMap.find path !delayed in let num = PathMap.find path !delayed in
F.fprintf fmt "P%d" num F.fprintf fmt "P%d" num
with Not_found -> with Not_found ->
match path with match path with
| Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node | Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node
| Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node | Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node
| Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 | Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in | Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in
let print_delayed () = let print_delayed () =
if not (PathMap.is_empty !delayed) then begin if not (PathMap.is_empty !delayed) then begin
let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in
@ -474,7 +474,7 @@ end = struct
if n <> 0 then n else Sil.loc_compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in if n <> 0 then n else Sil.loc_compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in
let relevant lt = lt.Errlog.lt_node_tags <> [] in let relevant lt = lt.Errlog.lt_node_tags <> [] in
list_remove_irrelevant_duplicates compare relevant (list_rev !trace) list_remove_irrelevant_duplicates compare relevant (list_rev !trace)
(* list_remove_duplicates compare (list_sort compare !trace) *) (* list_remove_duplicates compare (list_sort compare !trace) *)
end end
(* =============== END of the Path module ===============*) (* =============== END of the Path module ===============*)
@ -610,7 +610,7 @@ end = struct
if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *) if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *)
then res := PropMap.remove p !res then res := PropMap.remove p !res
with Not_found -> with Not_found ->
res := PropMap.remove p !res in res := PropMap.remove p !res in
PropMap.iter rem ps2; PropMap.iter rem ps2;
!res !res

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

@ -30,7 +30,7 @@ module AllPreds = struct
let preds' = Cfg.NodeSet.add nfrom preds in let preds' = Cfg.NodeSet.add nfrom preds in
NodeHash.replace preds_table nto preds' NodeHash.replace preds_table nto preds'
with Not_found -> with Not_found ->
NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in
let do_node n = let do_node n =
list_iter (add_edge false n) (Cfg.Node.get_succs n); list_iter (add_edge false n) (Cfg.Node.get_succs n);
list_iter (add_edge true n) (Cfg.Node.get_exn n) in list_iter (add_edge true n) (Cfg.Node.get_exn n) in
@ -44,7 +44,7 @@ module AllPreds = struct
let preds = NodeHash.find preds_table n in let preds = NodeHash.find preds_table n in
Cfg.NodeSet.elements preds Cfg.NodeSet.elements preds
with Not_found -> with Not_found ->
Cfg.Node.get_preds n Cfg.Node.get_preds n
end end
module Vset = Set.Make (struct module Vset = Set.Make (struct
@ -69,21 +69,21 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc =
match exp with match exp with
| Sil.Var _ | Sil.Sizeof _ -> acc | Sil.Var _ | Sil.Sizeof _ -> acc
| Sil.Const (Sil.Ctuple((Sil.Const (Sil.Cfun pname)):: _)) -> | Sil.Const (Sil.Ctuple((Sil.Const (Sil.Cfun pname)):: _)) ->
(* for tuples representing the assignment of a block we take the block name *) (* for tuples representing the assignment of a block we take the block name *)
(* look for its procdesc and add its captured vars to the set of captured vars. *) (* look for its procdesc and add its captured vars to the set of captured vars. *)
let found_pd = ref None in let found_pd = ref None in
Cfg.iter_proc_desc cfg (fun pn pd -> if Procname.equal pn pname then found_pd:= Some pd); Cfg.iter_proc_desc cfg (fun pn pd -> if Procname.equal pn pname then found_pd:= Some pd);
let defining_proc = Cfg.Procdesc.get_proc_name pdesc in let defining_proc = Cfg.Procdesc.get_proc_name pdesc in
(match !found_pd with (match !found_pd with
| Some pd -> | Some pd ->
list_iter (fun (x, _) -> list_iter (fun (x, _) ->
captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var
) (Cfg.Procdesc.get_captured pd) ) (Cfg.Procdesc.get_captured pd)
| _ -> ()); | _ -> ());
acc acc
| Sil.Const _ -> acc | Sil.Const _ -> acc
| Sil.Lvar x -> | Sil.Lvar x ->
(* If x is a captured var in the current procdesc don't add it to acc *) (* If x is a captured var in the current procdesc don't add it to acc *)
if is_captured_pvar pdesc x then acc else Vset.add x acc if is_captured_pvar pdesc x then acc else Vset.add x acc
| Sil.Cast (_, e) | Sil.UnOp (_, e, _) | Sil.Lfield (e, _, _) -> use_exp cfg pdesc e acc | Sil.Cast (_, e) | Sil.UnOp (_, e, _) | Sil.Lfield (e, _, _) -> use_exp cfg pdesc e acc
| Sil.BinOp (_, e1, e2) | Sil.Lindex (e1, e2) -> use_exp cfg pdesc e1 (use_exp cfg pdesc e2 acc) | Sil.BinOp (_, e1, e2) | Sil.Lindex (e1, e2) -> use_exp cfg pdesc e1 (use_exp cfg pdesc e2 acc)
@ -193,7 +193,7 @@ end = struct
replace node newset; replace node newset;
if not (Vset.equal oldset newset) then Worklist.add node if not (Vset.equal oldset newset) then Worklist.add node
with Not_found -> with Not_found ->
replace node set; Worklist.add node in replace node set; Worklist.add node in
list_iter do_node preds list_iter do_node preds
let iter init f = let iter init f =
@ -298,7 +298,7 @@ let node_assigns_no_variables cfg node =
Vset.is_empty assign_set Vset.is_empty assign_set
(** Set the dead variables of a node, by default as dead_after. (** Set the dead variables of a node, by default as dead_after.
If the node is a prune or a join node, propagate as dead_before in the successors *) If the node is a prune or a join node, propagate as dead_before in the successors *)
let add_dead_pvars_after_conditionals_join cfg n dead_pvars = let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
(* L.out " node %d: %a@." (Cfg.Node.get_id n) (Sil.pp_pvar_list pe_text) dead_pvars; *) (* L.out " node %d: %a@." (Cfg.Node.get_id n) (Sil.pp_pvar_list pe_text) dead_pvars; *)
let seen = ref Cfg.NodeSet.empty in let seen = ref Cfg.NodeSet.empty in
@ -316,7 +316,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
| _ -> false in | _ -> false in
match Cfg.Node.get_kind node with match Cfg.Node.get_kind node with
| Cfg.Node.Prune_node _ | Cfg.Node.Join_node when node_assigns_no_variables cfg node && not (next_is_exit node) -> | Cfg.Node.Prune_node _ | Cfg.Node.Join_node when node_assigns_no_variables cfg node && not (next_is_exit node) ->
(* cannot push nullify instructions after an assignment, as they could nullify the same variable *) (* cannot push nullify instructions after an assignment, as they could nullify the same variable *)
let succs = Cfg.Node.get_succs node in let succs = Cfg.Node.get_succs node in
list_iter (add_after_prune_join false) succs list_iter (add_after_prune_join false) succs
| _ -> | _ ->
@ -329,7 +329,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
add_after_prune_join true n add_after_prune_join true n
(** Find the set of dead variables for the procedure pname and add nullify instructions. (** Find the set of dead variables for the procedure pname and add nullify instructions.
The variables that are possibly aliased are only considered just before the exit node. *) The variables that are possibly aliased are only considered just before the exit node. *)
let analyze_and_annotate_proc cfg tenv pname pdesc = let analyze_and_annotate_proc cfg tenv pname pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let exit_node_is_succ node = let exit_node_is_succ node =
@ -341,7 +341,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
captured_var:= Vset.empty; captured_var:= Vset.empty;
analyze_proc cfg tenv pdesc cand; (* as side effect it coputes the set aliased_var *) analyze_proc cfg tenv pdesc cand; (* as side effect it coputes the set aliased_var *)
(* print_aliased_var "@.@.Aliased variable computed: " !aliased_var; (* print_aliased_var "@.@.Aliased variable computed: " !aliased_var;
L.out " PROCEDURE %s@." (Procname.to_string pname); *) L.out " PROCEDURE %s@." (Procname.to_string pname); *)
let dead_pvars_added = ref 0 in let dead_pvars_added = ref 0 in
let dead_pvars_limit = 100000 in let dead_pvars_limit = 100000 in
let incr_dead_pvars_added pvars = let incr_dead_pvars_added pvars =
@ -350,26 +350,26 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
if !dead_pvars_added > dead_pvars_limit && !dead_pvars_added - num <= dead_pvars_limit if !dead_pvars_added > dead_pvars_limit && !dead_pvars_added - num <= dead_pvars_limit
then L.err "WARNING: liveness: more than %d dead pvars added in procedure %a, stopping@." dead_pvars_limit Procname.pp pname in then L.err "WARNING: liveness: more than %d dead pvars added in procedure %a, stopping@." dead_pvars_limit Procname.pp pname in
Table.iter cand (fun n live_at_predecessors live_current -> (* set dead variables on nodes *) Table.iter cand (fun n live_at_predecessors live_current -> (* set dead variables on nodes *)
let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *) let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *)
let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *) let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *)
(* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *) (* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *)
let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in
(* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars; (* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars;
print_aliased_var "@.Dead variable computed: " dead_pvars; print_aliased_var "@.Dead variable computed: " dead_pvars;
print_aliased_var "@.Captured variable computed: " !captured_var; print_aliased_var "@.Captured variable computed: " !captured_var;
print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *) print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *)
let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in
(* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *) (* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *)
let dead_pvars_to_add = let dead_pvars_to_add =
if exit_node_is_succ n (* add dead aliased vars just before the exit node *) if exit_node_is_succ n (* add dead aliased vars just before the exit node *)
then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var)) then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var))
else dead_pvars_no_alias in else dead_pvars_no_alias in
incr_dead_pvars_added dead_pvars_to_add; incr_dead_pvars_added dead_pvars_to_add;
if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add); if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add);
list_iter (fun n -> (* generate nullify instructions *) list_iter (fun n -> (* generate nullify instructions *)
let dead_pvs_after = Cfg.Node.get_dead_pvars n true in let dead_pvs_after = Cfg.Node.get_dead_pvars n true in
let dead_pvs_before = Cfg.Node.get_dead_pvars n false in let dead_pvs_before = Cfg.Node.get_dead_pvars n false in
node_add_nullify_instrs n dead_pvs_after dead_pvs_before) node_add_nullify_instrs n dead_pvs_after dead_pvs_before)
(Cfg.Procdesc.get_nodes pdesc); (Cfg.Procdesc.get_nodes pdesc);
Table.reset () Table.reset ()

84
infer/src/backend/printer.ml
Unescape View File

@ -57,16 +57,16 @@ end = struct
Hashtbl.replace log_files (node_fname, !DB.current_source) fd; Hashtbl.replace log_files (node_fname, !DB.current_source) fd;
if needs_initialization then if needs_initialization then
(F.fprintf fmt "<center><h1>Cfg Node %a</h1></center>" (Io_infer.Html.pp_line_link ~text: (Some (string_of_int nodeid)) [".."]) loc.Sil.line; (F.fprintf fmt "<center><h1>Cfg Node %a</h1></center>" (Io_infer.Html.pp_line_link ~text: (Some (string_of_int nodeid)) [".."]) loc.Sil.line;
F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line; F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line;
F.fprintf fmt "<br>PREDS:@\n"; F.fprintf fmt "<br>PREDS:@\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds; list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds;
F.fprintf fmt "<br>SUCCS: @\n"; F.fprintf fmt "<br>SUCCS: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs; list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs;
F.fprintf fmt "<br>EXN: @\n"; F.fprintf fmt "<br>EXN: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn; list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn;
F.fprintf fmt "<br>@\n"; F.fprintf fmt "<br>@\n";
F.pp_print_flush fmt (); F.pp_print_flush fmt ();
true true
) )
else false else false
@ -220,7 +220,7 @@ let force_delayed_prints () =
let _start_session node (loc: Sil.location) proc_name session = let _start_session node (loc: Sil.location) proc_name session =
let node_id = Cfg.Node.get_id node in let node_id = Cfg.Node.get_id node in
(if Log_nodes.start_node node_id loc proc_name (Cfg.Node.get_preds node) (Cfg.Node.get_succs node) (Cfg.Node.get_exn node) (if Log_nodes.start_node node_id loc proc_name (Cfg.Node.get_preds node) (Cfg.Node.get_succs node) (Cfg.Node.get_exn node)
then F.fprintf !html_formatter "%a@[<v>%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ()); then F.fprintf !html_formatter "%a@[<v>%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ());
F.fprintf !html_formatter "%a%a" Io_infer.Html.pp_hline () (Io_infer.Html.pp_session_link ~with_name: true [".."]) (node_id, session, loc.Sil.line); F.fprintf !html_formatter "%a%a" Io_infer.Html.pp_hline () (Io_infer.Html.pp_session_link ~with_name: true [".."]) (node_id, session, loc.Sil.line);
F.fprintf !html_formatter "<LISTING>%a" Io_infer.Html.pp_start_color Black F.fprintf !html_formatter "<LISTING>%a" Io_infer.Html.pp_start_color Black
@ -249,17 +249,17 @@ let _proc_write_log whole_seconds cfg pname =
linenum; linenum;
list_iter list_iter
(fun n -> Io_infer.Html.pp_node_link [] (fun n -> Io_infer.Html.pp_node_link []
(Cfg.Node.get_description (pe_html Black) n) (Cfg.Node.get_description (pe_html Black) n)
(list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n))
(is_visited n) false fmt (Cfg.Node.get_id n)) (is_visited n) false fmt (Cfg.Node.get_id n))
nodes; nodes;
(match Specs.get_summary pname with (match Specs.get_summary pname with
| None -> () | None -> ()
| Some summary -> | Some summary ->
Specs.pp_summary (pe_html Black) whole_seconds fmt summary; Specs.pp_summary (pe_html Black) whole_seconds fmt summary;
Io_infer.Html.close (fd, fmt)) Io_infer.Html.close (fd, fmt))
| None -> () | None -> ()
let proc_write_log whole_seconds cfg pname = let proc_write_log whole_seconds cfg pname =
@ -275,7 +275,7 @@ let create_errors_per_line err_log =
let set = Hashtbl.find err_per_line loc.Sil.line in let set = Hashtbl.find err_per_line loc.Sil.line in
Hashtbl.replace err_per_line loc.Sil.line (StringSet.add err_str set) Hashtbl.replace err_per_line loc.Sil.line (StringSet.add err_str set)
with Not_found -> with Not_found ->
Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in
Errlog.iter add_err err_log; Errlog.iter add_err err_log;
err_per_line err_per_line
@ -284,7 +284,7 @@ let create_err_message err_string =
"\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>" "\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>"
(** Module to read specific lines from files. (** Module to read specific lines from files.
The data from any file will stay in memory until the handle is collected by the gc *) The data from any file will stay in memory until the handle is collected by the gc *)
module LineReader : sig module LineReader : sig
type t type t
@ -322,18 +322,18 @@ end = struct
done; done;
assert false (* execution never reaches here *) assert false (* execution never reaches here *)
with End_of_file -> with End_of_file ->
(close_in cin; (close_in cin;
Array.of_list (list_rev !lines)) Array.of_list (list_rev !lines))
let file_data (hash: t) fname = let file_data (hash: t) fname =
try try
Some (Hashtbl.find hash fname) Some (Hashtbl.find hash fname)
with Not_found -> with Not_found ->
try try
let lines_arr = read_file (DB.source_file_to_string fname) in let lines_arr = read_file (DB.source_file_to_string fname) in
Hashtbl.add hash fname lines_arr; Hashtbl.add hash fname lines_arr;
Some lines_arr Some lines_arr
with exn when exn_not_timeout exn -> None with exn when exn_not_timeout exn -> None
let from_file_linenum_original hash fname linenum = let from_file_linenum_original hash fname linenum =
match file_data hash fname with match file_data hash fname with
@ -382,8 +382,8 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
let err_per_line = create_errors_per_line global_err_log in let err_per_line = create_errors_per_line global_err_log in
try try
(let s = "<center><h1>File " ^ (DB.source_file_to_string !DB.current_source) ^ "</h1></center>\n" ^ (let s = "<center><h1>File " ^ (DB.source_file_to_string !DB.current_source) ^ "</h1></center>\n" ^
"<table class=\"code\">\n" in "<table class=\"code\">\n" in
F.fprintf fmt "%s" s); F.fprintf fmt "%s" s);
let linenum = ref 0 in let linenum = ref 0 in
while true do while true do
incr linenum; incr linenum;
@ -404,22 +404,22 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
"<tr><td class=\"num\" id=\"" ^ line_str ^ "\">" ^ linenum_str ^ "</td><td class=\"line\">" ^ line_html in "<tr><td class=\"num\" id=\"" ^ line_str ^ "\">" ^ linenum_str ^ "</td><td class=\"line\">" ^ line_html in
F.fprintf fmt "%s" str; F.fprintf fmt "%s" str;
list_iter (fun n -> list_iter (fun n ->
let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in
Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum; Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum;
list_iter (fun n -> match Cfg.Node.get_kind n with list_iter (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Start_node proc_desc -> | Cfg.Node.Start_node proc_desc ->
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
let num_specs = list_length (Specs.get_specs proc_name) in let num_specs = list_length (Specs.get_specs proc_name) in
let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in
Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label
| _ -> ()) nodes_at_linenum; | _ -> ()) nodes_at_linenum;
list_iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum; list_iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum;
F.fprintf fmt "%s" "</td></tr>\n" F.fprintf fmt "%s" "</td></tr>\n"
done done
with End_of_file -> with End_of_file ->
(F.fprintf fmt "%s" "</table>\n"; (F.fprintf fmt "%s" "</table>\n";
Errlog.pp_html [fname_encoding] fmt global_err_log; Errlog.pp_html [fname_encoding] fmt global_err_log;
Io_infer.Html.close (fd, fmt)) Io_infer.Html.close (fd, fmt))
let c_files_write_html linereader exe_env = let c_files_write_html linereader exe_env =
let proc_is_active = Exe_env.proc_is_active exe_env in let proc_is_active = Exe_env.proc_is_active exe_env in

36
infer/src/backend/procname.ml
Unescape View File

@ -238,9 +238,9 @@ let java_is_static = function
let java_to_string ?withclass: (wc = false) j verbosity = let java_to_string ?withclass: (wc = false) j verbosity =
match verbosity with match verbosity with
| VERBOSE | NON_VERBOSE -> | VERBOSE | NON_VERBOSE ->
(* if verbose, then package.class.method(params): rtype, (* if verbose, then package.class.method(params): rtype,
else rtype package.class.method(params) else rtype package.class.method(params)
verbose is used for example to create unique filenames, non_verbose to create reports *) verbose is used for example to create unique filenames, non_verbose to create reports *)
let return_type = java_return_type_to_string j verbosity in let return_type = java_return_type_to_string j verbosity in
let params = java_param_list_to_string j.parameters verbosity in let params = java_param_list_to_string j.parameters verbosity in
let classname = java_type_to_string j.classname verbosity in let classname = java_type_to_string j.classname verbosity in
@ -279,16 +279,16 @@ let java_is_anonymous_inner_class = function
| _ -> false | _ -> false
(** Check if the last parameter is a hidden inner class, and remove it if present. (** Check if the last parameter is a hidden inner class, and remove it if present.
This is used in private constructors, where a proxy constructor is generated This is used in private constructors, where a proxy constructor is generated
with an extra parameter and calls the normal constructor. *) with an extra parameter and calls the normal constructor. *)
let java_remove_hidden_inner_class_parameter = function let java_remove_hidden_inner_class_parameter = function
| JAVA js -> | JAVA js ->
(match list_rev js.parameters with (match list_rev js.parameters with
| (so, s) :: par' -> | (so, s) :: par' ->
if is_anonymous_inner_class_name s if is_anonymous_inner_class_name s
then Some (JAVA { js with parameters = list_rev par'}) then Some (JAVA { js with parameters = list_rev par'})
else None else None
| [] -> None) | [] -> None)
| _ -> None | _ -> None
(** Check if the procedure name is an anonymous inner class constructor. *) (** Check if the procedure name is an anonymous inner class constructor. *)
@ -299,19 +299,19 @@ let java_is_anonymous_inner_class_constructor = function
| _ -> false | _ -> false
(** Check if the procedure name is an acess method (e.g. access$100 used to (** Check if the procedure name is an acess method (e.g. access$100 used to
access private members from a nested class. *) access private members from a nested class. *)
let java_is_access_method = function let java_is_access_method = function
| JAVA js -> | JAVA js ->
(match string_split_character js.methodname '$' with (match string_split_character js.methodname '$' with
| Some "access", s -> | Some "access", s ->
let is_int = let is_int =
try ignore (int_of_string s); true with Failure _ -> false in try ignore (int_of_string s); true with Failure _ -> false in
is_int is_int
| _ -> false) | _ -> false)
| _ -> false | _ -> false
(** Check if the proc name has the type of a java vararg. (** Check if the proc name has the type of a java vararg.
Note: currently only checks that the last argument has type Object[]. *) Note: currently only checks that the last argument has type Object[]. *)
let java_is_vararg = function let java_is_vararg = function
| JAVA js -> | JAVA js ->
begin begin
@ -342,7 +342,7 @@ let is_infer_undefined pn = match pn with
let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in
Str.string_match regexp (java_get_class pn) 0 Str.string_match regexp (java_get_class pn) 0
| _ -> | _ ->
(* TODO: add cases for obj-c, c, c++ *) (* TODO: add cases for obj-c, c, c++ *)
false false
(** to_string for C_FUNCTION and STATIC types *) (** to_string for C_FUNCTION and STATIC types *)

418
infer/src/backend/prop.ml
Unescape View File

@ -15,8 +15,8 @@ module F = Format
open Utils open Utils
(** type to describe different strategies for initializing fields of a structure. [No_init] does not (** type to describe different strategies for initializing fields of a structure. [No_init] does not
initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh
variables (C) or default values (Java). *) variables (C) or default values (Java). *)
type struct_init_mode = type struct_init_mode =
| No_init | No_init
| Fld_init | Fld_init
@ -31,12 +31,12 @@ type normal = Normal (** kind for normal props, i.e. normalized *)
type exposed = Exposed (** kind for exposed props *) type exposed = Exposed (** kind for exposed props *)
(** A proposition. The following invariants are mantained. [sub] is of (** A proposition. The following invariants are mantained. [sub] is of
the form id1 = e1 ... idn = en where: the id's are distinct and do not the form id1 = e1 ... idn = en where: the id's are distinct and do not
occur in the e's nor in [pi] or [sigma]; the id's are in sorted occur in the e's nor in [pi] or [sigma]; the id's are in sorted
order; the id's are not existentials; if idn = yn (for yn not order; the id's are not existentials; if idn = yn (for yn not
existential) then idn < yn in the order on ident's. [pi] is sorted existential) then idn < yn in the order on ident's. [pi] is sorted
and normalized, and does not contain x = e. [sigma] is sorted and and normalized, and does not contain x = e. [sigma] is sorted and
normalized. *) normalized. *)
type 'a t = type 'a t =
{ sigma: Sil.hpred list; { sigma: Sil.hpred list;
sub: Sil.subst; sub: Sil.subst;
@ -127,10 +127,10 @@ let pp_hpred_stackvar pe0 env f hpred =
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in | _ -> pe in
(match pe'.pe_kind with (match pe'.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se) F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> assert false (* should not happen *) | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> assert false (* should not happen *)
end; end;
Sil.color_post_wrapper changed pe0 f Sil.color_post_wrapper changed pe0 f
@ -173,7 +173,7 @@ let pp_sigma pe =
pp_semicolon_seq pe (Sil.pp_hpred pe) pp_semicolon_seq pe (Sil.pp_hpred pe)
(** Split sigma into stack and nonstack parts. (** Split sigma into stack and nonstack parts.
The boolean indicates whether the stack should only include local variales. *) The boolean indicates whether the stack should only include local variales. *)
let sigma_get_stack_nonstack only_local_vars sigma = let sigma_get_stack_nonstack only_local_vars sigma =
let hpred_is_stack_var = function let hpred_is_stack_var = function
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar
@ -188,8 +188,8 @@ let pp_sigma_simple pe env fmt sigma =
if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe env)) sg in if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe env)) sg in
let pp_nl fmt doit = if doit then let pp_nl fmt doit = if doit then
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n" | PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n"
| PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in | PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in
let pp_nonstack fmt = pp_semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in let pp_nonstack fmt = pp_semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in
if sigma_stack != [] || sigma_nonstack != [] then if sigma_stack != [] || sigma_nonstack != [] then
Format.fprintf fmt "%a%a%a" pp_stack sigma_stack pp_nl (sigma_stack != [] && sigma_nonstack != []) pp_nonstack sigma_nonstack Format.fprintf fmt "%a%a%a" pp_stack sigma_stack pp_nl (sigma_stack != [] && sigma_nonstack != []) pp_nonstack sigma_nonstack
@ -312,7 +312,7 @@ let pp_prop pe0 f prop =
else else
F.fprintf f "%a%a%a" pp_pure () (pp_sigma pe) prop.sigma (pp_footprint pe) prop in F.fprintf f "%a%a%a" pp_pure () (pp_sigma pe) prop.sigma (pp_footprint pe) prop in
if !Config.forcing_delayed_prints then (** print in html mode *) if !Config.forcing_delayed_prints then (** print in html mode *)
F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color () F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color ()
else else
do_print f () (** print in text mode *) do_print f () (** print in text mode *)
@ -590,20 +590,20 @@ let sym_eval abs e =
let e' = Sil.BinOp (Sil.PlusA, e1, e2) in let e' = Sil.BinOp (Sil.PlusA, e1, e2) in
eval (Sil.Lindex (ep, e')) eval (Sil.Lindex (ep, e'))
| Sil.BinOp (Sil.PlusPI, (Sil.BinOp (Sil.PlusPI, e11, e12)), e2) -> (* take care of pattern ((ptr + off1) + off2) *) | Sil.BinOp (Sil.PlusPI, (Sil.BinOp (Sil.PlusPI, e11, e12)), e2) -> (* take care of pattern ((ptr + off1) + off2) *)
(* progress: convert inner +I to +A *) (* progress: convert inner +I to +A *)
let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in
eval (Sil.BinOp (Sil.PlusPI, e11, e2')) eval (Sil.BinOp (Sil.PlusPI, e11, e2'))
| Sil.BinOp (Sil.PlusA, (Sil.Sizeof (Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) as e1), e2) -> (* pattern for extensible structs | Sil.BinOp (Sil.PlusA, (Sil.Sizeof (Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) as e1), e2) -> (* pattern for extensible structs
given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t)) given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t))
turn it into struct s { ... t arr[n + k] ... } *) turn it into struct s { ... t arr[n + k] ... } *)
let e1' = eval e1 in let e1' = eval e1 in
let e2' = eval e2 in let e2' = eval e2 in
(match list_rev ftal, e2' with (match list_rev ftal, e2' with
(fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp -> (fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp ->
let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in
let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in
Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st) Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st)
| _ -> Sil.BinOp(Sil.PlusA, e1', e2')) | _ -> Sil.BinOp(Sil.PlusA, e1', e2'))
| Sil.BinOp (Sil.PlusA as oplus, e1, e2) | Sil.BinOp (Sil.PlusA as oplus, e1, e2)
| Sil.BinOp (Sil.PlusPI as oplus, e1, e2) -> | Sil.BinOp (Sil.PlusPI as oplus, e1, e2) ->
let e1' = eval e1 in let e1' = eval e1 in
@ -638,7 +638,7 @@ let sym_eval abs e =
| Sil.Const (Sil.Cint n2), Sil.BinOp (Sil.MinusA, Sil.Const (Sil.Cint n1), e) -> | Sil.Const (Sil.Cint n2), Sil.BinOp (Sil.MinusA, Sil.Const (Sil.Cint n1), e) ->
Sil.exp_int (n1 ++ n2) --- e Sil.exp_int (n1 ++ n2) --- e
| Sil.BinOp (Sil.MinusA, e1, e2), e3 -> (* (e1-e2)+e3 --> e1 + (e3-e2) *) | Sil.BinOp (Sil.MinusA, e1, e2), e3 -> (* (e1-e2)+e3 --> e1 + (e3-e2) *)
(* progress: brings + to the outside *) (* progress: brings + to the outside *)
eval (e1 +++ (e3 --- e2)) eval (e1 +++ (e3 --- e2))
| _, Sil.Const _ -> | _, Sil.Const _ ->
e1' +++ e2' e1' +++ e2'
@ -732,7 +732,7 @@ let sym_eval abs e =
| Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) -> | Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) ->
Sil.exp_float (v /.w) Sil.exp_float (v /.w)
| Sil.Sizeof(Sil.Tarray(typ, size), _), Sil.Sizeof(_typ, _) (* pattern: sizeof(arr) / sizeof(arr[0]) = size of arr *) | Sil.Sizeof(Sil.Tarray(typ, size), _), Sil.Sizeof(_typ, _) (* pattern: sizeof(arr) / sizeof(arr[0]) = size of arr *)
when Sil.typ_equal _typ typ -> when Sil.typ_equal _typ typ ->
size size
| _ -> | _ ->
if abs then Sil.exp_get_undefined false else Sil.BinOp (Sil.Div, e1', e2') if abs then Sil.exp_get_undefined false else Sil.BinOp (Sil.Div, e1', e2')
@ -884,57 +884,57 @@ let atom_const_lt_exp = function
let mk_inequality e = let mk_inequality e =
match e with match e with
| Sil.BinOp (Sil.Le, base, Sil.Const (Sil.Cint n)) -> | Sil.BinOp (Sil.Le, base, Sil.Const (Sil.Cint n)) ->
(* base <= n case *) (* base <= n case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in let nbase = exp_normalize_noabs Sil.sub_empty base in
(match nbase with (match nbase with
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) -> | Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct -n-1 < new_base. *) (* In this case, base = -new_base. Construct -n-1 < new_base. *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one)) | _ -> Sil.Aeq (e, Sil.exp_one))
| Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n), base) -> | Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n), base) ->
(* n < base case *) (* n < base case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in let nbase = exp_normalize_noabs Sil.sub_empty base in
(match nbase with (match nbase with
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) -> | Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct new_base <= -n-1 *) (* In this case, base = -new_base. Construct new_base <= -n-1 *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in
Sil.Aeq (new_e, Sil.exp_one) Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one)) | _ -> Sil.Aeq (e, Sil.exp_one))
| _ -> Sil.Aeq (e, Sil.exp_one) | _ -> Sil.Aeq (e, Sil.exp_one)
(** Normalize an inequality *) (** Normalize an inequality *)
@ -962,9 +962,9 @@ let inequality_normalize a =
let rec combine pacc nacc = function let rec combine pacc nacc = function
| x:: ps, y:: ng -> | x:: ps, y:: ng ->
(match Sil.exp_compare x y with (match Sil.exp_compare x y with
| n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng) | n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng)
| 0 -> combine pacc nacc (ps, ng) | 0 -> combine pacc nacc (ps, ng)
| _ -> combine pacc (y:: nacc) (x :: ps, ng)) | _ -> combine pacc (y:: nacc) (x :: ps, ng))
| ps, ng -> (list_rev pacc) @ ps, (list_rev nacc) @ ng in | ps, ng -> (list_rev pacc) @ ps, (list_rev nacc) @ ng in
let pos'', neg'' = combine [] [] (pos', neg') in let pos'', neg'' = combine [] [] (pos', neg') in
(pos'', neg'', off) in (pos'', neg'', off) in
@ -997,8 +997,8 @@ let inequality_normalize a =
let exp_reorder e1 e2 = if Sil.exp_compare e1 e2 <= 0 then (e1, e2) else (e2, e1) let exp_reorder e1 e2 = if Sil.exp_compare e1 e2 <= 0 then (e1, e2) else (e2, e1)
(** Normalize an atom. (** Normalize an atom.
We keep the convention that inequalities with constants We keep the convention that inequalities with constants
are only of the form [e <= n] and [n < e]. *) are only of the form [e <= n] and [n < e]. *)
let atom_normalize sub a0 = let atom_normalize sub a0 =
let a = Sil.atom_sub sub a0 in let a = Sil.atom_sub sub a0 in
let rec normalize_eq eq = match eq with let rec normalize_eq eq = match eq with
@ -1072,7 +1072,7 @@ let rec strexp_normalize sub se =
| _ -> | _ ->
let fld_cnts' = let fld_cnts' =
list_map (fun (fld, cnt) -> list_map (fun (fld, cnt) ->
fld, strexp_normalize sub cnt) fld_cnts in fld, strexp_normalize sub cnt) fld_cnts in
let fld_cnts'' = list_sort Sil.fld_strexp_compare fld_cnts' in let fld_cnts'' = list_sort Sil.fld_strexp_compare fld_cnts' in
Sil.Estruct (fld_cnts'', inst) Sil.Estruct (fld_cnts'', inst)
end end
@ -1085,8 +1085,8 @@ let rec strexp_normalize sub se =
| _ -> | _ ->
let idx_cnts' = let idx_cnts' =
list_map (fun (idx, cnt) -> list_map (fun (idx, cnt) ->
let idx' = exp_normalize sub idx in let idx' = exp_normalize sub idx in
idx', strexp_normalize sub cnt) idx_cnts in idx', strexp_normalize sub cnt) idx_cnts in
let idx_cnts'' = let idx_cnts'' =
list_sort Sil.exp_strexp_compare idx_cnts' in list_sort Sil.exp_strexp_compare idx_cnts' in
Sil.Earray (size', idx_cnts'', inst) Sil.Earray (size', idx_cnts'', inst)
@ -1144,7 +1144,7 @@ let mk_ptsto lexp sexp te =
Sil.Hpointsto(lexp, nsexp, te) Sil.Hpointsto(lexp, nsexp, te)
(** Construct a points-to predicate for an expression using either the provided expression [name] as (** Construct a points-to predicate for an expression using either the provided expression [name] as
base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *) base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred = let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred =
let default_strexp () = match te with let default_strexp () = match te with
| Sil.Sizeof (typ, st) -> | Sil.Sizeof (typ, st) ->
@ -1177,12 +1177,12 @@ let rec hpred_normalize sub hpred =
let normalized_te = texp_normalize sub te in let normalized_te = texp_normalize sub te in
begin match normalized_cnt, normalized_te with begin match normalized_cnt, normalized_te with
| Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, st2) -> | Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, st2) ->
(* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) (* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *)
let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in
replace_hpred hpred' replace_hpred hpred'
| Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) | Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst), Sil.Sizeof (Sil.Tarray _, st2)
| Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) -> | Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) ->
(* check for an array whose size expression is n * (Sizeof type), and turn the array into a strexp of the given type *) (* check for an array whose size expression is n * (Sizeof type), and turn the array into a strexp of the given type *)
let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (Sil.Tarray(t, x), st1), None) inst in let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (Sil.Tarray(t, x), st1), None) inst in
replace_hpred (replace_array_contents hpred' esel) replace_hpred (replace_array_contents hpred' esel)
| _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te) | _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te)
@ -1269,12 +1269,12 @@ let pi_tighten_ineq pi =
(** remove duplicate atoms and redundant inequalities from a sorted pi *) (** remove duplicate atoms and redundant inequalities from a sorted pi *)
let rec pi_sorted_remove_redundant = function let rec pi_sorted_remove_redundant = function
| (Sil.Aeq(Sil.BinOp (Sil.Le, e1, Sil.Const (Sil.Cint n1)), Sil.Const (Sil.Cint i1)) as a1) :: | (Sil.Aeq(Sil.BinOp (Sil.Le, e1, Sil.Const (Sil.Cint n1)), Sil.Const (Sil.Cint i1)) as a1) ::
Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *) when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *)
pi_sorted_remove_redundant (a1 :: rest) pi_sorted_remove_redundant (a1 :: rest)
| Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint i1)) :: | Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint i1)) ::
(Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest (Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *) when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *)
pi_sorted_remove_redundant (a2 :: rest) pi_sorted_remove_redundant (a2 :: rest)
| a1:: a2:: rest -> | a1:: a2:: rest ->
if Sil.atom_equal a1 a2 then pi_sorted_remove_redundant (a2 :: rest) if Sil.atom_equal a1 a2 then pi_sorted_remove_redundant (a2 :: rest)
@ -1293,19 +1293,19 @@ let sigma_get_unsigned_exps sigma =
!uexps !uexps
(** Normalization of pi. (** Normalization of pi.
The normalization filters out obviously - true disequalities, such as e <> e + 1. *) The normalization filters out obviously - true disequalities, such as e <> e + 1. *)
let pi_normalize sub sigma pi0 = let pi_normalize sub sigma pi0 =
let pi = list_map (atom_normalize sub) pi0 in let pi = list_map (atom_normalize sub) pi0 in
let ineq_list, nonineq_list = pi_tighten_ineq pi in let ineq_list, nonineq_list = pi_tighten_ineq pi in
let syntactically_different = function let syntactically_different = function
| Sil.BinOp(op1, e1, Sil.Const(c1)), Sil.BinOp(op2, e2, Sil.Const(c2)) | Sil.BinOp(op1, e1, Sil.Const(c1)), Sil.BinOp(op2, e2, Sil.Const(c2))
when Sil.exp_equal e1 e2 -> when Sil.exp_equal e1 e2 ->
Sil.binop_equal op1 op2 && Sil.binop_injective op1 && not (Sil.const_equal c1 c2) Sil.binop_equal op1 op2 && Sil.binop_injective op1 && not (Sil.const_equal c1 c2)
| e1, Sil.BinOp(op2, e2, Sil.Const(c2)) | e1, Sil.BinOp(op2, e2, Sil.Const(c2))
when Sil.exp_equal e1 e2 -> when Sil.exp_equal e1 e2 ->
Sil.binop_injective op2 && Sil.binop_is_zero_runit op2 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c2) Sil.binop_injective op2 && Sil.binop_is_zero_runit op2 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c2)
| Sil.BinOp(op1, e1, Sil.Const(c1)), e2 | Sil.BinOp(op1, e1, Sil.Const(c1)), e2
when Sil.exp_equal e1 e2 -> when Sil.exp_equal e1 e2 ->
Sil.binop_injective op1 && Sil.binop_is_zero_runit op1 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c1) Sil.binop_injective op1 && Sil.binop_is_zero_runit op1 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c1)
| _ -> false in | _ -> false in
let filter_useful_atom = let filter_useful_atom =
@ -1347,13 +1347,13 @@ let footprint_normalize prop =
let npi', nsigma' = let npi', nsigma' =
if Sil.fav_is_empty fp_vars then npi, nsigma if Sil.fav_is_empty fp_vars then npi, nsigma
else (* replace primed vars by fresh footprint vars *) else (* replace primed vars by fresh footprint vars *)
let ids_primed = Sil.fav_to_list fp_vars in let ids_primed = Sil.fav_to_list fp_vars in
let ids_footprint = let ids_footprint =
list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in
let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in
let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in
let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in
(npi', nsigma') in (npi', nsigma') in
{ prop with foot_pi = npi'; foot_sigma = nsigma' } { prop with foot_pi = npi'; foot_sigma = nsigma' }
let exp_normalize_prop prop exp = let exp_normalize_prop prop exp =
@ -1366,14 +1366,14 @@ let lexp_normalize_prop p lexp =
let nroot = exp_normalize_prop p root in let nroot = exp_normalize_prop p root in
let noffsets = let noffsets =
list_map (fun n -> match n with list_map (fun n -> match n with
| Sil.Off_fld _ -> n | Sil.Off_fld _ -> n
| Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e) | Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e)
) offsets in ) offsets in
Sil.exp_add_offsets nroot noffsets Sil.exp_add_offsets nroot noffsets
(** Collapse consecutive indices that should be added. For instance, (** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *) to ensure the soundness of this collapsing. *)
let exp_collapse_consecutive_indices_prop p typ exp = let exp_collapse_consecutive_indices_prop p typ exp =
let typ_is_base = function let typ_is_base = function
| Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true | Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true
@ -1464,24 +1464,24 @@ let prop_replace_sub sub p =
let mk_neq e1 e2 = let mk_neq e1 e2 =
run_with_abs_val_eq_zero run_with_abs_val_eq_zero
(fun () -> (fun () ->
let ne1 = exp_normalize Sil.sub_empty e1 in let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2))) atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2)))
(** Sil.Construct an equality. *) (** Sil.Construct an equality. *)
let mk_eq e1 e2 = let mk_eq e1 e2 =
run_with_abs_val_eq_zero run_with_abs_val_eq_zero
(fun () -> (fun () ->
let ne1 = exp_normalize Sil.sub_empty e1 in let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2))) atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2)))
let unstructured_type = function let unstructured_type = function
| Sil.Tstruct _ | Sil.Tarray _ -> false | Sil.Tstruct _ | Sil.Tarray _ -> false
| _ -> true | _ -> true
(** Construct a points-to predicate for a single program variable. (** Construct a points-to predicate for a single program variable.
If [expand_structs] is true, initialize the fields of structs with fresh variables. *) If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
let mk_ptsto_lvar tenv expand_structs inst ((pvar: Sil.pvar), texp, expo) : Sil.hpred = let mk_ptsto_lvar tenv expand_structs inst ((pvar: Sil.pvar), texp, expo) : Sil.hpred =
mk_ptsto_exp tenv expand_structs (Sil.Lvar pvar, texp, expo) inst mk_ptsto_exp tenv expand_structs (Sil.Lvar pvar, texp, expo) inst
@ -1518,12 +1518,12 @@ let prop_sigma_star (p : 'a t) (sigma : Sil.hpred list) : exposed t =
{ p with sigma = sigma' } { p with sigma = sigma' }
(** Eliminates all empty lsegs from sigma, and collect equalities (** Eliminates all empty lsegs from sigma, and collect equalities
The empty lsegs include The empty lsegs include
(a) "lseg_pe para 0 e elist", (a) "lseg_pe para 0 e elist",
(b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0, (b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0,
(c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1, (c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1,
(d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains (d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains
cell iF or iB. *) cell iF or iB. *)
let sigma_remove_emptylseg sigma = let sigma_remove_emptylseg sigma =
let alloc_set = let alloc_set =
let rec f_alloc set = function let rec f_alloc set = function
@ -1543,13 +1543,13 @@ let sigma_remove_emptylseg sigma =
| Sil.Hpointsto _ as hpred :: sigma' -> | Sil.Hpointsto _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma' f eqs_zero (hpred :: sigma_passed) sigma'
| Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) :: sigma' | Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) :: sigma'
when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) -> when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) ->
f (Sil.Aeq(e1, e2) :: eqs_zero) sigma_passed sigma' f (Sil.Aeq(e1, e2) :: eqs_zero) sigma_passed sigma'
| Sil.Hlseg _ as hpred :: sigma' -> | Sil.Hlseg _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma' f eqs_zero (hpred :: sigma_passed) sigma'
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) :: sigma' | Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) :: sigma'
when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set) when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set)
|| (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) -> || (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) ->
f (Sil.Aeq(iF, oF):: Sil.Aeq(iB, oB):: eqs_zero) sigma_passed sigma' f (Sil.Aeq(iF, oF):: Sil.Aeq(iB, oB):: eqs_zero) sigma_passed sigma'
| Sil.Hdllseg _ as hpred :: sigma' -> | Sil.Hdllseg _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma' f eqs_zero (hpred :: sigma_passed) sigma'
@ -1563,16 +1563,16 @@ let sigma_intro_nonemptylseg e1 e2 sigma =
| Sil.Hpointsto _ as hpred :: sigma' -> | Sil.Hpointsto _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma' f (hpred :: sigma_passed) sigma'
| Sil.Hlseg (Sil.Lseg_PE, para, f1, f2, shared) :: sigma' | Sil.Hlseg (Sil.Lseg_PE, para, f1, f2, shared) :: sigma'
when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2) when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2)
|| (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) -> || (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) ->
f (Sil.Hlseg (Sil.Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' f (Sil.Hlseg (Sil.Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma'
| Sil.Hlseg _ as hpred :: sigma' -> | Sil.Hlseg _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma' f (hpred :: sigma_passed) sigma'
| Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma' | Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma'
when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF) when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF)
|| (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF) || (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF)
|| (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB) || (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB)
|| (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) -> || (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) ->
f (Sil.Hdllseg (Sil.Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' f (Sil.Hdllseg (Sil.Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma'
| Sil.Hdllseg _ as hpred :: sigma' -> | Sil.Hdllseg _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma' f (hpred :: sigma_passed) sigma'
@ -1708,10 +1708,10 @@ let attributes_in_same_category attr1 attr2 =
let get_attribute prop exp category = let get_attribute prop exp category =
let atts = get_exp_attributes prop exp in let atts = get_exp_attributes prop exp in
try Some (list_find try Some (list_find
(fun att -> (fun att ->
Sil.attribute_category_equal Sil.attribute_category_equal
(Sil.attribute_to_category att) category) (Sil.attribute_to_category att) category)
atts) atts)
with Not_found -> None with Not_found -> None
let get_resource_undef_attribute prop exp = let get_resource_undef_attribute prop exp =
@ -1875,12 +1875,12 @@ let find_arithmetic_problem proc_node_session prop exp =
walk exp; walk exp;
try Some (Div0 (list_find check_zero !exps_divided)), !res try Some (Div0 (list_find check_zero !exps_divided)), !res
with Not_found -> with Not_found ->
(match !uminus_unsigned with (match !uminus_unsigned with
| (e, t):: _ -> Some (UminusUnsigned (e, t)), !res | (e, t):: _ -> Some (UminusUnsigned (e, t)), !res
| _ -> None, !res) | _ -> None, !res)
(** Deallocate the stack variables in [pvars], and replace them by normal variables. (** Deallocate the stack variables in [pvars], and replace them by normal variables.
Return the list of stack variables whose address was still present after deallocation. *) Return the list of stack variables whose address was still present after deallocation. *)
let deallocate_stack_vars p pvars = let deallocate_stack_vars p pvars =
let filter = function let filter = function
| Sil.Hpointsto (Sil.Lvar v, _, _) -> | Sil.Hpointsto (Sil.Lvar v, _, _) ->
@ -1890,11 +1890,11 @@ let deallocate_stack_vars p pvars =
let fresh_address_vars = ref [] in (* fresh vars substituted for the address of stack vars *) let fresh_address_vars = ref [] in (* fresh vars substituted for the address of stack vars *)
let stack_vars_address_in_post = ref [] in (* stack vars whose address is still present *) let stack_vars_address_in_post = ref [] in (* stack vars whose address is still present *)
let exp_replace = list_map (function let exp_replace = list_map (function
| Sil.Hpointsto (Sil.Lvar v, _, _) -> | Sil.Hpointsto (Sil.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars; fresh_address_vars := (v, freshv) :: !fresh_address_vars;
(Sil.Lvar v, Sil.Var freshv) (Sil.Lvar v, Sil.Var freshv)
| _ -> assert false) sigma_stack in | _ -> assert false) sigma_stack in
let pi1 = list_map (fun (id, e) -> Sil.Aeq (Sil.Var id, e)) (Sil.sub_to_list p.sub) in let pi1 = list_map (fun (id, e) -> Sil.Aeq (Sil.Var id, e)) (Sil.sub_to_list p.sub) in
let pi = list_map (Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in let pi = list_map (Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in
let p' = { p with sub = Sil.sub_empty; pi = []; sigma = sigma_replace_exp exp_replace sigma_other } in let p' = { p with sub = Sil.sub_empty; pi = []; sigma = sigma_replace_exp exp_replace sigma_other } in
@ -1903,11 +1903,11 @@ let deallocate_stack_vars p pvars =
let p'_fav = prop_fav p' in let p'_fav = prop_fav p' in
let do_var (v, freshv) = let do_var (v, freshv) =
if Sil.fav_mem p'_fav freshv then (* the address of a de-allocated stack var in in the post *) if Sil.fav_mem p'_fav freshv then (* the address of a de-allocated stack var in in the post *)
begin begin
stack_vars_address_in_post := v :: !stack_vars_address_in_post; stack_vars_address_in_post := v :: !stack_vars_address_in_post;
let check_attribute_change att_old att_new = () in let check_attribute_change att_old att_new = () in
res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var) res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var)
end in end in
list_iter do_var !fresh_address_vars; list_iter do_var !fresh_address_vars;
!res in !res in
!stack_vars_address_in_post, list_fold_left prop_atom_and p'' pi !stack_vars_address_in_post, list_fold_left prop_atom_and p'' pi
@ -1916,8 +1916,8 @@ let deallocate_stack_vars p pvars =
(** {1 Functions for transforming footprints into propositions.} *) (** {1 Functions for transforming footprints into propositions.} *)
(** The ones used for abstraction add/remove local stacks in order to (** The ones used for abstraction add/remove local stacks in order to
stop the firing of some abstraction rules. The other usual stop the firing of some abstraction rules. The other usual
transforation functions do not use this hack. *) transforation functions do not use this hack. *)
(** Extract the footprint and return it as a prop *) (** Extract the footprint and return it as a prop *)
let extract_footprint p = let extract_footprint p =
@ -1986,7 +1986,7 @@ let sigma_dfs_sort sigma =
list_iter ExpStack.push (next:: shared); list_iter ExpStack.push (next:: shared);
(hpred:: visited, list_rev_append cur seen) (hpred:: visited, list_rev_append cur seen)
| Sil.Hdllseg (_, _, iF, oB, oF, iB, shared) | Sil.Hdllseg (_, _, iF, oB, oF, iB, shared)
when Sil.exp_equal e iF || Sil.exp_equal e iB -> when Sil.exp_equal e iF || Sil.exp_equal e iB ->
list_iter ExpStack.push (oB:: oF:: shared); list_iter ExpStack.push (oB:: oF:: shared);
(hpred:: visited, list_rev_append cur seen) (hpred:: visited, list_rev_append cur seen)
| _ -> | _ ->
@ -2095,7 +2095,7 @@ let prop_rename_array_indices prop =
let not_same_base_lt_offsets e1 e2 = let not_same_base_lt_offsets e1 e2 =
match e1, e2 with match e1, e2 with
| Sil.BinOp(Sil.PlusA, e1', Sil.Const (Sil.Cint n1')), | Sil.BinOp(Sil.PlusA, e1', Sil.Const (Sil.Cint n1')),
Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) -> Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) ->
not (Sil.exp_equal e1' e2' && Sil.Int.lt n1' n2') not (Sil.exp_equal e1' e2' && Sil.Int.lt n1' n2')
| _ -> true in | _ -> true in
let rec select_minimal_indices indices_seen = function let rec select_minimal_indices indices_seen = function
@ -2272,7 +2272,7 @@ let prop_rename_primed_footprint_vars p =
let sub_for_normalize = Sil.sub_empty in let sub_for_normalize = Sil.sub_empty in
(* It is fine to use the empty substituion during normalization (* It is fine to use the empty substituion during normalization
because the renaming maintains that a substitution is normalized *) because the renaming maintains that a substitution is normalized *)
let nsub' = sub_normalize sub' in let nsub' = sub_normalize sub' in
let nsigma' = sigma_normalize sub_for_normalize sigma' in let nsigma' = sigma_normalize sub_for_normalize sigma' in
let npi' = pi_normalize sub_for_normalize nsigma' pi' in let npi' = pi_normalize sub_for_normalize nsigma' pi' in
@ -2318,7 +2318,7 @@ let prop_ren_sub (ren_sub: Sil.subst) (prop: normal t) : normal t =
normalize (prop_sub ren_sub prop) normalize (prop_sub ren_sub prop)
(** Existentially quantify the [ids] in [prop]. (** Existentially quantify the [ids] in [prop].
[ids] should not contain any primed variables. *) [ids] should not contain any primed variables. *)
let exist_quantify fav prop = let exist_quantify fav prop =
let ids = Sil.fav_to_list fav in let ids = Sil.fav_to_list fav in
if list_exists Ident.is_primed ids then assert false; (* sanity check *) if list_exists Ident.is_primed ids then assert false; (* sanity check *)
@ -2412,15 +2412,15 @@ type 'a prop_iter =
let prop_iter_create prop = let prop_iter_create prop =
match prop.sigma with match prop.sigma with
| hpred:: sigma' -> Some | hpred:: sigma' -> Some
{ pit_sub = prop.sub; { pit_sub = prop.sub;
pit_pi = prop.pi; pit_pi = prop.pi;
pit_newpi = []; pit_newpi = [];
pit_old = []; pit_old = [];
pit_curr = hpred; pit_curr = hpred;
pit_state = (); pit_state = ();
pit_new = sigma'; pit_new = sigma';
pit_foot_pi = prop.foot_pi; pit_foot_pi = prop.foot_pi;
pit_foot_sigma = prop.foot_sigma } pit_foot_sigma = prop.foot_sigma }
| _ -> None | _ -> None
(** Return the prop associated to the iterator. *) (** Return the prop associated to the iterator. *)
@ -2434,13 +2434,13 @@ let prop_iter_to_prop iter =
prop iter.pit_newpi prop iter.pit_newpi
(** Add an atom to the pi part of prop iter. The (** Add an atom to the pi part of prop iter. The
first parameter records whether it is done first parameter records whether it is done
during footprint or during re - execution. *) during footprint or during re - execution. *)
let prop_iter_add_atom footprint iter atom = let prop_iter_add_atom footprint iter atom =
{ iter with pit_newpi = (footprint, atom):: iter.pit_newpi } { iter with pit_newpi = (footprint, atom):: iter.pit_newpi }
(** Remove the current element of the iterator, and return the prop (** Remove the current element of the iterator, and return the prop
associated to the resulting iterator *) associated to the resulting iterator *)
let prop_iter_remove_curr_then_to_prop iter = let prop_iter_remove_curr_then_to_prop iter =
let sigma = list_rev_append iter.pit_old iter.pit_new in let sigma = list_rev_append iter.pit_old iter.pit_new in
let normalized_sigma = sigma_normalize iter.pit_sub sigma in let normalized_sigma = sigma_normalize iter.pit_sub sigma in
@ -2477,21 +2477,21 @@ let prop_iter_next iter =
match iter.pit_new with match iter.pit_new with
| [] -> None | [] -> None
| hpred':: new' -> Some | hpred':: new' -> Some
{ iter with { iter with
pit_old = iter.pit_curr:: iter.pit_old; pit_old = iter.pit_curr:: iter.pit_old;
pit_curr = hpred'; pit_curr = hpred';
pit_state = (); pit_state = ();
pit_new = new'} pit_new = new'}
let prop_iter_remove_curr_then_next iter = let prop_iter_remove_curr_then_next iter =
match iter.pit_new with match iter.pit_new with
| [] -> None | [] -> None
| hpred':: new' -> Some | hpred':: new' -> Some
{ iter with { iter with
pit_old = iter.pit_old; pit_old = iter.pit_old;
pit_curr = hpred'; pit_curr = hpred';
pit_state = (); pit_state = ();
pit_new = new'} pit_new = new'}
(** Insert before the current element of the iterator. *) (** Insert before the current element of the iterator. *)
let prop_iter_prev_then_insert iter hpred = let prop_iter_prev_then_insert iter hpred =
@ -2505,8 +2505,8 @@ let rec prop_iter_find iter filter =
| Some st -> Some { iter with pit_state = st } | Some st -> Some { iter with pit_state = st }
| None -> | None ->
(match prop_iter_next iter with (match prop_iter_next iter with
| None -> None | None -> None
| Some iter' -> prop_iter_find iter' filter) | Some iter' -> prop_iter_find iter' filter)
(** Set the state of the iterator *) (** Set the state of the iterator *)
let prop_iter_set_state iter state = let prop_iter_set_state iter state =
@ -2627,10 +2627,10 @@ let hpred_gc_fields (fav: Sil.fav) hpred = match hpred with
Sil.exp_fav_add fav e; Sil.exp_fav_add fav e;
Sil.exp_fav_add fav te; Sil.exp_fav_add fav te;
(match strexp_gc_fields fav se with (match strexp_gc_fields fav se with
| None -> hpred | None -> hpred
| Some se' -> | Some se' ->
if Sil.strexp_compare se se' = 0 then hpred if Sil.strexp_compare se se' = 0 then hpred
else Sil.Hpointsto (e, se', te)) else Sil.Hpointsto (e, se', te))
| Sil.Hlseg _ | Sil.Hdllseg _ -> | Sil.Hlseg _ | Sil.Hdllseg _ ->
hpred hpred
@ -2697,38 +2697,38 @@ let trans_land_lor op ((idl1, stml1), e1) ((idl2, stml2), e2) loc =
end end
(** Input of this mehtod is an exp in a prop. Output is a formal variable or path from a (** Input of this mehtod is an exp in a prop. Output is a formal variable or path from a
formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *) formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *)
let find_equal_formal_path e prop = let find_equal_formal_path e prop =
let rec find_in_sigma e seen_hpreds = let rec find_in_sigma e seen_hpreds =
list_fold_right ( list_fold_right (
fun hpred res -> fun hpred res ->
if list_mem Sil.hpred_equal hpred seen_hpreds then None if list_mem Sil.hpred_equal hpred seen_hpreds then None
else else
let seen_hpreds = hpred :: seen_hpreds in let seen_hpreds = hpred :: seen_hpreds in
match res with match res with
| Some _ -> res | Some _ -> res
| None -> | None ->
match hpred with match hpred with
| Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _) | Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _)
when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) -> when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) ->
Some (Sil.Lvar pvar1) Some (Sil.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) ->
list_fold_right (fun (field, strexp) res -> list_fold_right (fun (field, strexp) res ->
match res with match res with
| Some _ -> res | Some _ -> res
| None -> | None ->
match strexp with match strexp with
| Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e -> | Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e ->
(match find_in_sigma exp1 seen_hpreds with (match find_in_sigma exp1 seen_hpreds with
| Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid)) | Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid))
| None -> None) | None -> None)
| _ -> None) fields None | _ -> None) fields None
| _ -> None) (get_sigma prop) None in | _ -> None) (get_sigma prop) None in
match find_in_sigma e [] with match find_in_sigma e [] with
| Some res -> Some res | Some res -> Some res
| None -> match get_objc_null_attribute prop e with | None -> match get_objc_null_attribute prop e with
| Some (Sil.Aobjc_null exp) -> Some exp | Some (Sil.Aobjc_null exp) -> Some exp
| _ -> None | _ -> None
(** translate an if-then-else expression *) (** translate an if-then-else expression *)
let trans_if_then_else ((idl1, stml1), e1) ((idl2, stml2), e2) ((idl3, stml3), e3) loc = let trans_if_then_else ((idl1, stml1), e1) ((idl2, stml2), e2) ((idl3, stml3), e3) loc =
@ -2772,8 +2772,8 @@ end = struct
(** Approximate the size of the longest chain by counting the max (** Approximate the size of the longest chain by counting the max
number of |-> with the same type and whose lhs is primed or number of |-> with the same type and whose lhs is primed or
footprint *) footprint *)
let sigma_chain_size sigma = let sigma_chain_size sigma =
let tbl = ref Sil.ExpMap.empty in let tbl = ref Sil.ExpMap.empty in
let add t = let add t =
@ -2786,8 +2786,8 @@ end = struct
let process_hpred = function let process_hpred = function
| Sil.Hpointsto (e, _, te) -> | Sil.Hpointsto (e, _, te) ->
(match e with (match e with
| Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te | Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te
| _ -> ()) | _ -> ())
| Sil.Hlseg _ | Sil.Hdllseg _ -> () in | Sil.Hlseg _ | Sil.Hdllseg _ -> () in
list_iter process_hpred sigma; list_iter process_hpred sigma;
let size = ref 0 in let size = ref 0 in
@ -2795,15 +2795,15 @@ end = struct
!size !size
(** Compute a size value for the prop, which indicates its (** Compute a size value for the prop, which indicates its
complexity *) complexity *)
let prop_size p = let prop_size p =
let size_current = sigma_size p.sigma in let size_current = sigma_size p.sigma in
let size_footprint = sigma_size p.foot_sigma in let size_footprint = sigma_size p.foot_sigma in
max size_current size_footprint max size_current size_footprint
(** Approximate the size of the longest chain by counting the max (** Approximate the size of the longest chain by counting the max
number of |-> with the same type and whose lhs is primed or number of |-> with the same type and whose lhs is primed or
footprint *) footprint *)
let prop_chain_size p = let prop_chain_size p =
let fp_size = pi_size p.foot_pi + sigma_size p.foot_sigma in let fp_size = pi_size p.foot_pi + sigma_size p.foot_sigma in
pi_size p.pi + sigma_size p.sigma + fp_size pi_size p.pi + sigma_size p.sigma + fp_size

38
infer/src/backend/propgraph.ml
Unescape View File

@ -67,7 +67,7 @@ let get_subl footprint_part g =
if footprint_part then [] else Sil.sub_to_list (Prop.get_sub g) if footprint_part then [] else Sil.sub_to_list (Prop.get_sub g)
(** [edge_from_source g n footprint_part is_hpred] finds and edge with the given source [n] in prop [g]. (** [edge_from_source g n footprint_part is_hpred] finds and edge with the given source [n] in prop [g].
[footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *) [footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *)
let edge_from_source g n footprint_part is_hpred = let edge_from_source g n footprint_part is_hpred =
let edges = let edges =
if is_hpred if is_hpred
@ -78,7 +78,7 @@ let edge_from_source g n footprint_part is_hpred =
| edge:: _ -> Some edge | edge:: _ -> Some edge
(** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g]. (** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g].
[footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *) [footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *)
let get_succs g n footprint_part is_hpred = let get_succs g n footprint_part is_hpred =
match edge_from_source g n footprint_part is_hpred with match edge_from_source g n footprint_part is_hpred with
| None -> [] | None -> []
@ -98,13 +98,13 @@ let edge_equal e1 e2 = match e1, e2 with
| _ -> false | _ -> false
(** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e], (** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e],
searching the footprint part if [footprint_part] is true. *) searching the footprint part if [footprint_part] is true. *)
let contains_edge (footprint_part: bool) (g: t) (e: edge) = let contains_edge (footprint_part: bool) (g: t) (e: edge) =
try ignore (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true try ignore (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
with Not_found -> false with Not_found -> false
(** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges]; (** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges];
if [footprint_part] is true the edges are taken from the footprint part. *) if [footprint_part] is true the edges are taken from the footprint part. *)
let iter_edges footprint_part f g = let iter_edges footprint_part f g =
list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *) list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *)
@ -133,9 +133,9 @@ let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = mat
and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with
| ((f1, se1):: fsel1'), (((f2, se2) as x):: fsel2') -> | ((f1, se1):: fsel1'), (((f2, se2) as x):: fsel2') ->
(match Sil.fld_compare f1 f2 with (match Sil.fld_compare f1 f2 with
| n when n < 0 -> compute_fsel_diff fsel1' fsel2 | n when n < 0 -> compute_fsel_diff fsel1' fsel2
| 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2' | 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2'
| _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2') | _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2')
| _, [] -> [] | _, [] -> []
| [], x:: fsel2' -> | [], x:: fsel2' ->
(Obj.repr x) :: compute_fsel_diff [] fsel2' (Obj.repr x) :: compute_fsel_diff [] fsel2'
@ -143,9 +143,9 @@ and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with
and compute_esel_diff esel1 esel2 : Obj.t list = match esel1, esel2 with and compute_esel_diff esel1 esel2 : Obj.t list = match esel1, esel2 with
| ((e1, se1):: esel1'), (((e2, se2) as x):: esel2') -> | ((e1, se1):: esel1'), (((e2, se2) as x):: esel2') ->
(match Sil.exp_compare e1 e2 with (match Sil.exp_compare e1 e2 with
| n when n < 0 -> compute_esel_diff esel1' esel2 | n when n < 0 -> compute_esel_diff esel1' esel2
| 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2' | 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2'
| _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2') | _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2')
| _, [] -> [] | _, [] -> []
| [], x:: esel2' -> | [], x:: esel2' ->
(Obj.repr x) :: compute_esel_diff [] esel2' (Obj.repr x) :: compute_esel_diff [] esel2'
@ -192,13 +192,13 @@ let compute_diff default_color oldgraph newgraph : diff =
diff_cmap_foot = colormap_foot } diff_cmap_foot = colormap_foot }
(** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff, (** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff,
selecting the footprint colormap if [footprint_part] is true. *) selecting the footprint colormap if [footprint_part] is true. *)
let diff_get_colormap footprint_part diff = let diff_get_colormap footprint_part diff =
if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm
(** Print a list of propositions, prepending each one with the given string. (** Print a list of propositions, prepending each one with the given string.
If !Config.pring_using_diff is true, print the diff w.r.t. the given prop, If !Config.pring_using_diff is true, print the diff w.r.t. the given prop,
extracting its local stack vars if the boolean is true. *) extracting its local stack vars if the boolean is true. *)
let pp_proplist pe0 s (base_prop, extract_stack) f plist = let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let num = list_length plist in let num = list_length plist in
let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in
@ -218,16 +218,16 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let pe = update_pe_diff _x in let pe = update_pe_diff _x in
let x = add_base_stack _x in let x = add_base_stack _x in
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x
| PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x) | PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x)
| _x:: l -> | _x:: l ->
let pe = update_pe_diff _x in let pe = update_pe_diff _x in
let x = add_base_stack _x in let x = add_base_stack _x in
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l) | PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l)
in pp_seq_newline 1 f plist in pp_seq_newline 1 f plist
(** dump a propset *) (** dump a propset *)

6
infer/src/backend/propset.ml
Unescape View File

@ -25,7 +25,7 @@ module PropSet =
let compare = PropSet.compare let compare = PropSet.compare
(** Sets of propositions. (** Sets of propositions.
The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *) The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *)
type t = PropSet.t type t = PropSet.t
let add p pset = let add p pset =
@ -78,13 +78,13 @@ let map f pset =
from_proplist (list_map f (to_proplist pset)) from_proplist (list_map f (to_proplist pset))
(** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn] (** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn]
where [p1 ... pN] are the elements of pset, in increasing order. *) where [p1 ... pN] are the elements of pset, in increasing order. *)
let fold f a pset = let fold f a pset =
let l = to_proplist pset in let l = to_proplist pset in
list_fold_left f a l list_fold_left f a l
(** [iter f pset] computes (f p1;f p2;..;f pN) (** [iter f pset] computes (f p1;f p2;..;f pN)
where [p1 ... pN] are the elements of pset, in increasing order. *) where [p1 ... pN] are the elements of pset, in increasing order. *)
let iter = let iter =
PropSet.iter PropSet.iter

634
infer/src/backend/prover.ml
Unescape View File

@ -74,21 +74,21 @@ end = struct
let from_leq acc (e1, e2) = let from_leq acc (e1, e2) =
match e1, e2 with match e1, e2 with
| Sil.BinOp(Sil.MinusA, (Sil.Var id11 as e11), (Sil.Var id12 as e12)), Sil.Const (Sil.Cint n) | Sil.BinOp(Sil.MinusA, (Sil.Var id11 as e11), (Sil.Var id12 as e12)), Sil.Const (Sil.Cint n)
when not (Ident.equal id11 id12) -> when not (Ident.equal id11 id12) ->
(match Sil.Int.to_signed n with (match Sil.Int.to_signed n with
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *) | None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' -> | Some n' ->
(e11, e12, n') :: acc) (e11, e12, n') :: acc)
| _ -> acc | _ -> acc
let from_lt acc (e1, e2) = let from_lt acc (e1, e2) =
match e1, e2 with match e1, e2 with
| Sil.Const (Sil.Cint n), Sil.BinOp(Sil.MinusA, (Sil.Var id21 as e21), (Sil.Var id22 as e22)) | Sil.Const (Sil.Cint n), Sil.BinOp(Sil.MinusA, (Sil.Var id21 as e21), (Sil.Var id22 as e22))
when not (Ident.equal id21 id22) -> when not (Ident.equal id21 id22) ->
(match Sil.Int.to_signed n with (match Sil.Int.to_signed n with
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *) | None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' -> | Some n' ->
let m = Sil.Int.zero -- n' -- Sil.Int.one in let m = Sil.Int.zero -- n' -- Sil.Int.one in
(e22, e21, m) :: acc) (e22, e21, m) :: acc)
| _ -> acc | _ -> acc
let rec generate ((e1, e2, n) as constr) acc = function let rec generate ((e1, e2, n) as constr) acc = function
@ -191,7 +191,7 @@ let check_type_size_lt t1 t2 = match type_size_compare t1 t2 with
(** Reasoning about inequalities *) (** Reasoning about inequalities *)
module Inequalities : sig module Inequalities : sig
(** type for inequalities (and implied disequalities) *) (** type for inequalities (and implied disequalities) *)
type t type t
(** Extract inequalities and disequalities from [pi] *) (** Extract inequalities and disequalities from [pi] *)
@ -310,7 +310,7 @@ end = struct
let new_umap = umap_add umap e1 new_upper1 in let new_umap = umap_add umap e1 new_upper1 in
umap_improve_by_difference_constraints new_umap constrs_rest umap_improve_by_difference_constraints new_umap constrs_rest
with Not_found -> with Not_found ->
umap_improve_by_difference_constraints umap constrs_rest in umap_improve_by_difference_constraints umap constrs_rest in
let rec lmap_improve_by_difference_constraints lmap = function let rec lmap_improve_by_difference_constraints lmap = function
| [] -> lmap | [] -> lmap
| constr:: constrs_rest -> (* e2 - e1 > -n-1 *) | constr:: constrs_rest -> (* e2 - e1 > -n-1 *)
@ -321,7 +321,7 @@ end = struct
let new_lmap = lmap_add lmap e2 new_lower2 in let new_lmap = lmap_add lmap e2 new_lower2 in
lmap_improve_by_difference_constraints new_lmap constrs_rest lmap_improve_by_difference_constraints new_lmap constrs_rest
with Not_found -> with Not_found ->
lmap_improve_by_difference_constraints lmap constrs_rest in lmap_improve_by_difference_constraints lmap constrs_rest in
let leqs_res = let leqs_res =
let umap = umap_create_from_leqs Sil.ExpMap.empty leqs in let umap = umap_create_from_leqs Sil.ExpMap.empty leqs in
let umap' = umap_improve_by_difference_constraints umap diff_constraints2 in let umap' = umap_improve_by_difference_constraints umap diff_constraints2 in
@ -375,8 +375,8 @@ end = struct
| Sil.Earray (size, isel, _) -> | Sil.Earray (size, isel, _) ->
add_lt_minus1_e size; add_lt_minus1_e size;
list_iter (fun (idx, se) -> list_iter (fun (idx, se) ->
add_lt_minus1_e idx; add_lt_minus1_e idx;
strexp_extract se) isel in strexp_extract se) isel in
let hpred_extract = function let hpred_extract = function
| Sil.Hpointsto(_, se, texp) -> | Sil.Hpointsto(_, se, texp) ->
if texp_is_unsigned texp then strexp_lt_minus1 se; if texp_is_unsigned texp then strexp_lt_minus1 se;
@ -408,7 +408,7 @@ end = struct
match e1, e2 with match e1, e2 with
| Sil.Const (Sil.Cint n1), Sil.Const (Sil.Cint n2) -> Sil.Int.leq n1 n2 | Sil.Const (Sil.Cint n1), Sil.Const (Sil.Cint n2) -> Sil.Int.leq n1 n2
| Sil.BinOp (Sil.MinusA, Sil.Sizeof (t1, _), Sil.Sizeof (t2, _)), Sil.Const(Sil.Cint n2) | Sil.BinOp (Sil.MinusA, Sil.Sizeof (t1, _), Sil.Sizeof (t2, _)), Sil.Const(Sil.Cint n2)
when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *)
check_type_size_lt t1 t2 check_type_size_lt t1 t2
| e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n |- e <= n] *) | e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n |- e <= n] *)
list_exists (function list_exists (function
@ -533,9 +533,9 @@ let check_zero e =
check_equal Prop.prop_emp e Sil.exp_zero check_equal Prop.prop_emp e Sil.exp_zero
(** [is_root prop base_exp exp] checks whether [base_exp = (** [is_root prop base_exp exp] checks whether [base_exp =
exp.offlist] for some list of offsets [offlist]. If so, it returns exp.offlist] for some list of offsets [offlist]. If so, it returns
[Some(offlist)]. Otherwise, it returns [None]. Assumes that [Some(offlist)]. Otherwise, it returns [None]. Assumes that
[base_exp] points to the beginning of a structure, not the middle. [base_exp] points to the beginning of a structure, not the middle.
*) *)
let is_root prop base_exp exp = let is_root prop base_exp exp =
let rec f offlist_past e = match e with let rec f offlist_past e = match e with
@ -599,27 +599,27 @@ let check_disequal prop e1 e2 =
| [] -> None | [] -> None
| Sil.Hpointsto (base, _, _) as hpred :: sigma_rest -> | Sil.Hpointsto (base, _, _) as hpred :: sigma_rest ->
(match is_root prop base e with (match is_root prop base e with
| None -> | None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest in f sigma_irrelevant' e sigma_rest
| Some _ -> | Some _ ->
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')) in Some (true, sigma_irrelevant'))
| Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest -> | Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest ->
(match is_root prop e1 e with (match is_root prop e1 e with
| None -> | None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest in f sigma_irrelevant' e sigma_rest
| Some _ -> | Some _ ->
if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant') in Some (true, sigma_irrelevant')
else if (Sil.exp_equal e2 Sil.exp_zero) then else if (Sil.exp_equal e2 Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant') in Some (false, sigma_irrelevant')
else else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest') in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then if is_root prop iF e != None || is_root prop iB e != None then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
@ -629,19 +629,19 @@ let check_disequal prop e1 e2 =
in Some (false, sigma_irrelevant') in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest ->
(match is_root prop iF e with (match is_root prop iF e with
| None -> | None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest in f sigma_irrelevant' e sigma_rest
| Some _ -> | Some _ ->
if (check_pi_implies_disequal iF oF) then if (check_pi_implies_disequal iF oF) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant') in Some (true, sigma_irrelevant')
else if (Sil.exp_equal oF Sil.exp_zero) then else if (Sil.exp_equal oF Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant') in Some (false, sigma_irrelevant')
else else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] oF sigma_rest') in in f [] oF sigma_rest') in
let f_null_check sigma_irrelevant e sigma_rest = let f_null_check sigma_irrelevant e sigma_rest =
if not (Sil.exp_equal e Sil.exp_zero) then f sigma_irrelevant e sigma_rest if not (Sil.exp_equal e Sil.exp_zero) then f sigma_irrelevant e sigma_rest
else else
@ -651,8 +651,8 @@ let check_disequal prop e1 e2 =
| None -> false | None -> false
| Some (e1_allocated, spatial_part_leftover) -> | Some (e1_allocated, spatial_part_leftover) ->
(match f_null_check [] n_e2 spatial_part_leftover with (match f_null_check [] n_e2 spatial_part_leftover with
| None -> false | None -> false
| Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in | Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in
let neq_pure_part () = let neq_pure_part () =
check_pi_implies_disequal n_e1 n_e2 in check_pi_implies_disequal n_e1 n_e2 in
check_disequal_const () || neq_pure_part () || neq_spatial_part () check_disequal_const () || neq_pure_part () || neq_spatial_part ()
@ -841,12 +841,12 @@ let check_inconsistency_base prop =
let inconsistent_atom = function let inconsistent_atom = function
| Sil.Aeq (e1, e2) -> | Sil.Aeq (e1, e2) ->
(match e1, e2 with (match e1, e2 with
| Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2) | Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2)
| _ -> check_disequal prop e1 e2) | _ -> check_disequal prop e1 e2)
| Sil.Aneq (e1, e2) -> | Sil.Aneq (e1, e2) ->
(match e1, e2 with (match e1, e2 with
| Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2 | Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2
| _ -> (Sil.exp_compare e1 e2 = 0)) in | _ -> (Sil.exp_compare e1 e2 = 0)) in
let inconsistent_inequalities () = let inconsistent_inequalities () =
let ineq = Inequalities.from_prop prop in let ineq = Inequalities.from_prop prop in
(* (*
@ -1097,8 +1097,8 @@ let extend_sub sub v e =
Sil.sub_join new_sub (Sil.sub_range_map (Sil.exp_sub new_sub) sub) Sil.sub_join new_sub (Sil.sub_range_map (Sil.exp_sub new_sub) sub)
(** Extend [sub1] and [sub2] to witnesses that each instance of (** Extend [sub1] and [sub2] to witnesses that each instance of
[e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not [e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not
possible. *) possible. *)
let exp_imply calc_missing subs e1_in e2_in : subst2 = let exp_imply calc_missing subs e1_in e2_in : subst2 =
let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in
let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in
@ -1128,7 +1128,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| e1, Sil.Var v2 -> | e1, Sil.Var v2 ->
let occurs_check v e = (* check whether [v] occurs in normalized [e] *) let occurs_check v e = (* check whether [v] occurs in normalized [e] *)
if Sil.fav_mem (Sil.exp_fav e) v if Sil.fav_mem (Sil.exp_fav e) v
&& Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v && Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v
then raise (IMPL_EXC ("occurs check", subs, (EXC_FALSE_EXPS (e1, e2)))) in then raise (IMPL_EXC ("occurs check", subs, (EXC_FALSE_EXPS (e1, e2)))) in
if Ident.is_primed v2 then if Ident.is_primed v2 then
let () = occurs_check v2 e1 in let () = occurs_check v2 e1 in
@ -1177,9 +1177,9 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
do_imply subs e1 e2 do_imply subs e1 e2
(** Convert a path (from lhs of a |-> to a field name present only in (** Convert a path (from lhs of a |-> to a field name present only in
the rhs) into an id. If the lhs was a footprint var, the id is a the rhs) into an id. If the lhs was a footprint var, the id is a
new footprint var. Othewise it is a var with the path in the name new footprint var. Othewise it is a var with the path in the name
and stamp - 1 *) and stamp - 1 *)
let path_to_id path = let path_to_id path =
let rec f = function let rec f = function
| Sil.Var id -> | Sil.Var id ->
@ -1187,12 +1187,12 @@ let path_to_id path =
else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id))) else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id)))
| Sil.Lfield (e, fld, t) -> | Sil.Lfield (e, fld, t) ->
(match f e with (match f e with
| None -> None | None -> None
| Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld))) | Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld)))
| Sil.Lindex (e, ind) -> | Sil.Lindex (e, ind) ->
(match f e with (match f e with
| None -> None | None -> None
| Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind))) | Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind)))
| Sil.Lvar pv -> | Sil.Lvar pv ->
Some (Sil.exp_to_string path) Some (Sil.exp_to_string path)
| Sil.Const (Sil.Cstr s) -> | Sil.Const (Sil.Cstr s) ->
@ -1216,15 +1216,15 @@ let array_size_imply calc_missing subs size1 size2 indices2 =
| _, Sil.BinOp (Sil.PlusA, _, Sil.Var _) | _, Sil.BinOp (Sil.PlusA, _, Sil.Var _)
| Sil.BinOp (Sil.Mult, _, _), _ -> | Sil.BinOp (Sil.Mult, _, _), _ ->
(try exp_imply calc_missing subs size1 size2 with (try exp_imply calc_missing subs size1 size2 with
| IMPL_EXC (s, subs', x) -> | IMPL_EXC (s, subs', x) ->
raise (IMPL_EXC ("array size:" ^ s, subs', x))) raise (IMPL_EXC ("array size:" ^ s, subs', x)))
| _ -> | _ ->
ProverState.add_bounds_check (ProverState.BCsize_imply (size1, size2, indices2)); ProverState.add_bounds_check (ProverState.BCsize_imply (size1, size2, indices2));
subs subs
(** Extend [sub1] and [sub2] to witnesses that each instance of (** Extend [sub1] and [sub2] to witnesses that each instance of
[se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not [se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not
possible. *) possible. *)
let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) = let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) =
(* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Sil.d_typ_full typ2; L.d_ln(); *) (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Sil.d_typ_full typ2; L.d_ln(); *)
match se1, se2 with match se1, se2 with
@ -1309,8 +1309,8 @@ and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fi
subs'', fld_frame, (f2, se2):: fld_missing subs'', fld_frame, (f2, se2):: fld_missing
and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2 and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
: subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list) : subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list)
= =
let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ2 in let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ2 in
match esel1, esel2 with match esel1, esel2 with
| _,[] -> subs, esel1, [] | _,[] -> subs, esel1, []
@ -1321,8 +1321,8 @@ and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
if n < 0 then array_imply source calc_index_frame calc_missing subs esel1' esel2 typ2 if n < 0 then array_imply source calc_index_frame calc_missing subs esel1' esel2 typ2
else if n > 0 then array_imply source calc_index_frame calc_missing subs esel1 esel2' typ2 else if n > 0 then array_imply source calc_index_frame calc_missing subs esel1 esel2' typ2
else (* n=0 *) else (* n=0 *)
let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in
array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2 array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2
| [], (e2, se2) :: esel2' -> | [], (e2, se2) :: esel2' ->
let subs' = sexp_imply_nolhs (Sil.Lindex (source, e2)) calc_missing subs se2 typ_elem in let subs' = sexp_imply_nolhs (Sil.Lindex (source, e2)) calc_missing subs se2 typ_elem in
let subs'', index_frame, index_missing = array_imply source calc_index_frame calc_missing subs' [] esel2' typ2 in let subs'', index_frame, index_missing = array_imply source calc_index_frame calc_missing subs' [] esel2' typ2 in
@ -1415,7 +1415,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with
let name_n = Ident.string_to_name "n" let name_n = Ident.string_to_name "n"
(** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off. (** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off.
Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *) Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *)
let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred = let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
let rec expand changed calc_index_frame hpred = match hpred with let rec expand changed calc_index_frame hpred = match hpred with
| Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) -> | Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) ->
@ -1509,7 +1509,7 @@ let rec case_analysis_type tenv (t1, st1) (t2, st2) =
| Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tarray _ -> | Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tarray _ ->
if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) && if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) &&
(st1 <> Sil.Subtype.exact) then (Some st1, None) (st1 <> Sil.Subtype.exact) then (Some st1, None)
else (None, Some st1) else (None, Some st1)
| _ -> if (check_subtype_basic_type t1 t2) then (Some st1, None) | _ -> if (check_subtype_basic_type t1 t2) then (Some st1, None)
@ -1565,27 +1565,27 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
not (texp_equal_modulo_subtype_flag texp1' texp1) not (texp_equal_modulo_subtype_flag texp1' texp1)
| None -> false in | None -> false in
if (calc_missing) then (* footprint *) if (calc_missing) then (* footprint *)
begin begin
match pos_type_opt with match pos_type_opt with
| None -> cast_exception tenv texp1 texp2 e1 subs | None -> cast_exception tenv texp1 texp2 e1 subs
| Some texp1' -> | Some texp1' ->
if has_changed then None, pos_type_opt (* missing *) if has_changed then None, pos_type_opt (* missing *)
else pos_type_opt, None (* frame *) else pos_type_opt, None (* frame *)
end end
else (* re-execution *) else (* re-execution *)
begin begin
match neg_type_opt with match neg_type_opt with
| Some _ -> cast_exception tenv texp1 texp2 e1 subs | Some _ -> cast_exception tenv texp1 texp2 e1 subs
| None -> | None ->
if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *) if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *)
else pos_type_opt, None (* frame *) else pos_type_opt, None (* frame *)
end end
end end
else else
None, None None, None
(** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type (** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type
only active in type_size mode *) only active in type_size mode *)
let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size -> | Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size ->
let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in
@ -1594,7 +1594,7 @@ let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| _ -> se1 | _ -> se1
(** handle parameter subtype for java: when the type of a callee variable in the caller is a strict subtype (** handle parameter subtype for java: when the type of a callee variable in the caller is a strict subtype
of the one in the callee, add a type frame and type missing *) of the one in the callee, add a type frame and type missing *)
let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) = let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) =
let is_callee = match e1 with let is_callee = match e1 with
| Sil.Lvar pv -> Sil.pvar_is_callee pv | Sil.Lvar pv -> Sil.pvar_is_callee pv
@ -1639,84 +1639,84 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> () | Sil.Lvar p -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> () in | _ -> () in
(match Prop.prop_iter_create prop1 with (match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 -> | Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with (match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with
| None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2))) | None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2)))
| Some iter1' -> | Some iter1' ->
(match Prop.prop_iter_current iter1' with (match Prop.prop_iter_current iter1' with
| Sil.Hpointsto (e1, se1, texp1), _ -> | Sil.Hpointsto (e1, se1, texp1), _ ->
(try (try
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in
let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in
let se1' = sexp_imply_preprocess se1 texp1 se2 in let se1' = sexp_imply_preprocess se1 texp1 se2 in
let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in
if calc_missing then if calc_missing then
begin begin
handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2); handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2);
(match fld_missing with (match fld_missing with
| Some fld_missing -> | Some fld_missing ->
ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1)) ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1))
| None -> ()); | None -> ());
(match fld_frame with (match fld_frame with
| Some fld_frame -> | Some fld_frame ->
ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1)) ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1))
| None -> ()); | None -> ());
(match typing_missing with (match typing_missing with
| Some t_missing -> | Some t_missing ->
ProverState.add_missing_typ (_e2, t_missing) ProverState.add_missing_typ (_e2, t_missing)
| None -> ()); | None -> ());
(match typing_frame with (match typing_frame with
| Some t_frame -> | Some t_frame ->
ProverState.add_frame_typ (e1, t_frame) ProverState.add_frame_typ (e1, t_frame)
| None -> ()) | None -> ())
end; end;
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1') in (subs', prop1')
with with
| IMPL_EXC (s, _, body) when calc_missing -> | IMPL_EXC (s, _, body) when calc_missing ->
raise (MISSING_EXC s)) raise (MISSING_EXC s))
| Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *) | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *) when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *) when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| _ -> assert false | _ -> assert false
) )
) )
) )
| Sil.Hlseg (k, para2, _e2, _f2, _elist2) -> (* for now ignore implications between PE and NE *) | Sil.Hlseg (k, para2, _e2, _f2, _elist2) -> (* for now ignore implications between PE and NE *)
let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in
@ -1724,58 +1724,58 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> () | Sil.Lvar p -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> () | _ -> ()
in in
if Sil.exp_equal e2 f2 && k == Sil.Lseg_PE then (subs, prop1) if Sil.exp_equal e2 f2 && k == Sil.Lseg_PE then (subs, prop1)
else else
(match Prop.prop_iter_create prop1 with (match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 -> | Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None -> | None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *) (* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| Some iter1' -> | Some iter1' ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *) let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in
let hpred1 = match Prop.prop_iter_current iter1' with let hpred1 = match Prop.prop_iter_current iter1' with
| hpred1, b -> | hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *) if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *)
hpred1 hpred1
in match hpred1 with in match hpred1 with
| Sil.Hlseg _ -> (subs', prop1') | Sil.Hlseg _ -> (subs', prop1')
| Sil.Hpointsto _ -> (* unroll rhs list and try again *) | Sil.Hpointsto _ -> (* unroll rhs list and try again *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in
let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> (fun () ->
try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2 try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
begin begin
(L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1"; (L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1";
let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in
sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3 sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3
end) in end) in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| Sil.Hdllseg _ -> assert false | Sil.Hdllseg _ -> assert false
) )
) )
| Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) ->
(d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| Sil.Hdllseg (k, para2, iF2, oB2, oF2, iB2, elist2) -> (* for now ignore implications between PE and NE *) | Sil.Hdllseg (k, para2, iF2, oB2, oF2, iB2, elist2) -> (* for now ignore implications between PE and NE *)
let iF2, oF2 = Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2 in let iF2, oF2 = Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2 in
let iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in let iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in
@ -1783,53 +1783,53 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> () | Sil.Lvar p -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> () | _ -> ()
in in
let _ = match oB2 with let _ = match oB2 with
| Sil.Lvar p -> () | Sil.Lvar p -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> () | _ -> ()
in in
(match Prop.prop_iter_create prop1 with (match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 -> | Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None -> | None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let _, para_inst2 = let _, para_inst2 =
if Sil.exp_equal iF2 iB2 then if Sil.exp_equal iF2 iB2 then
Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2
else assert false in (** Only base case of rhs list considered for now *) else assert false in (** Only base case of rhs list considered for now *)
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *) (* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
| Some iter1' -> (** Only consider implications between identical listsegs for now *) | Some iter1' -> (** Only consider implications between identical listsegs for now *)
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *) let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1') in (subs', prop1')
) )
) )
(** Check that [sigma1] implies [sigma2] and return two substitution (** Check that [sigma1] implies [sigma2] and return two substitution
instantiations for the primed variables of [sigma1] and [sigma2] instantiations for the primed variables of [sigma1] and [sigma2]
and a frame. Raise IMPL_FALSE if the implication cannot be and a frame. Raise IMPL_FALSE if the implication cannot be
proven. *) proven. *)
and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Prop.normal Prop.t) = and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Prop.normal Prop.t) =
let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *) let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *)
| Sil.Hpointsto (_e2, _, _) -> | Sil.Hpointsto (_e2, _, _) ->
let e2 = Sil.exp_sub (snd subs) _e2 in let e2 = Sil.exp_sub (snd subs) _e2 in
(match e2 with (match e2 with
| Sil.Const (Sil.Cstr s) -> Some (s, true) | Sil.Const (Sil.Cstr s) -> Some (s, true)
| Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false) | Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false)
| _ -> None) | _ -> None)
| _ -> None in | _ -> None in
let mk_constant_string_hpred s = (* create an hpred from a constant string *) let mk_constant_string_hpred s = (* create an hpred from a constant string *)
let size = Sil.exp_int (Sil.Int.of_int (1 + String.length s)) in let size = Sil.exp_int (Sil.Int.of_int (1 + String.length s)) in
@ -1869,60 +1869,60 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
Sil.Hpointsto (root, sexp, class_texp) in Sil.Hpointsto (root, sexp, class_texp) in
try try
(match move_primed_lhs_from_front subs sigma2 with (match move_primed_lhs_from_front subs sigma2 with
| [] -> | [] ->
L.d_strln "Final Implication"; L.d_strln "Final Implication";
d_impl subs (prop1, Prop.prop_emp); d_impl subs (prop1, Prop.prop_emp);
(subs, prop1) (subs, prop1)
| hpred2 :: sigma2' -> | hpred2 :: sigma2' ->
L.d_strln "Current Implication"; L.d_strln "Current Implication";
d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2'))); d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2')));
L.d_ln (); L.d_ln ();
L.d_ln (); L.d_ln ();
let normal_case hpred2' = let normal_case hpred2' =
let (subs', prop1') = let (subs', prop1') =
try try
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in (fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res res
with IMPL_EXC _ when calc_missing -> with IMPL_EXC _ when calc_missing ->
begin begin
match is_constant_string_class subs hpred2' with match is_constant_string_class subs hpred2' with
| Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *) | Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *)
let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in
let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in
let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in
(* ProverState.add_missing_sigma [hpred1']; *) (* ProverState.add_missing_sigma [hpred1']; *)
subs', frame_prop subs', frame_prop
| None -> | None ->
let subs' = match hpred2' with let subs' = match hpred2' with
| Sil.Hpointsto (e2, se2, te2) -> | Sil.Hpointsto (e2, se2, te2) ->
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in
sexp_imply_nolhs e2 calc_missing subs se2 typ2 sexp_imply_nolhs e2 calc_missing subs se2 typ2
| _ -> subs in | _ -> subs in
ProverState.add_missing_sigma [hpred2']; ProverState.add_missing_sigma [hpred2'];
subs', prop1 subs', prop1
end in end in
L.d_increase_indent 1; L.d_increase_indent 1;
let res = let res =
decrease_indent_when_exception decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in (fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in
L.d_decrease_indent 1; L.d_decrease_indent 1;
res in res in
(match hpred2 with (match hpred2 with
| Sil.Hpointsto(_e2, se2, t) -> | Sil.Hpointsto(_e2, se2, t) ->
let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in
if changed if changed
then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *) then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *)
else normal_case hpred2' else normal_case hpred2'
| _ -> normal_case hpred2) | _ -> normal_case hpred2)
) )
with IMPL_EXC (s, _, _) when calc_missing -> with IMPL_EXC (s, _, _) when calc_missing ->
L.d_strln ("Adding rhs as missing: " ^ s); L.d_strln ("Adding rhs as missing: " ^ s);
ProverState.add_missing_sigma sigma2; ProverState.add_missing_sigma sigma2;
subs, prop1 subs, prop1
let prepare_prop_for_implication (sub1, sub2) pi1 sigma1 = let prepare_prop_for_implication (sub1, sub2) pi1 sigma1 =
let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in
@ -1946,8 +1946,8 @@ let imply_atom calc_missing (sub1, sub2) prop a =
imply_pi calc_missing (sub1, sub2) prop [a] imply_pi calc_missing (sub1, sub2) prop [a]
(** Check pure implications before looking at the spatial part. Add (** Check pure implications before looking at the spatial part. Add
necessary instantiations for equalities and check that instantiations necessary instantiations for equalities and check that instantiations
are possible for disequalities. *) are possible for disequalities. *)
let rec pre_check_pure_implication calc_missing subs pi1 pi2 = let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
match pi2 with match pi2 with
| [] -> subs | [] -> subs
@ -1956,21 +1956,21 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
if Sil.exp_equal e2 f2 then pre_check_pure_implication calc_missing subs pi1 pi2' if Sil.exp_equal e2 f2 then pre_check_pure_implication calc_missing subs pi1 pi2'
else else
(match e2, f2 with (match e2, f2 with
| Sil.Var v2, f2 | Sil.Var v2, f2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* The commented-out condition should always hold. *) (* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 f2 in let sub2' = extend_sub (snd subs) v2 f2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, Sil.Var v2 | e2, Sil.Var v2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* The commented-out condition should always hold. *) (* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 e2 in let sub2' = extend_sub (snd subs) v2 e2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, f2 -> | e2, f2 ->
let pi1' = Prop.pi_sub (fst subs) pi1 in let pi1' = Prop.pi_sub (fst subs) pi1 in
let prop_for_impl = prepare_prop_for_implication subs pi1' [] in let prop_for_impl = prepare_prop_for_implication subs pi1' [] in
imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)); imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in));
pre_check_pure_implication calc_missing subs pi1 pi2' pre_check_pure_implication calc_missing subs pi1 pi2'
) )
| Sil.Aeq (e1, e2) :: pi2' -> (* must be an inequality *) | Sil.Aeq (e1, e2) :: pi2' -> (* must be an inequality *)
pre_check_pure_implication calc_missing subs pi1 pi2' pre_check_pure_implication calc_missing subs pi1 pi2'
@ -1983,8 +1983,8 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
else raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE)) else raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE))
(** Perform the array bound checks delayed (to instantiate variables) by the prover. (** Perform the array bound checks delayed (to instantiate variables) by the prover.
If there is a provable violation of the array bounds, set the prover status to Bounds_check If there is a provable violation of the array bounds, set the prover status to Bounds_check
and make the proof fail. *) and make the proof fail. *)
let check_array_bounds (sub1, sub2) prop = let check_array_bounds (sub1, sub2) prop =
let check_failed atom = let check_failed atom =
ProverState.checks := Bounds_check :: !ProverState.checks; ProverState.checks := Bounds_check :: !ProverState.checks;
@ -2008,7 +2008,7 @@ let check_array_bounds (sub1, sub2) prop =
list_iter check_bound (ProverState.get_bounds_checks ()) list_iter check_bound (ProverState.get_bounds_checks ())
(** [check_implication_base] returns true if [prop1|-prop2], (** [check_implication_base] returns true if [prop1|-prop2],
ignoring the footprint part of the props *) ignoring the footprint part of the props *)
let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 = let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 =
try try
ProverState.reset prop1 prop2; ProverState.reset prop1 prop2;
@ -2063,9 +2063,9 @@ type implication_result =
| ImplFail of check list | ImplFail of check list
(** [check_implication_for_footprint p1 p2] returns (** [check_implication_for_footprint p1 p2] returns
[Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)] [Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)]
where [sub] is a substitution which instantiates the where [sub] is a substitution which instantiates the
primed vars of [p1] and [p2], which are assumed to be disjoint. *) primed vars of [p1] and [p2], which are assumed to be disjoint. *)
let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) = let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) =
let check_frame_empty = false in let check_frame_empty = false in
let calc_missing = true in let calc_missing = true in

216
infer/src/backend/rearrange.ml
Unescape View File

@ -30,13 +30,13 @@ let rec list_rev_and_concat l1 l2 =
let pp_off fmt off = let pp_off fmt off =
list_iter (fun n -> match n with list_iter (fun n -> match n with
| Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f | Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f
| Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off | Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off
(** Check whether the index is out of bounds. (** Check whether the index is out of bounds.
If the size is - 1, no check is performed. If the size is - 1, no check is performed.
If the index is provably out of bound, a bound error is given. If the index is provably out of bound, a bound error is given.
If the size is a constant and the index is not provably in bound, a warning is given. If the size is a constant and the index is not provably in bound, a warning is given.
*) *)
let check_bad_index pname tenv p size index loc = let check_bad_index pname tenv p size index loc =
let size_is_constant = match size with let size_is_constant = match size with
@ -145,7 +145,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
| Sil.Tint _, [Sil.Off_index e] | Sil.Tfloat _, [Sil.Off_index e] | Sil.Tint _, [Sil.Off_index e] | Sil.Tfloat _, [Sil.Off_index e]
| Sil.Tvoid, [Sil.Off_index e] | Sil.Tvoid, [Sil.Off_index e]
| Sil.Tfun _, [Sil.Off_index e] | Sil.Tptr _, [Sil.Off_index e] -> | Sil.Tfun _, [Sil.Off_index e] | Sil.Tptr _, [Sil.Off_index e] ->
(* In this case, we lift t to the t array. *) (* In this case, we lift t to the t array. *)
let t' = match t with let t' = match t with
| Sil.Tptr(t', _) -> t' | Sil.Tptr(t', _) -> t'
| _ -> t in | _ -> t in
@ -177,10 +177,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
res res
(** Extend the strexp by populating the path indicated by [off]. (** Extend the strexp by populating the path indicated by [off].
This means that it will add missing flds and do the case - analysis This means that it will add missing flds and do the case - analysis
for array accesses. This does not catch the array - bounds errors. for array accesses. This does not catch the array - bounds errors.
If we want to implement the checks for array bounds errors, If we want to implement the checks for array bounds errors,
we need to change this function. *) we need to change this function. *)
let rec _strexp_extend_values let rec _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp pname tenv orig_prop footprint_part kind max_stamp
se typ (off : Sil.offset list) inst = se typ (off : Sil.offset list) inst =
@ -215,13 +215,13 @@ let rec _strexp_extend_values
(res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in (res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in
list_fold_left replace [] atoms_se_typ_list' list_fold_left replace [] atoms_se_typ_list'
with Not_found -> with Not_found ->
let atoms', se', res_typ' = let atoms', se', res_typ' =
create_struct_values create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in
let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in
[(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))] [(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))]
end end
| (Sil.Off_fld (f, _)):: off', _, _ -> | (Sil.Off_fld (f, _)):: off', _, _ ->
raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x))
@ -232,7 +232,7 @@ let rec _strexp_extend_values
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tfun _ | (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tfun _
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tptr _ | (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tptr _
| (Sil.Off_index _):: _, Sil.Estruct _, Sil.Tstruct _ -> | (Sil.Off_index _):: _, Sil.Estruct _, Sil.Tstruct _ ->
(* L.d_strln_color Orange "turn into an array"; *) (* L.d_strln_color Orange "turn into an array"; *)
let size = match se with let size = match se with
| Sil.Eexp (_, Sil.Ialloc) -> Sil.exp_one (* if allocated explicitly, we know size is 1 *) | Sil.Eexp (_, Sil.Ialloc) -> Sil.exp_one (* if allocated explicitly, we know size is 1 *)
| _ -> | _ ->
@ -259,11 +259,11 @@ let rec _strexp_extend_values
else raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in else raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
list_fold_left replace [] atoms_se_typ_list' list_fold_left replace [] atoms_se_typ_list'
with Not_found -> with Not_found ->
array_case_analysis_index pname tenv orig_prop array_case_analysis_index pname tenv orig_prop
footprint_part kind max_stamp footprint_part kind max_stamp
size esel size esel
size_for_typ' typ' size_for_typ' typ'
e off' inst_arr inst e off' inst_arr inst
end end
| _, _, _ -> | _, _, _ ->
raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x))
@ -273,7 +273,7 @@ and array_case_analysis_index pname tenv orig_prop
array_size array_cont array_size array_cont
typ_array_size typ_cont typ_array_size typ_cont
index off inst_arr inst index off inst_arr inst
= =
let check_sound t' = let check_sound t' =
if not (Sil.typ_equal typ_cont t' || array_cont == []) if not (Sil.typ_equal typ_cont t' || array_cont == [])
then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
@ -319,12 +319,12 @@ and array_case_analysis_index pname tenv orig_prop
pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in
let atoms_se_typ_list' = let atoms_se_typ_list' =
list_fold_left (fun acc' (atoms', se', typ') -> list_fold_left (fun acc' (atoms', se', typ') ->
check_sound typ'; check_sound typ';
let atoms_new = Sil.Aeq(index, i) :: atoms' in let atoms_new = Sil.Aeq(index, i) :: atoms' in
let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in
let array_new = Sil.Earray(array_size, isel_new, inst_arr) in let array_new = Sil.Earray(array_size, isel_new, inst_arr) in
let typ_new = Sil.Tarray(typ', typ_array_size) in let typ_new = Sil.Tarray(typ', typ_array_size) in
(atoms_new, array_new, typ_new):: acc' (atoms_new, array_new, typ_new):: acc'
) [] atoms_se_typ_list in ) [] atoms_se_typ_list in
let acc_new = atoms_se_typ_list' :: acc in let acc_new = atoms_se_typ_list' :: acc in
let isel_seen_rev_new = ise :: isel_seen_rev in let isel_seen_rev_new = ise :: isel_seen_rev in
@ -370,7 +370,7 @@ let strexp_extend_values
off', list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs off', list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs
else off, [] in else off, [] in
if !Config.trace_rearrange then (L.d_str "entering strexp_extend_values se: "; Sil.d_sexp se; L.d_str " typ: "; if !Config.trace_rearrange then (L.d_str "entering strexp_extend_values se: "; Sil.d_sexp se; L.d_str " typ: ";
Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE")); Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE"));
let atoms_se_typ_list = let atoms_se_typ_list =
_strexp_extend_values _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off' inst in pname tenv orig_prop footprint_part kind max_stamp se typ off' inst in
@ -397,7 +397,7 @@ let mk_ptsto_exp_footprint
if not (exp_has_only_footprint_ids root) if not (exp_has_only_footprint_ids root)
then begin then begin
(* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we (* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we
* will fix them during the re - execution phase *) * will fix them during the re - execution phase *)
if not (!Config.angelic_execution && !Config.footprint) then if not (!Config.angelic_execution && !Config.footprint) then
begin begin
if !Config.developer_mode then if !Config.developer_mode then
@ -407,7 +407,7 @@ let mk_ptsto_exp_footprint
Errdesc.explain_dereference deref_str orig_prop (State.get_loc ()) in Errdesc.explain_dereference deref_str orig_prop (State.get_loc ()) in
raise raise
(Exceptions.Dangling_pointer_dereference (Exceptions.Dangling_pointer_dereference
(None, err_desc, try assert false with Assert_failure x -> x)) (None, err_desc, try assert false with Assert_failure x -> x))
end end
end; end;
let off_foot, eqs = laundry_offset_for_footprint max_stamp off in let off_foot, eqs = laundry_offset_for_footprint max_stamp off in
@ -436,7 +436,7 @@ let mk_ptsto_exp_footprint
(ptsto, ptsto_foot, atoms @ atoms') (ptsto, ptsto_foot, atoms @ atoms')
(** Check if the path in exp exists already in the current ptsto predicate. (** Check if the path in exp exists already in the current ptsto predicate.
If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *)
let prop_iter_check_fields_ptsto_shallow iter lexp = let prop_iter_check_fields_ptsto_shallow iter lexp =
let offset = Sil.exp_get_offsets lexp in let offset = Sil.exp_get_offsets lexp in
let (e, se, t) = let (e, se, t) =
@ -447,12 +447,12 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
| [] -> None | [] -> None
| (Sil.Off_fld (fld, _)):: off' -> | (Sil.Off_fld (fld, _)):: off' ->
(match se with (match se with
| Sil.Estruct (fsel, _) -> | Sil.Estruct (fsel, _) ->
(try (try
let _, se' = list_find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in let _, se' = list_find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in
check_offset se' off' check_offset se' off'
with Not_found -> Some fld) with Not_found -> Some fld)
| _ -> Some fld) | _ -> Some fld)
| (Sil.Off_index e):: off' -> None in | (Sil.Off_index e):: off' -> None in
check_offset se offset check_offset se offset
@ -463,9 +463,9 @@ let fav_max_stamp fav =
max_stamp max_stamp
(** [prop_iter_extend_ptsto iter lexp] extends the current psto (** [prop_iter_extend_ptsto iter lexp] extends the current psto
predicate in [iter] with enough fields to follow the path in predicate in [iter] with enough fields to follow the path in
[lexp] -- field splitting model. It also materializes all [lexp] -- field splitting model. It also materializes all
indices accessed in lexp. *) indices accessed in lexp. *)
let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
if !Config.trace_rearrange then (L.d_str "entering prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ()); if !Config.trace_rearrange then (L.d_str "entering prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ());
let offset = Sil.exp_get_offsets lexp in let offset = Sil.exp_get_offsets lexp in
@ -515,29 +515,29 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
if Ident.kind_equal extend_kind Ident.kprimed if Ident.kind_equal extend_kind Ident.kprimed
then iter_list (* normal part already extended: nothing to do *) then iter_list (* normal part already extended: nothing to do *)
else (* extend footprint part *) else (* extend footprint part *)
let atoms_fp_sigma_list = let atoms_fp_sigma_list =
let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in
let sigma_pto, sigma_rest = let sigma_pto, sigma_rest =
list_partition (function list_partition (function
| Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e' | Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e'
| Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1 | Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1
| Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB | Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB
) footprint_sigma in ) footprint_sigma in
let atoms_sigma_list = let atoms_sigma_list =
match sigma_pto with match sigma_pto with
| [hpred] -> | [hpred] ->
let atoms_hpred_list = extend_footprint_pred hpred in let atoms_hpred_list = extend_footprint_pred hpred in
list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
| _ -> | _ ->
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln(); L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln();
[([], footprint_sigma)] in [([], footprint_sigma)] in
list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
let iter_atoms_fp_sigma_list = let iter_atoms_fp_sigma_list =
list_product iter_list atoms_fp_sigma_list in list_product iter_list atoms_fp_sigma_list in
list_map (fun (iter, (atoms, fp_sigma)) -> list_map (fun (iter, (atoms, fp_sigma)) ->
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
Prop.prop_iter_replace_footprint_sigma iter' fp_sigma Prop.prop_iter_replace_footprint_sigma iter' fp_sigma
) iter_atoms_fp_sigma_list in ) iter_atoms_fp_sigma_list in
let res_prop_list = let res_prop_list =
list_map Prop.prop_iter_to_prop res_iter_list in list_map Prop.prop_iter_to_prop res_iter_list in
begin begin
@ -558,10 +558,10 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
end end
(** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a (** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a
prop, if it's compatible with the allowed footprint prop, if it's compatible with the allowed footprint
variables. Then, change it into a iterator. This function ensures variables. Then, change it into a iterator. This function ensures
that [root(lexp): typ] is the current hpred of the iterator. typ that [root(lexp): typ] is the current hpred of the iterator. typ
is the type of the root of lexp. *) is the type of the root of lexp. *)
let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
let max_stamp = fav_max_stamp (Prop.prop_footprint_fav prop) in let max_stamp = fav_max_stamp (Prop.prop_footprint_fav prop) in
let ptsto, ptsto_foot, atoms = let ptsto, ptsto_foot, atoms =
@ -587,9 +587,9 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
Prop.prop_iter_set_state iter offsets_default Prop.prop_iter_set_state iter offsets_default
(** Add a pointsto for [root(lexp): typ] to the iterator and to the (** Add a pointsto for [root(lexp): typ] to the iterator and to the
footprint, if it's compatible with the allowed footprint footprint, if it's compatible with the allowed footprint
variables. This function ensures that [root(lexp): typ] is the variables. This function ensures that [root(lexp): typ] is the
current hpred of the iterator. typ is the type of the root of lexp. *) current hpred of the iterator. typ is the type of the root of lexp. *)
let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst = let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst =
let max_stamp = fav_max_stamp (Prop.prop_iter_footprint_fav iter) in let max_stamp = fav_max_stamp (Prop.prop_iter_footprint_fav iter) in
let ptsto, ptsto_foot, atoms = let ptsto, ptsto_foot, atoms =
@ -794,11 +794,11 @@ let type_at_offset texp off =
| [], _ -> Some typ | [], _ -> Some typ
| (Sil.Off_fld (f, _)):: off', Sil.Tstruct (ftal, sftal, _, _, _, _, _) -> | (Sil.Off_fld (f, _)):: off', Sil.Tstruct (ftal, sftal, _, _, _, _, _) ->
(try (try
let typ' = let typ' =
(fun (x, y, z) -> y) (fun (x, y, z) -> y)
(list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in (list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in
strip_offset off' typ' strip_offset off' typ'
with Not_found -> None) with Not_found -> None)
| (Sil.Off_index _):: off', Sil.Tarray (typ', _) -> | (Sil.Off_index _):: off', Sil.Tarray (typ', _) ->
strip_offset off' typ' strip_offset off' typ'
| _ -> None in | _ -> None in
@ -808,7 +808,7 @@ let type_at_offset texp off =
| _ -> None | _ -> None
(** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate (** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate
For example, that a pointer to int is not used to assign to a char *) For example, that a pointer to int is not used to assign to a char *)
let check_type_size pname prop texp off typ_from_instr = let check_type_size pname prop texp off typ_from_instr =
L.d_strln_color Orange "check_type_size"; L.d_strln_color Orange "check_type_size";
L.d_str "off: "; Sil.d_offset_list off; L.d_ln (); L.d_str "off: "; Sil.d_offset_list off; L.d_ln ();
@ -831,14 +831,14 @@ let check_type_size pname prop texp off typ_from_instr =
L.d_str "texp: "; Sil.d_texp_full texp; L.d_ln () L.d_str "texp: "; Sil.d_texp_full texp; L.d_ln ()
(** Exposes lexp |->- from iter. In case that it is not possible to (** Exposes lexp |->- from iter. In case that it is not possible to
* expose lexp |->-, this function prints an error message and * expose lexp |->-, this function prints an error message and
* faults. There are four things to note. First, typ is the type of the * faults. There are four things to note. First, typ is the type of the
* root of lexp. Second, prop should mean the same as iter. Third, the * root of lexp. Second, prop should mean the same as iter. Third, the
* result [] means that the given input iter is inconsistent. This * result [] means that the given input iter is inconsistent. This
* happens when the theorem prover can prove the inconsistency of prop, * happens when the theorem prover can prove the inconsistency of prop,
* only after unrolling some predicates in prop. This function ensures * only after unrolling some predicates in prop. This function ensures
* that the theorem prover cannot prove the inconsistency of any of the * that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *) * new iters in the result. *)
let rec iter_rearrange let rec iter_rearrange
pname tenv lexp typ_from_instr prop iter pname tenv lexp typ_from_instr prop iter
inst: (Sil.offset list) Prop.prop_iter list = inst: (Sil.offset list) Prop.prop_iter list =
@ -938,24 +938,24 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let ann_sig = Models.get_annotated_signature pdesc (Cfg.Procdesc.get_proc_name pdesc) in let ann_sig = Models.get_annotated_signature pdesc (Cfg.Procdesc.get_proc_name pdesc) in
list_exists list_exists
(fun hpred -> (fun hpred ->
match hpred with match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _) | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _)
when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig -> when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig ->
nullable_obj_str := Sil.pvar_to_string pvar; nullable_obj_str := Sil.pvar_to_string pvar;
true true
| Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) -> | Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) ->
let is_nullable fld = let is_nullable fld =
match Annotations.get_field_type_and_annotation fld typ with match Annotations.get_field_type_and_annotation fld typ with
| Some (_, annot) -> Annotations.ia_is_nullable annot | Some (_, annot) -> Annotations.ia_is_nullable annot
| _ -> false in | _ -> false in
let is_strexp_pt_by_nullable_fld (fld, strexp) = let is_strexp_pt_by_nullable_fld (fld, strexp) =
match strexp with match strexp with
| Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld -> | Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld ->
nullable_obj_str := Ident.fieldname_to_string fld; nullable_obj_str := Ident.fieldname_to_string fld;
true true
| _ -> false in | _ -> false in
list_exists is_strexp_pt_by_nullable_fld flds list_exists is_strexp_pt_by_nullable_fld flds
| _ -> false) | _ -> false)
(Prop.get_sigma prop) in (Prop.get_sigma prop) in
let root = Sil.root_of_lexp lexp in let root = Sil.root_of_lexp lexp in
let is_deref_of_nullable = let is_deref_of_nullable =
@ -970,8 +970,8 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let rec fold_getters = function let rec fold_getters = function
| [] -> None | [] -> None
| getter:: tl -> match getter prop exp with | getter:: tl -> match getter prop exp with
| Some _ as some_attr -> some_attr | Some _ as some_attr -> some_attr
| None -> fold_getters tl in | None -> fold_getters tl in
fold_getters relevant_attributes_getters in fold_getters relevant_attributes_getters in
let attribute_opt = match get_relevant_attributes root with let attribute_opt = match get_relevant_attributes root with
| Some att -> Some att | Some att -> Some att
@ -1024,8 +1024,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
match e with match e with
| Sil.Var id -> | Sil.Var id ->
(match (Errdesc.find_ident_assignment (State.get_node ()) id) with (match (Errdesc.find_ident_assignment (State.get_node ()) id) with
| Some (_, e') -> e' | Some (_, e') -> e'
| None -> e) | None -> e)
| _ -> e in | _ -> e in
let get_exp_called () = (* Exp called in the block's function call*) let get_exp_called () = (* Exp called in the block's function call*)
match State.get_instr () with match State.get_instr () with
@ -1069,8 +1069,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
end end
(** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ].
It returns an iterator with [lexp |-> strexp: typ] as current predicate It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *)
let rearrange pdesc tenv lexp typ prop loc : (Sil.offset list) Prop.prop_iter list = let rearrange pdesc tenv lexp typ prop loc : (Sil.offset list) Prop.prop_iter list =
let nlexp = match Prop.exp_normalize_prop prop lexp with let nlexp = match Prop.exp_normalize_prop prop lexp with
| Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *) | Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *)

390
infer/src/backend/sil.ml
Unescape View File

@ -304,9 +304,9 @@ module Subtype = struct
try try
SubtypesMap.find (c1, c2) !subtMap SubtypesMap.find (c1, c2) !subtMap
with Not_found -> with Not_found ->
let is_subt = f c1 c2 in let is_subt = f c1 c2 in
subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap); subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap);
is_subt is_subt
let flag_to_string flag = let flag_to_string flag =
match flag with match flag with
@ -385,12 +385,12 @@ module Subtype = struct
match st_opt with match st_opt with
| Some st -> | Some st ->
(match st with (match st with
| Exact, flag -> | Exact, flag ->
let new_flag = update_flag c1 c2 flag flag' in let new_flag = update_flag c1 c2 flag flag' in
Some (Exact, new_flag) Some (Exact, new_flag)
| Subtypes t, flag -> | Subtypes t, flag ->
let new_flag = update_flag c1 c2 flag flag' in let new_flag = update_flag c1 c2 flag flag' in
Some (Subtypes t, new_flag)) Some (Subtypes t, new_flag))
| None -> None | None -> None
let normalize_subtypes t_opt c1 c2 flag1 flag2 = let normalize_subtypes t_opt c1 c2 flag1 flag2 =
@ -398,9 +398,9 @@ module Subtype = struct
match t_opt with match t_opt with
| Some t -> | Some t ->
(match t with (match t with
| Exact -> Some (t, new_flag) | Exact -> Some (t, new_flag)
| Subtypes l -> | Subtypes l ->
Some (Subtypes (list_sort Mangled.compare l), new_flag)) Some (Subtypes (list_sort Mangled.compare l), new_flag))
| None -> None | None -> None
let subtypes_to_string t = let subtypes_to_string t =
@ -417,9 +417,9 @@ module Subtype = struct
f c1 c2 && not (Mangled.equal c1 c2) f c1 c2 && not (Mangled.equal c1 c2)
(* checks for redundancies when adding c to l (* checks for redundancies when adding c to l
Xi in A - { X1,..., Xn } is redundant in two cases: Xi in A - { X1,..., Xn } is redundant in two cases:
1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A 1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A
2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *) 2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *)
let check_redundancies f c l = let check_redundancies f c l =
let aux (l, add) ci = let aux (l, add) ci =
let l, should_add = let l, should_add =
@ -437,7 +437,7 @@ module Subtype = struct
else (updates_head f c rest) else (updates_head f c rest)
(* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur (* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur
A - { X1,..., Xn } is inconsistent if A <: Xi for some i *) A - { X1,..., Xn } is inconsistent if A <: Xi for some i *)
let rec add_not_subtype f c1 l1 l2 = let rec add_not_subtype f c1 l1 l2 =
match l2 with match l2 with
| [] -> l1 | [] -> l1
@ -494,10 +494,10 @@ module Subtype = struct
(change_flag pos_st c1 c2 flag2), (change_flag neg_st c1 c2 flag2) (change_flag pos_st c1 c2 flag2), (change_flag neg_st c1 c2 flag2)
(** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according to [st1] and [st2] (** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according to [st1] and [st2]
where f c1 c2 is true if c1 is a subtype of c2. where f c1 c2 is true if c1 is a subtype of c2.
get_subtypes returning a pair: get_subtypes returning a pair:
- whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1]
- whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *) - whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *)
let case_analysis (c1, st1) (c2, st2) f is_interface = let case_analysis (c1, st1) (c2, st2) f is_interface =
let f = check_subtype f in let f = check_subtype f in
if (!Config.subtype_multirange) then if (!Config.subtype_multirange) then
@ -651,7 +651,7 @@ type dexp =
| Dretcall of dexp * dexp list * location * call_flags | Dretcall of dexp * dexp list * location * call_flags
(** Value paths: identify an occurrence of a value in a symbolic heap (** Value paths: identify an occurrence of a value in a symbolic heap
each expression represents a path, with Dpvar being the simplest one *) each expression represents a path, with Dpvar being the simplest one *)
and vpath = and vpath =
dexp option dexp option
@ -708,9 +708,9 @@ and typ =
| Tptr of typ * ptr_kind (** pointer type *) | Tptr of typ * ptr_kind (** pointer type *)
| Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation (** structure type with class/struct/union flag and name and list of superclasses *) | Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation (** structure type with class/struct/union flag and name and list of superclasses *)
(** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses, (** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses,
methods defined, and annotations. methods defined, and annotations.
The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts
of C structs. *) of C structs. *)
| Tarray of typ * exp (** array type with fixed size *) | Tarray of typ * exp (** array type with fixed size *)
| Tenum of (Mangled.t * const) list | Tenum of (Mangled.t * const) list
@ -753,7 +753,7 @@ type instr =
| Prune of exp * location * bool * if_kind (** prune the state based on [exp=1], the boolean indicates whether true branch *) | Prune of exp * location * bool * if_kind (** prune the state based on [exp=1], the boolean indicates whether true branch *)
| Call of Ident.t list * exp * (exp * typ) list * location * call_flags | Call of Ident.t list * exp * (exp * typ) list * location * call_flags
(** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions (** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions
[ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *) [ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *)
| Nullify of pvar * location * bool (** nullify stack variable, the bool parameter indicates whether to deallocate the variable *) | Nullify of pvar * location * bool (** nullify stack variable, the bool parameter indicates whether to deallocate the variable *)
| Abstract of location (** apply abstraction *) | Abstract of location (** apply abstraction *)
| Remove_temps of Ident.t list * location (** remove temporaries *) | Remove_temps of Ident.t list * location (** remove temporaries *)
@ -810,31 +810,31 @@ type strexp =
| Estruct of (Ident.fieldname * strexp) list * inst (** C structure *) | Estruct of (Ident.fieldname * strexp) list * inst (** C structure *)
| Earray of exp * (exp * strexp) list * inst (** Array of given size. *) | Earray of exp * (exp * strexp) list * inst (** Array of given size. *)
(** There are two conditions imposed / used in the array case. (** There are two conditions imposed / used in the array case.
First, if some index and value pair appears inside an array First, if some index and value pair appears inside an array
in a strexp, then the index is less than the size of the array. in a strexp, then the index is less than the size of the array.
For instance, x |->[10 | e1: v1] implies that e1 <= 9. For instance, x |->[10 | e1: v1] implies that e1 <= 9.
Second, if two indices appear in an array, they should be different. Second, if two indices appear in an array, they should be different.
For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *)
(** an atomic heap predicate *) (** an atomic heap predicate *)
and hpred = and hpred =
| Hpointsto of exp * strexp * exp | Hpointsto of exp * strexp * exp
(** represents [exp|->strexp:typexp] where [typexp] (** represents [exp|->strexp:typexp] where [typexp]
is an expression representing a type, e.h. [sizeof(t)]. *) is an expression representing a type, e.h. [sizeof(t)]. *)
| Hlseg of lseg_kind * hpara * exp * exp * exp list | Hlseg of lseg_kind * hpara * exp * exp * exp list
(** higher - order predicate for singly - linked lists. (** higher - order predicate for singly - linked lists.
Should ensure that exp1!= exp2 implies that exp1 is allocated. Should ensure that exp1!= exp2 implies that exp1 is allocated.
This assumption is used in the rearrangement. The last [exp list] parameter This assumption is used in the rearrangement. The last [exp list] parameter
is used to denote the shared links by all the nodes in the list. *) is used to denote the shared links by all the nodes in the list. *)
| Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list | Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list
(** higher-order predicate for doubly-linked lists. *) (** higher-order predicate for doubly-linked lists. *)
(** parameter for the higher-order singly-linked list predicate. (** parameter for the higher-order singly-linked list predicate.
Means "lambda (root,next,svars). Exists evars. body". Means "lambda (root,next,svars). Exists evars. body".
Assume that root, next, svars, evars are disjoint sets of Assume that root, next, svars, evars are disjoint sets of
primed identifiers, and include all the free primed identifiers in body. primed identifiers, and include all the free primed identifiers in body.
body should not contain any non - primed identifiers or program body should not contain any non - primed identifiers or program
variables (i.e. pvars). *) variables (i.e. pvars). *)
and hpara = and hpara =
{ root: Ident.t; { root: Ident.t;
next: Ident.t; next: Ident.t;
@ -843,8 +843,8 @@ and hpara =
body: hpred list } body: hpred list }
(** parameter for the higher-order doubly-linked list predicates. (** parameter for the higher-order doubly-linked list predicates.
Assume that all the free identifiers in body_dll should belong to Assume that all the free identifiers in body_dll should belong to
cell, blink, flink, svars_dll, evars_dll. *) cell, blink, flink, svars_dll, evars_dll. *)
and hpara_dll = and hpara_dll =
{ cell: Ident.t; (** address cell *) { cell: Ident.t; (** address cell *)
blink: Ident.t; (** backward link *) blink: Ident.t; (** backward link *)
@ -892,8 +892,8 @@ let pvar_get_simplified_name pv =
match string_split_character s '.' with match string_split_character s '.' with
| Some s1, s2 -> | Some s1, s2 ->
(match string_split_character s1 '.' with (match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2 | Some s3, s4 -> s4 ^ "." ^ s2
| _ -> s) | _ -> s)
| _ -> s | _ -> s
(** Check if the pvar is an abucted return var or param passed by ref *) (** Check if the pvar is an abucted return var or param passed by ref *)
@ -1087,8 +1087,8 @@ let binop_compare o1 o2 = match o1, o2 with
let binop_equal o1 o2 = binop_compare o1 o2 = 0 let binop_equal o1 o2 = binop_compare o1 o2 = 0
(** This function returns true if the operation is injective (** This function returns true if the operation is injective
wrt. each argument: op(e,-) and op(-, e) is injective for all e. wrt. each argument: op(e,-) and op(-, e) is injective for all e.
The return value false means "don't know". *) The return value false means "don't know". *)
let binop_injective = function let binop_injective = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false | _ -> false
@ -1099,9 +1099,9 @@ let binop_invertible = function
| _ -> false | _ -> false
(** This function inverts an injective binary operator (** This function inverts an injective binary operator
with respect to the first argument. It returns an expression [e'] such that with respect to the first argument. It returns an expression [e'] such that
BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible,
the function raises an exception by calling "assert false". *) the function raises an exception by calling "assert false". *)
let binop_invert bop e1 e2 = let binop_invert bop e1 e2 =
let inverted_bop = match bop with let inverted_bop = match bop with
| PlusA -> MinusA | PlusA -> MinusA
@ -1112,7 +1112,7 @@ let binop_invert bop e1 e2 =
BinOp(inverted_bop, e2, e1) BinOp(inverted_bop, e2, e1)
(** This function returns true if 0 is the right unit of [binop]. (** This function returns true if 0 is the right unit of [binop].
The return value false means "don't know". *) The return value false means "don't know". *)
let binop_is_zero_runit = function let binop_is_zero_runit = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false | _ -> false
@ -1373,7 +1373,7 @@ and typ_compare t1 t2 =
| Tarray _, _ -> -1 | Tarray _, _ -> -1
| _, Tarray _ -> 1 | _, Tarray _ -> 1
| Tenum l1, Tenum l2 -> | Tenum l1, Tenum l2 ->
(* Here we take as result the first non-zero result when comparing their (constant,value) pair.*) (* Here we take as result the first non-zero result when comparing their (constant,value) pair.*)
let compare_pair (n1, e1) (n2, e2) = let compare_pair (n1, e1) (n2, e2) =
let n = Mangled.compare n1 n2 in let n = Mangled.compare n1 n2 in
if n <> 0 then n else const_compare e1 e2 in if n <> 0 then n else const_compare e1 e2 in
@ -1661,10 +1661,10 @@ module TypMap = Map.Make(struct
(** {2 Sets of expressions} *) (** {2 Sets of expressions} *)
module ExpSet = Set.Make module ExpSet = Set.Make
(struct (struct
type t = exp type t = exp
let compare = exp_compare let compare = exp_compare
end) end)
module ExpMap = Map.Make(struct module ExpMap = Map.Make(struct
type t = exp type t = exp
@ -1678,10 +1678,10 @@ let elist_to_eset es =
(** {2 Sets of heap predicates} *) (** {2 Sets of heap predicates} *)
module HpredSet = Set.Make module HpredSet = Set.Make
(struct (struct
type t = hpred type t = hpred
let compare = hpred_compare let compare = hpred_compare
end) end)
(** {2 Pretty Printing} *) (** {2 Pretty Printing} *)
@ -2015,8 +2015,8 @@ and pp_const pe f = function
| Cint i -> Int.pp f i | Cint i -> Int.pp f i
| Cfun fn -> | Cfun fn ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn)) | PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn))
| _ -> F.fprintf f "_fun_%s" (Procname.to_string fn)) | _ -> F.fprintf f "_fun_%s" (Procname.to_string fn))
| Cstr s -> F.fprintf f "\"%s\"" (String.escaped s) | Cstr s -> F.fprintf f "\"%s\"" (String.escaped s)
| Cfloat v -> F.fprintf f "%f" v | Cfloat v -> F.fprintf f "%f" v
| Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att) | Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att)
@ -2030,8 +2030,8 @@ and pp_typ pe f te =
if !Config.print_types then pp_typ_full pe f te else () if !Config.print_types then pp_typ_full pe f te else ()
(** Pretty print a type declaration. (** Pretty print a type declaration.
pp_base prints the variable for a declaration, or can be skip to print only the type pp_base prints the variable for a declaration, or can be skip to print only the type
pp_size prints the expression for the array size *) pp_size prints the expression for the array size *)
and pp_type_decl pe pp_base pp_size f = function and pp_type_decl pe pp_base pp_size f = function
| Tvar tname -> F.fprintf f "%s %a" (typename_to_string tname) pp_base () | Tvar tname -> F.fprintf f "%s %a" (typename_to_string tname) pp_base ()
| Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base () | Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base ()
@ -2048,7 +2048,7 @@ and pp_type_decl pe pp_base pp_size f = function
| Tstruct (ftal, sftal, csu, Some name, _, _, _) when false -> (* remove "when false" to print the details of struct *) | Tstruct (ftal, sftal, csu, Some name, _, _, _) when false -> (* remove "when false" to print the details of struct *)
F.fprintf f "%s %a {%a} %a" (csu_name csu) Mangled.pp name F.fprintf f "%s %a {%a} %a" (csu_name csu) Mangled.pp name
(pp_seq (fun f (fld, t, ann) -> (pp_seq (fun f (fld, t, ann) ->
F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld))
ftal pp_base () ftal pp_base ()
| Tstruct (ftal, sftal, csu, Some name, _, _, _) -> | Tstruct (ftal, sftal, csu, Some name, _, _, _) ->
F.fprintf f "%s %a %a" (csu_name csu) Mangled.pp name pp_base () F.fprintf f "%s %a %a" (csu_name csu) Mangled.pp name pp_base ()
@ -2072,32 +2072,32 @@ and _pp_exp pe0 pp_t f e0 =
| Some sub -> Obj.obj (sub (Obj.repr e0)) (* apply object substitution to expression *) | Some sub -> Obj.obj (sub (Obj.repr e0)) (* apply object substitution to expression *)
| None -> e0 in | None -> e0 in
(if not (exp_equal e0 e) (if not (exp_equal e0 e)
then then
match e with match e with
| Lvar pvar -> pp_pvar_value pe f pvar | Lvar pvar -> pp_pvar_value pe f pvar
| _ -> assert false | _ -> assert false
else else
let pp_exp = _pp_exp pe pp_t in let pp_exp = _pp_exp pe pp_t in
let print_binop_stm_output e1 op e2 = let print_binop_stm_output e1 op e2 =
match op with match op with
| Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1 | Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1
| Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1 | Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1
| Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1 | Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1
| Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1 | Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1
| Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1 | Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1
| _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in | _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in
begin match e with begin match e with
| Var id -> (Ident.pp pe) f id | Var id -> (Ident.pp pe) f id
| Const c -> F.fprintf f "%a" (pp_const pe) c | Const c -> F.fprintf f "%a" (pp_const pe) c
| Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e | Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e
| UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e | UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e
| BinOp (op, Const c, e2) when !Config.smt_output -> print_binop_stm_output (Const c) op e2 | 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 (str_binop pe op) pp_exp e2 | BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2
| Lvar pv -> pp_pvar pe f pv | Lvar pv -> pp_pvar pe f pv
| Lfield (e, fld, typ) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld | Lfield (e, fld, typ) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld
| Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 | Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2
| Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s | Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s
end); end);
color_post_wrapper changed pe0 f color_post_wrapper changed pe0 f
and pp_exp pe f e = and pp_exp pe f e =
@ -2209,33 +2209,33 @@ let pp_call_flags f cf =
let rec pp_instr pe0 f instr = let rec pp_instr pe0 f instr =
let pe, changed = color_pre_wrapper pe0 f instr in let pe, changed = color_pre_wrapper pe0 f instr in
(match instr with (match instr with
| Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc | Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc
| Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc | Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc
| Prune (cond, loc, true_branch, ik) -> | Prune (cond, loc, true_branch, ik) ->
F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc
| Call (ret_ids, e, arg_ts, loc, cf) -> | Call (ret_ids, e, arg_ts, loc, cf) ->
(match ret_ids with (match ret_ids with
| [] -> () | [] -> ()
| _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids); | _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids);
F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc
| Nullify (pvar, loc, deallocate) -> | Nullify (pvar, loc, deallocate) ->
F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc
| Abstract loc -> | Abstract loc ->
F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc
| Remove_temps (temps, loc) -> | Remove_temps (temps, loc) ->
F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc
| Stackop (stackop, loc) -> | Stackop (stackop, loc) ->
let s = match stackop with let s = match stackop with
| Push -> "Push" | Push -> "Push"
| Swap -> "Swap" | Swap -> "Swap"
| Pop -> "Pop" in | Pop -> "Pop" in
F.fprintf f "STACKOP.%s; %a" s pp_loc loc F.fprintf f "STACKOP.%s; %a" s pp_loc loc
| Declare_locals (ptl, loc) -> | Declare_locals (ptl, loc) ->
(* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *) (* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *)
let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a" (pp_pvar pe) pvar in let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a" (pp_pvar pe) pvar in
F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc
| Goto_node (e, loc) -> | Goto_node (e, loc) ->
F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc
); );
color_post_wrapper changed pe0 f color_post_wrapper changed pe0 f
@ -2288,8 +2288,8 @@ and exp_iter_types f e =
| UnOp (op, e1, typo) -> | UnOp (op, e1, typo) ->
exp_iter_types f e1; exp_iter_types f e1;
(match typo with (match typo with
| Some t -> typ_iter_types f t | Some t -> typ_iter_types f t
| None -> ()) | None -> ())
| BinOp (op, e1, e2) -> | BinOp (op, e1, e2) ->
exp_iter_types f e1; exp_iter_types f e1;
exp_iter_types f e2 exp_iter_types f e2
@ -2346,26 +2346,26 @@ let pp_atom pe0 f a =
begin match a with begin match a with
| Aeq (BinOp(op, e1, e2), Const (Cint i)) when Int.isone i -> | Aeq (BinOp(op, e1, e2), Const (Cint i)) when Int.isone i ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
) )
| Aeq (e1, e2) -> | Aeq (e1, e2) ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2) F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2)
| Aneq ((Const (Cattribute a) as ea), e) | Aneq ((Const (Cattribute a) as ea), e)
| Aneq (e, (Const (Cattribute a) as ea)) -> | Aneq (e, (Const (Cattribute a) as ea)) ->
F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e
| Aneq (e1, e2) -> | Aneq (e1, e2) ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2 F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2) F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2)
end; end;
color_post_wrapper changed pe0 f color_post_wrapper changed pe0 f
@ -2384,9 +2384,9 @@ let rec pp_star_seq pp f = function
(********* START OF MODULE Predicates **********) (********* START OF MODULE Predicates **********)
(** Module Predicates records the occurrences of predicates as parameters (** Module Predicates records the occurrences of predicates as parameters
of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *) of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *)
module Predicates : sig module Predicates : sig
(** predicate environment *) (** predicate environment *)
type env type env
(** create an empty predicate environment *) (** create an empty predicate environment *)
val empty_env : unit -> env val empty_env : unit -> env
@ -2397,7 +2397,7 @@ module Predicates : sig
(** return the id of the hpara_dll *) (** return the id of the hpara_dll *)
val get_hpara_dll_id : env -> hpara_dll -> int val get_hpara_dll_id : env -> hpara_dll -> int
(** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll,
passing the unique id to the functions. The iterator can only be used once. *) passing the unique id to the functions. The iterator can only be used once. *)
val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit
(** Process one hpred, updating the predicate environment *) (** Process one hpred, updating the predicate environment *)
val process_hpred : env -> hpred -> unit val process_hpred : env -> hpred -> unit
@ -2418,7 +2418,7 @@ end = struct
end) end)
(** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, (** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted,
also keep a list of hparas still to be emitted. Same for hpara_dll. *) also keep a list of hparas still to be emitted. Same for hpara_dll. *)
type env = type env =
{ {
mutable num: int; mutable num: int;
@ -2443,16 +2443,16 @@ end = struct
let process_hpara env hpara = let process_hpara env hpara =
if not (HparaHash.mem env.hash hpara) then if not (HparaHash.mem env.hash hpara) then
(HparaHash.add env.hash hpara (env.num, false); (HparaHash.add env.hash hpara (env.num, false);
env.num <- env.num + 1; env.num <- env.num + 1;
env.todo <- env.todo @ [hpara]) env.todo <- env.todo @ [hpara])
(** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *)
let process_hpara_dll env hpara_dll = let process_hpara_dll env hpara_dll =
if not (HparaDllHash.mem env.hash_dll hpara_dll) if not (HparaDllHash.mem env.hash_dll hpara_dll)
then then
(HparaDllHash.add env.hash_dll hpara_dll (env.num, false); (HparaDllHash.add env.hash_dll hpara_dll (env.num, false);
env.num <- env.num + 1; env.num <- env.num + 1;
env.todo_dll <- env.todo_dll @ [hpara_dll]) env.todo_dll <- env.todo_dll @ [hpara_dll])
(** Process a sexp, updating env *) (** Process a sexp, updating env *)
let rec process_sexp env = function let rec process_sexp env = function
@ -2484,8 +2484,8 @@ end = struct
} }
(** iterator for predicates which are marked as todo in env, unless they have been visited already. (** iterator for predicates which are marked as todo in env, unless they have been visited already.
This can in turn extend the todo list for the nested predicates, which are then visited as well. This can in turn extend the todo list for the nested predicates, which are then visited as well.
Can be applied only once, as it destroys the todo list *) Can be applied only once, as it destroys the todo list *)
let iter (env: env) f f_dll = let iter (env: env) f f_dll =
while env.todo != [] || env.todo_dll != [] do while env.todo != [] || env.todo_dll != [] do
if env.todo != [] then if env.todo != [] then
@ -2683,26 +2683,26 @@ and pp_hpred_env pe0 envo f hpred =
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in | _ -> pe in
(match pe'.pe_kind with (match pe'.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se) F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se)
| Hlseg (k, hpara, e1, e2, elist) -> | Hlseg (k, hpara, e1, e2, elist) ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "lseg%a(%a,%a,[%a],%a)" F.fprintf f "lseg%a(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara) pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara)
| Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll) pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll)
end; end;
color_post_wrapper changed pe0 f color_post_wrapper changed pe0 f
@ -2868,24 +2868,24 @@ let unsome_typ s = function
assert false assert false
(** Turn an expression representing a type into the type it represents (** 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 *) If not a sizeof, return the default type if given, otherwise raise an exception *)
let texp_to_typ default_opt = function let texp_to_typ default_opt = function
| Sizeof (t, _) -> t | Sizeof (t, _) -> t
| t -> | t ->
unsome_typ "texp_to_typ" default_opt unsome_typ "texp_to_typ" default_opt
(** If a struct type with field f, return the type of f. (** If a struct type with field f, return the type of f.
If not, return the default type if given, otherwise raise an exception *) If not, return the default type if given, otherwise raise an exception *)
let struct_typ_fld default_opt f = let struct_typ_fld default_opt f =
let def () = unsome_typ "struct_typ_fld" default_opt in let def () = unsome_typ "struct_typ_fld" default_opt in
function function
| Tstruct (ftal, sftal, _, _, _, _, _) -> | Tstruct (ftal, sftal, _, _, _, _, _) ->
(try (fun (x, y, z) -> y) (list_find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal) (try (fun (x, y, z) -> y) (list_find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal)
with Not_found -> def ()) with Not_found -> def ())
| _ -> def () | _ -> def ()
(** If an array type, return the type of the element. (** If an array type, return the type of the element.
If not, return the default type if given, otherwise raise an exception *) If not, return the default type if given, otherwise raise an exception *)
let array_typ_elem default_opt = function let array_typ_elem default_opt = function
| Tarray (t_el, _) -> t_el | Tarray (t_el, _) -> t_el
| t -> | t ->
@ -2903,7 +2903,7 @@ let rec root_of_lexp lexp = match lexp with
| Sizeof _ -> lexp | Sizeof _ -> lexp
(** Checks whether an expression denotes a location by pointer arithmetic. (** Checks whether an expression denotes a location by pointer arithmetic.
Currently, catches array - indexing expressions such as a[i] only. *) Currently, catches array - indexing expressions such as a[i] only. *)
let rec exp_pointer_arith = function let rec exp_pointer_arith = function
| Lfield (e, _, _) -> exp_pointer_arith e | Lfield (e, _, _) -> exp_pointer_arith e
| Lindex _ -> true | Lindex _ -> true
@ -2999,9 +2999,9 @@ and hpred_fpv = function
@ fpvars_in_elist @ fpvars_in_elist
(** hpara should not contain any program variables. (** hpara should not contain any program variables.
This is because it might cause problems when we do interprocedural This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *) of scopes of program variables. *)
and hpara_fpv para = and hpara_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in
match fpvars_in_body with match fpvars_in_body with
@ -3009,9 +3009,9 @@ and hpara_fpv para =
| _ -> assert false | _ -> assert false
(** hpara_dll should not contain any program variables. (** hpara_dll should not contain any program variables.
This is because it might cause problems when we do interprocedural This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *) of scopes of program variables. *)
and hpara_dll_fpv para = and hpara_dll_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in
match fpvars_in_body with match fpvars_in_body with
@ -3069,7 +3069,7 @@ let rec remove_duplicates_from_sorted special_equal = function
else x:: (remove_duplicates_from_sorted special_equal (y:: l)) else x:: (remove_duplicates_from_sorted special_equal (y:: l))
(** Convert a [fav] to a list of identifiers while preserving the order (** Convert a [fav] to a list of identifiers while preserving the order
that the identifiers were added to [fav]. *) that the identifiers were added to [fav]. *)
let fav_to_list fav = let fav_to_list fav =
list_rev !fav list_rev !fav
@ -3107,7 +3107,7 @@ let rec ident_sorted_list_subset l1 l2 =
else false else false
(** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] (** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1]
is in [fav2].*) is in [fav2].*)
let fav_subset_ident fav1 fav2 = let fav_subset_ident fav1 fav2 =
ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2) ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2)
@ -3173,16 +3173,16 @@ let hpred_fav =
fav_imperative_to_functional hpred_fav_add fav_imperative_to_functional hpred_fav_add
(** This function should be used before adding a new (** This function should be used before adding a new
index to Earray. The [exp] is the newly created index to Earray. The [exp] is the newly created
index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop. index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop.
The function faults in the re - execution mode, as an internal check of the tool. *) The function faults in the re - execution mode, as an internal check of the tool. *)
let array_clean_new_index footprint_part new_idx = let array_clean_new_index footprint_part new_idx =
if footprint_part && not !Config.footprint then assert false; if footprint_part && not !Config.footprint then assert false;
let fav = exp_fav new_idx in let fav = exp_fav new_idx in
if footprint_part && fav_exists fav (fun id -> not (Ident.is_footprint id)) then if footprint_part && fav_exists fav (fun id -> not (Ident.is_footprint id)) then
begin begin
L.d_warning ("Array index " ^ (exp_to_string new_idx) ^ L.d_warning ("Array index " ^ (exp_to_string new_idx) ^
" has non-footprint vars: replaced by fresh footprint var"); " has non-footprint vars: replaced by fresh footprint var");
L.d_ln (); L.d_ln ();
let id = Ident.create_fresh Ident.kfootprint in let id = Ident.create_fresh Ident.kfootprint in
Var id Var id
@ -3288,8 +3288,8 @@ let sub_check_inv sub =
(sub_check_sortedness sub) && not (sub_check_duplicated_ids sub) (sub_check_sortedness sub) && not (sub_check_duplicated_ids sub)
(** Create a substitution from a list of pairs. (** Create a substitution from a list of pairs.
For all (id1, e1), (id2, e2) in the input list, For all (id1, e1), (id2, e2) in the input list,
if id1 = id2, then e1 = e2. *) if id1 = id2, then e1 = e2. *)
let sub_of_list sub = let sub_of_list sub =
let sub' = list_sort ident_exp_compare sub in let sub' = list_sort ident_exp_compare sub in
let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in
@ -3315,7 +3315,7 @@ let sub_to_list sub =
let sub_empty = sub_of_list [] let sub_empty = sub_of_list []
(** Join two substitutions into one. (** Join two substitutions into one.
For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *)
let sub_join sub1 sub2 = let sub_join sub1 sub2 =
let sub = sorted_list_merge ident_exp_compare sub1 sub2 in let sub = sorted_list_merge ident_exp_compare sub1 sub2 in
let sub' = remove_duplicates_from_sorted ident_exp_equal sub in let sub' = remove_duplicates_from_sorted ident_exp_equal sub in
@ -3323,9 +3323,9 @@ let sub_join sub1 sub2 =
sub sub
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. (** Compute the common id-exp part of two inputs [subst1] and [subst2].
The first component of the output is this common part. The first component of the output is this common part.
The second and third components are the remainder of [subst1] The second and third components are the remainder of [subst1]
and [subst2], respectively. *) and [subst2], respectively. *)
let sub_symmetric_difference sub1_in sub2_in = let sub_symmetric_difference sub1_in sub2_in =
let rec diff sub_common sub1_only sub2_only sub1 sub2 = let rec diff sub_common sub1_only sub2_only sub1 sub2 =
match sub1, sub2 with match sub1, sub2 with
@ -3353,21 +3353,21 @@ let sub_find filter (sub: subst) =
snd (list_find (fun (i, _) -> filter i) sub) snd (list_find (fun (i, _) -> filter i) sub)
(** [sub_filter filter sub] restricts the domain of [sub] to the (** [sub_filter filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter]. *) identifiers satisfying [filter]. *)
let sub_filter filter (sub: subst) = let sub_filter filter (sub: subst) =
list_filter (fun (i, _) -> filter i) sub list_filter (fun (i, _) -> filter i) sub
(** [sub_filter_pair filter sub] restricts the domain of [sub] to the (** [sub_filter_pair filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter(id, sub(id))]. *) identifiers satisfying [filter(id, sub(id))]. *)
let sub_filter_pair = list_filter let sub_filter_pair = list_filter
(** [sub_range_partition filter sub] partitions [sub] according to (** [sub_range_partition filter sub] partitions [sub] according to
whether range expressions satisfy [filter]. *) whether range expressions satisfy [filter]. *)
let sub_range_partition filter (sub: subst) = let sub_range_partition filter (sub: subst) =
list_partition (fun (_, e) -> filter e) sub list_partition (fun (_, e) -> filter e) sub
(** [sub_domain_partition filter sub] partitions [sub] according to (** [sub_domain_partition filter sub] partitions [sub] according to
whether domain identifiers satisfy [filter]. *) whether domain identifiers satisfy [filter]. *)
let sub_domain_partition filter (sub: subst) = let sub_domain_partition filter (sub: subst) =
list_partition (fun (i, _) -> filter i) sub list_partition (fun (i, _) -> filter i) sub
@ -3384,7 +3384,7 @@ let sub_range_map f sub =
sub_of_list (list_map (fun (i, e) -> (i, f e)) sub) sub_of_list (list_map (fun (i, e) -> (i, f e)) sub)
(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain (** [sub_map f g sub] applies the renaming [f] to identifiers in the domain
of [sub] and the substitution [g] to the expressions in the range of [sub]. *) of [sub] and the substitution [g] to the expressions in the range of [sub]. *)
let sub_map f g sub = let sub_map f g sub =
sub_of_list (list_map (fun (i, e) -> (f i, g e)) sub) sub_of_list (list_map (fun (i, e) -> (f i, g e)) sub)
@ -3398,7 +3398,7 @@ let extend_sub sub id exp : subst option =
else Some (sorted_list_merge compare sub [(id, exp)]) else Some (sorted_list_merge compare sub [(id, exp)])
(** Free auxilary variables in the domain and range of the (** Free auxilary variables in the domain and range of the
substitution. *) substitution. *)
let sub_fav_add fav (sub: subst) = let sub_fav_add fav (sub: subst) =
list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub
@ -3765,8 +3765,8 @@ let tenv_fold f tenv =
let pp_tenv f (tenv : tenv) = let pp_tenv f (tenv : tenv) =
TypenameHash.iter TypenameHash.iter
(fun name typ -> (fun name typ ->
Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name); Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name);
Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ) Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ)
tenv tenv
(** {2 Functions for constructing or destructing entities in this module} *) (** {2 Functions for constructing or destructing entities in this module} *)
@ -3840,9 +3840,9 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list =
[([], sigma)] [([], sigma)]
(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], (** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1],
[e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b],
then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*) for some fresh [_zs'].*)
let hpara_instantiate para e1 e2 elist = let hpara_instantiate para e1 e2 elist =
let subst_for_svars = let subst_for_svars =
let g id e = (id, e) in let g id e = (id, e) in
@ -3859,9 +3859,9 @@ let hpara_instantiate para e1 e2 elist =
(ids_evars, list_map (hpred_sub subst) para.body) (ids_evars, list_map (hpred_sub subst) para.body)
(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], (** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell],
[blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b],
then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*) for some fresh [_zs'].*)
let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist =
let subst_for_svars = let subst_for_svars =
let g id e = (id, e) in let g id e = (id, e) in
@ -3882,7 +3882,7 @@ let rec strexp_get_target_exps = function
| Eexp (e, inst) -> [e] | Eexp (e, inst) -> [e]
| Estruct (fsel, inst) -> list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) fsel) | Estruct (fsel, inst) -> list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) fsel)
| Earray (_, esel, _) -> | Earray (_, esel, _) ->
(* We ignore size and indices since they are not quite outgoing arrows. *) (* We ignore size and indices since they are not quite outgoing arrows. *)
list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) esel) list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) esel)
let global_error = let global_error =

98
infer/src/backend/specs.ml
Unescape View File

@ -120,15 +120,15 @@ module Jprop = struct
| [] -> acc | [] -> acc
| (Prop (_, p) as jp) :: jpl -> | (Prop (_, p) as jp) :: jpl ->
(match f jp with (match f jp with
| Some x -> | Some x ->
do_filter (x:: acc) jpl do_filter (x:: acc) jpl
| None -> do_filter acc jpl) | None -> do_filter acc jpl)
| (Joined (_, p, jp1, jp2) as jp) :: jpl -> | (Joined (_, p, jp1, jp2) as jp) :: jpl ->
(match f jp with (match f jp with
| Some x -> | Some x ->
do_filter (x:: acc) jpl do_filter (x:: acc) jpl
| None -> | None ->
do_filter acc (jpl @ [jp1; jp2])) in do_filter acc (jpl @ [jp1; jp2])) in
do_filter [] jpl do_filter [] jpl
let rec map (f : 'a Prop.t -> 'b Prop.t) = function let rec map (f : 'a Prop.t -> 'b Prop.t) = function
@ -148,20 +148,20 @@ let visited_str vis =
let lines = ref IntSet.empty in let lines = ref IntSet.empty in
let do_one (node, ns) = let do_one (node, ns) =
(* if list_length ns > 1 then (* if list_length ns > 1 then
begin begin
let ss = ref "" in let ss = ref "" in
list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns; list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns;
L.err "Node %d has lines %s@." node !ss L.err "Node %d has lines %s@." node !ss
end; *) end; *)
list_iter (fun n -> lines := IntSet.add n !lines) ns in list_iter (fun n -> lines := IntSet.add n !lines) ns in
Visitedset.iter do_one vis; Visitedset.iter do_one vis;
IntSet.iter (fun n -> s := !s ^ " " ^ string_of_int n) !lines; IntSet.iter (fun n -> s := !s ^ " " ^ string_of_int n) !lines;
!s !s
(** A spec consists of: (** A spec consists of:
pre: a joined prop pre: a joined prop
post: a list of props with path post: a list of props with path
visited: a list of pairs (node_id, line) for the visited nodes *) visited: a list of pairs (node_id, line) for the visited nodes *)
type 'a spec = { pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited : Visitedset.t } type 'a spec = { pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited : Visitedset.t }
module NormSpec : sig (* encapsulate type for normalized specs *) module NormSpec : sig (* encapsulate type for normalized specs *)
@ -407,10 +407,10 @@ let describe_phase summary =
let get_signature summary = let get_signature summary =
let s = ref "" in let s = ref "" in
list_iter (fun (p, typ) -> list_iter (fun (p, typ) ->
let pp_name f () = F.fprintf f "%s" p in let pp_name f () = F.fprintf f "%s" p in
let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in
let decl = pp_to_string pp () in let decl = pp_to_string pp () in
s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals; s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals;
let pp_procname f () = F.fprintf f "%a" Procname.pp summary.proc_name in let pp_procname f () = F.fprintf f "%a" Procname.pp summary.proc_name in
let pp f () = Sil.pp_type_decl pe_text pp_procname Sil.pp_exp f summary.ret_type in let pp f () = Sil.pp_type_decl pe_text pp_procname Sil.pp_exp f summary.ret_type in
let decl = pp_to_string pp () in let decl = pp_to_string pp () in
@ -462,8 +462,8 @@ let empty_stats err_log calls cyclomatic in_out_calls_opt =
stats_timeout = false; stats_timeout = false;
stats_calls = stats_calls =
(match in_out_calls_opt with (match in_out_calls_opt with
| Some in_out_calls -> in_out_calls | Some in_out_calls -> in_out_calls
| None -> { Cg.in_calls = 0; Cg.out_calls = 0 }); | None -> { Cg.in_calls = 0; Cg.out_calls = 0 });
symops = 0; symops = 0;
err_log = err_log; err_log = err_log;
nodes_visited_fp = IntSet.empty; nodes_visited_fp = IntSet.empty;
@ -570,9 +570,9 @@ let load_summary_to_spec_table proc_name =
| [] -> false | [] -> false
| spec_path :: spec_paths -> | spec_path :: spec_paths ->
(match load_summary spec_path with (match load_summary spec_path with
| None -> load_summary_libs spec_paths | None -> load_summary_libs spec_paths
| Some summ -> | Some summ ->
add summ Spec_lib) in add summ Spec_lib) in
let rec load_summary_ziplibs zip_libraries = (* try to load the summary from a list of zip libraries *) let rec load_summary_ziplibs zip_libraries = (* try to load the summary from a list of zip libraries *)
let zip_specs_filename = specs_filename proc_name in let zip_specs_filename = specs_filename proc_name in
let zip_specs_path = let zip_specs_path =
@ -591,7 +591,7 @@ let load_summary_to_spec_table proc_name =
let default_spec_dir = res_dir_specs_filename proc_name in let default_spec_dir = res_dir_specs_filename proc_name in
match load_summary default_spec_dir with match load_summary default_spec_dir with
| None -> | None ->
(* search on models, libzips, and libs *) (* search on models, libzips, and libs *)
if load_summary_models (specs_models_filename proc_name) then true if load_summary_models (specs_models_filename proc_name) then true
else if load_summary_ziplibs !Config.zip_libraries then true else if load_summary_ziplibs !Config.zip_libraries then true
else load_summary_libs (specs_library_filenames proc_name) else load_summary_libs (specs_library_filenames proc_name)
@ -603,9 +603,9 @@ let rec get_summary_origin proc_name =
try try
Some (Procname.Hash.find spec_tbl proc_name) Some (Procname.Hash.find spec_tbl proc_name)
with Not_found -> with Not_found ->
if load_summary_to_spec_table proc_name then if load_summary_to_spec_table proc_name then
get_summary_origin proc_name get_summary_origin proc_name
else None else None
let get_summary proc_name = let get_summary proc_name =
match get_summary_origin proc_name with match get_summary_origin proc_name with
@ -619,7 +619,7 @@ let get_summary_unsafe proc_name =
| Some summary -> summary | Some summary -> summary
(** Check if the procedure is from a library: (** Check if the procedure is from a library:
It's not defined in the current proc desc, and there is no spec file for it. *) It's not defined in the current proc desc, and there is no spec file for it. *)
let proc_is_library proc_name proc_desc = let proc_is_library proc_name proc_desc =
let defined = Cfg.Procdesc.is_defined proc_desc in let defined = Cfg.Procdesc.is_defined proc_desc in
if not defined then if not defined then
@ -688,7 +688,7 @@ let get_flag proc_name key =
with Not_found -> None with Not_found -> None
(** Get the iterations associated to the procedure if any, or the default timeout from the (** Get the iterations associated to the procedure if any, or the default timeout from the
command line *) command line *)
let get_iterations proc_name = let get_iterations proc_name =
match get_summary proc_name with match get_summary proc_name with
| None -> | None ->
@ -735,7 +735,7 @@ let re_initialize_dependency_map dependency_map =
Procname.Map.map (fun dep_proc -> - 1) dependency_map Procname.Map.map (fun dep_proc -> - 1) dependency_map
(** Update the dependency map of [proc_name] with the current (** Update the dependency map of [proc_name] with the current
timestamps of the dependents *) timestamps of the dependents *)
let update_dependency_map proc_name = let update_dependency_map proc_name =
match get_summary_origin proc_name with match get_summary_origin proc_name with
| None -> | None ->
@ -749,12 +749,12 @@ let update_dependency_map proc_name =
set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin
(** [init_summary loc (proc_name, ret_type, formals, depend_list, loc, nodes, (** [init_summary loc (proc_name, ret_type, formals, depend_list, loc, nodes,
proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)] proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)]
initializes the summary for [proc_name] given dependent procs in list [depend_list]. *) initializes the summary for [proc_name] given dependent procs in list [depend_list]. *)
let init_summary let init_summary
(proc_name, ret_type, formals, depend_list, loc, (proc_name, ret_type, formals, depend_list, loc,
nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt,
proc_attributes) = proc_attributes) =
let dependency_map = mk_initial_dependency_map depend_list in let dependency_map = mk_initial_dependency_map depend_list in
let summary = let summary =
{ {
@ -790,19 +790,19 @@ let reset_summary call_graph proc_name loc =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
init_summary ( init_summary (
proc_name, proc_name,
Sil.Tvoid, Sil.Tvoid,
[], [],
Procname.Set.elements Procname.Set.elements
dependents, dependents,
loc, loc,
[], [],
proc_flags_empty (), proc_flags_empty (),
Errlog.empty (), Errlog.empty (),
[], [],
0, 0,
Some (Cg.get_calls call_graph proc_name), Some (Cg.get_calls call_graph proc_name),
proc_attributes proc_attributes
) )
(* =============== END of support for spec tables =============== *) (* =============== END of support for spec tables =============== *)

18
infer/src/backend/state.ml
Unescape View File

@ -51,8 +51,8 @@ type failure_stats = {
mutable node_fail: int; (* number of node failures (i.e. at least one instruction failure) *) mutable node_fail: int; (* number of node failures (i.e. at least one instruction failure) *)
mutable node_ok: int; (* number of node successes (i.e. no instruction failures) *) mutable node_ok: int; (* number of node successes (i.e. no instruction failures) *)
mutable first_failure : mutable first_failure :
(Sil.location * (int * int) * int * Errlog.loc_trace * (Sil.location * (int * int) * int * Errlog.loc_trace *
(Prop.normal Prop.t) option * exn) option (* exception at the first failure *) (Prop.normal Prop.t) option * exn) option (* exception at the first failure *)
} }
module NodeHash = Cfg.NodeHash module NodeHash = Cfg.NodeHash
@ -63,9 +63,9 @@ let failure_map : failure_stats NodeHash.t = NodeHash.create 1
let get_failure_stats node = let get_failure_stats node =
try NodeHash.find failure_map node try NodeHash.find failure_map node
with Not_found -> with Not_found ->
let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in
NodeHash.add failure_map node fs; NodeHash.add failure_map node fs;
fs fs
let add_diverging_states pset = let add_diverging_states pset =
diverging_states_proc := Paths.PathSet.union pset !diverging_states_proc; diverging_states_proc := Paths.PathSet.union pset !diverging_states_proc;
@ -137,8 +137,8 @@ let instrs_normalize instrs =
list_map (Sil.instr_sub subst) instrs list_map (Sil.instr_sub subst) instrs
(** Create a function to find duplicate nodes. (** Create a function to find duplicate nodes.
A node is a duplicate of another one if they have the same kind and location A node is a duplicate of another one if they have the same kind and location
and normalized (w.r.t. renaming of let - bound ids) list of instructions. *) and normalized (w.r.t. renaming of let - bound ids) list of instructions. *)
let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) = let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let module M = (* map from (loc,kind) *) let module M = (* map from (loc,kind) *)
Map.Make(struct Map.Make(struct
@ -182,7 +182,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
list_iter do_node nodes; list_iter do_node nodes;
!m !m
with E.Threshold -> with E.Threshold ->
M.empty in M.empty in
let find_duplicate_nodes node = let find_duplicate_nodes node =
try try
@ -238,7 +238,7 @@ let extract_pre p tenv pdesc abstract_fun =
Prop.normalize (Prop.prop_sub sub pre') Prop.normalize (Prop.prop_sub sub pre')
(** return the normalized precondition extracted form the last prop seen, if any (** return the normalized precondition extracted form the last prop seen, if any
the abstraction function is a parameter to get around module dependencies *) the abstraction function is a parameter to get around module dependencies *)
let get_normalized_pre (abstract_fun : Sil.tenv -> Prop.normal Prop.t -> Prop.normal Prop.t) : Prop.normal Prop.t option = let get_normalized_pre (abstract_fun : Sil.tenv -> Prop.normal Prop.t -> Prop.normal Prop.t) : Prop.normal Prop.t option =
match get_prop_tenv_pdesc () with match get_prop_tenv_pdesc () with
| None -> None | None -> None

728
infer/src/backend/symExec.ml
View File

File diff suppressed because it is too large Load Diff

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

@ -46,9 +46,9 @@ type valid_res =
vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) } vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) }
(** Result of (bi)-abduction on a single spec. (** Result of (bi)-abduction on a single spec.
A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma
part of the splitting is not empty. part of the splitting is not empty.
A valid result contains the missing pi ans sigma, as well as the resulting props. *) A valid result contains the missing pi ans sigma, as well as the resulting props. *)
type abduction_res = type abduction_res =
| Valid_res of valid_res (** valid result for a function cal *) | Valid_res of valid_res (** valid result for a function cal *)
| Invalid_res of invalid_res (** reason for invalid result *) | Invalid_res of invalid_res (** reason for invalid result *)
@ -113,14 +113,14 @@ let spec_find_rename trace_call (proc_name : Procname.t) : (int * Prop.exposed S
list_map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in list_map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in
list_map f specs, formal_parameters list_map f specs, formal_parameters
with Not_found -> begin with Not_found -> begin
L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up..."); L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up...");
raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x)) raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x))
end end
(** Process a splitting coming straight from a call to the prover: (** Process a splitting coming straight from a call to the prover:
change the instantiating substitution so that it returns primed vars, change the instantiating substitution so that it returns primed vars,
except for vars occurring in the missing part, where it returns except for vars occurring in the missing part, where it returns
footprint vars. *) footprint vars. *)
let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ = let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ =
(* (*
let check_precondition () = let check_precondition () =
@ -228,11 +228,11 @@ and find_dereference_without_null_check_in_sexp_list = function
| [] -> None | [] -> None
| se:: sel -> | se:: sel ->
(match find_dereference_without_null_check_in_sexp se with (match find_dereference_without_null_check_in_sexp se with
| None -> find_dereference_without_null_check_in_sexp_list sel | None -> find_dereference_without_null_check_in_sexp_list sel
| Some x -> Some x) | Some x -> Some x)
(** Check dereferences implicit in the spec pre. (** Check dereferences implicit in the spec pre.
In case of dereference error, return [Some(deref_error, description)], otherwise [None] *) In case of dereference error, return [Some(deref_error, description)], otherwise [None] *)
let check_dereferences callee_pname actual_pre sub spec_pre formal_params = let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp = let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in let e_sub = Sil.exp_sub sub e in
@ -253,9 +253,9 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
else None in else None in
if deref_no_null_check_pos != None if deref_no_null_check_pos != None
then (* only report a dereference null error if we know there was a dereference without null check *) then (* only report a dereference null error if we know there was a dereference without null check *)
match deref_no_null_check_pos with match deref_no_null_check_pos with
| Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) | Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname)))
| None -> assert false | None -> assert false
else if Sil.exp_equal e_sub Sil.exp_minus_one then Some (Deref_minusone, desc true (Localise.deref_str_dangling None)) else if Sil.exp_equal e_sub Sil.exp_minus_one then Some (Deref_minusone, desc true (Localise.deref_str_dangling None))
else match Prop.get_resource_undef_attribute actual_pre e_sub with else match Prop.get_resource_undef_attribute actual_pre e_sub with
| Some (Sil.Aundef (s, loc, pos)) -> | Some (Sil.Aundef (s, loc, pos)) ->
@ -268,25 +268,25 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
check_dereference (Sil.root_of_lexp lexp) se check_dereference (Sil.root_of_lexp lexp) se
| _ -> None in | _ -> None in
let deref_err_list = list_fold_left (fun deref_errs hpred -> match check_hpred hpred with let deref_err_list = list_fold_left (fun deref_errs hpred -> match check_hpred hpred with
| Some reason -> reason :: deref_errs | Some reason -> reason :: deref_errs
| None -> deref_errs | None -> deref_errs
) [] (Prop.get_sigma spec_pre) in ) [] (Prop.get_sigma spec_pre) in
match deref_err_list with match deref_err_list with
| [] -> None | [] -> None
| deref_err :: _ -> | deref_err :: _ ->
if !Config.angelic_execution then if !Config.angelic_execution then
(* In angelic mode, prefer to report Deref_null over other kinds of deref errors. this (* In angelic mode, prefer to report Deref_null over other kinds of deref errors. this
* makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET * makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET
* whenever possible *) * whenever possible *)
(* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *) (* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *)
Some Some
(try (try
list_find list_find
(fun err -> match err with (fun err -> match err with
| (Deref_null _, _) -> true | (Deref_null _, _) -> true
| _ -> false ) | _ -> false )
deref_err_list deref_err_list
with Not_found -> deref_err) with Not_found -> deref_err)
else Some deref_err else Some deref_err
let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list = let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list =
@ -313,8 +313,8 @@ let check_path_errors_in_post caller_pname post post_path =
list_iter check_attr (Prop.get_all_attributes post) list_iter check_attr (Prop.get_all_attributes post)
(** Post process the instantiated post after the function call so that (** Post process the instantiated post after the function call so that
x.f |-> se becomes x |-> \{ f: se \}. x.f |-> se becomes x |-> \{ f: se \}.
Also, update any Aresource attributes to refer to the caller *) Also, update any Aresource attributes to refer to the caller *)
let post_process_post let post_process_post
caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) = caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) =
let actual_pre_has_freed_attribute e = match Prop.get_resource_undef_attribute actual_pre e with let actual_pre_has_freed_attribute e = match Prop.get_resource_undef_attribute actual_pre e with
@ -323,7 +323,7 @@ let post_process_post
let atom_update_alloc_attribute = function let atom_update_alloc_attribute = function
| Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra)))) | Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))))
| Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))), e) | Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))), e)
when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *) when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find post e in let vpath, _ = Errdesc.vpath_find post e in
let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in
let c = Sil.Const (Sil.Cattribute (Sil.Aresource ra')) in let c = Sil.Const (Sil.Cattribute (Sil.Aresource ra')) in
@ -360,9 +360,9 @@ let rec fsel_star_fld fsel1 fsel2 = match fsel1, fsel2 with
| fsel1,[] -> fsel1 | fsel1,[] -> fsel1
| (f1, se1):: fsel1', (f2, se2):: fsel2' -> | (f1, se1):: fsel1', (f2, se2):: fsel2' ->
(match Ident.fieldname_compare f1 f2 with (match Ident.fieldname_compare f1 f2 with
| 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' | 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2'
| n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2 | n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2
| _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2') | _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2')
and array_content_star se1 se2 = and array_content_star se1 se2 =
try sexp_star_fld se1 se2 with try sexp_star_fld se1 se2 with
@ -374,11 +374,11 @@ and esel_star_fld esel1 esel2 = match esel1, esel2 with
| esel1,[] -> esel1 | esel1,[] -> esel1
| (e1, se1):: esel1', (e2, se2):: esel2' -> | (e1, se1):: esel1', (e2, se2):: esel2' ->
(match Sil.exp_compare e1 e2 with (match Sil.exp_compare e1 e2 with
| 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' | 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2'
| n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2 | n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2
| _ -> | _ ->
let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *) let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *)
(e2, se2') :: esel_star_fld esel1 esel2') (e2, se2') :: esel_star_fld esel1 esel2')
and sexp_star_fld se1 se2 : Sil.strexp = and sexp_star_fld se1 se2 : Sil.strexp =
(* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *) (* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *)
@ -416,8 +416,8 @@ let texp_star texp1 texp2 =
let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred = let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred =
match hpred1, hpred2 with match hpred1, hpred2 with
| Sil.Hpointsto(e1, se1, t1), Sil.Hpointsto(_, se2, t2) -> | Sil.Hpointsto(e1, se1, t1), Sil.Hpointsto(_, se2, t2) ->
(* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2;
L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *)
Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star t1 t2) Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star t1 t2)
| _ -> assert false | _ -> assert false
@ -440,10 +440,10 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
in in
try star sigma1 sigma2 try star sigma1 sigma2
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
L.d_str "cannot star "; L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2; Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2;
L.d_ln (); L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
let hpred_typing_lhs_compare hpred1 (e2, te2) = match hpred1 with let hpred_typing_lhs_compare hpred1 (e2, te2) = match hpred1 with
| Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2 | Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2
@ -474,10 +474,10 @@ let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Sil.exp * Sil.exp) lis
end in end in
try star sigma1 typings2 try star sigma1 typings2
with exn when exn_not_timeout exn -> with exn when exn_not_timeout exn ->
L.d_str "cannot star "; L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2; Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2;
L.d_ln (); L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
end end
else sigma1 else sigma1
@ -489,7 +489,7 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne
let fav = Prop.sigma_fav [hpred] in let fav = Prop.sigma_fav [hpred] in
(* TODO (t4893479): make this check less angelic *) (* TODO (t4893479): make this check less angelic *)
if Sil.fav_exists fav if Sil.fav_exists fav
(fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution) (fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution)
then begin then begin
L.d_warning "found hpred with non-footprint variable, dropping the spec"; L.d_ln (); Sil.d_hpred hpred; L.d_ln (); L.d_warning "found hpred with non-footprint variable, dropping the spec"; L.d_ln (); Sil.d_hpred hpred; L.d_ln ();
None None
@ -519,8 +519,8 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne
(** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *) (** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *)
let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
| Sil.Aresource ({ Sil.ra_kind = Sil.Racquire; Sil.ra_res = Sil.Rmemory mk_old } as ra_old), | Sil.Aresource ({ Sil.ra_kind = Sil.Racquire; Sil.ra_res = Sil.Rmemory mk_old } as ra_old),
Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new) Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new)
when Sil.mem_kind_compare mk_old mk_new <> 0 -> when Sil.mem_kind_compare mk_old mk_new <> 0 ->
let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in
raise (Exceptions.Deallocation_mismatch (desc, try assert false with Assert_failure x -> x)) raise (Exceptions.Deallocation_mismatch (desc, try assert false with Assert_failure x -> x))
| _ -> () | _ -> ()
@ -573,7 +573,7 @@ let lookup_global_errors prop =
let rec search_error = function let rec search_error = function
| [] -> None | [] -> None
| Sil.Hpointsto (Sil.Lvar var, Sil.Eexp (Sil.Const (Sil.Cstr str), _), _) :: tl | Sil.Hpointsto (Sil.Lvar var, Sil.Eexp (Sil.Const (Sil.Cstr str), _), _) :: tl
when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str) when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str)
| _ :: tl -> search_error tl in | _ :: tl -> search_error tl in
search_error (Prop.get_sigma prop) search_error (Prop.get_sigma prop)
@ -622,22 +622,22 @@ let combine
let posts' = let posts' =
if !Config.footprint && posts = [] if !Config.footprint && posts = []
then (* in case of divergence, produce a prop *) then (* in case of divergence, produce a prop *)
(* with updated footprint and inconsistent current *) (* with updated footprint and inconsistent current *)
[(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)] [(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)]
else else
list_map list_map
(fun (p, path_post) -> (fun (p, path_post) ->
(p, (p,
Paths.Path.add_call Paths.Path.add_call
(include_subtrace callee_pname) (include_subtrace callee_pname)
path_pre path_pre
callee_pname callee_pname
path_post)) path_post))
posts in posts in
list_map list_map
(fun (p, path) -> (fun (p, path) ->
(post_process_post (post_process_post
caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path))) caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path)))
posts' in posts' in
L.d_increase_indent 1; L.d_increase_indent 1;
L.d_strln "New footprint:"; Prop.d_pi_sigma new_footprint_pi new_footprint_sigma; L.d_ln (); L.d_strln "New footprint:"; Prop.d_pi_sigma new_footprint_pi new_footprint_sigma; L.d_ln ();
@ -695,7 +695,7 @@ let combine
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
Prop.conjoin_eq e' (Sil.Var (list_hd ret_ids)) p Prop.conjoin_eq e' (Sil.Var (list_hd ret_ids)) p
| Sil.Hpointsto (e, Sil.Estruct (ftl, _), t) | Sil.Hpointsto (e, Sil.Estruct (ftl, _), t)
when list_length ftl = list_length ret_ids -> when list_length ftl = list_length ret_ids ->
let rec do_ftl_ids p = function let rec do_ftl_ids p = function
| [], [] -> p | [], [] -> p
| (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' -> | (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' ->
@ -715,15 +715,15 @@ let combine
post_p4 in post_p4 in
let _results = list_map (fun (p, path) -> (compute_result p, path)) instantiated_post in let _results = list_map (fun (p, path) -> (compute_result p, path)) instantiated_post in
if list_exists (fun (x, _) -> x = None) _results then (* at least one combine failed *) if list_exists (fun (x, _) -> x = None) _results then (* at least one combine failed *)
None None
else else
let results = list_map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in let results = list_map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in
print_results actual_pre (list_map fst results); print_results actual_pre (list_map fst results);
Some results Some results
(** Construct the actual precondition: add to the current state a copy (** Construct the actual precondition: add to the current state a copy
of the (callee's) formal parameters instantiated with the actual of the (callee's) formal parameters instantiated with the actual
parameters. *) parameters. *)
let mk_actual_precondition prop actual_params formal_params = let mk_actual_precondition prop actual_params formal_params =
let formals_actuals = let formals_actuals =
let rec comb fpars apars = match fpars, apars with let rec comb fpars apars = match fpars, apars with
@ -731,7 +731,7 @@ let mk_actual_precondition prop actual_params formal_params =
| [], _ -> | [], _ ->
if apars != [] then if apars != [] then
(let str = "more actual pars than formal pars in fun call (" ^ string_of_int (list_length actual_params) ^ " vs " ^ string_of_int (list_length formal_params) ^ ")" in (let str = "more actual pars than formal pars in fun call (" ^ string_of_int (list_length actual_params) ^ " vs " ^ string_of_int (list_length formal_params) ^ ")" in
L.d_warning str; L.d_ln ()); L.d_warning str; L.d_ln ());
[] []
| _:: _,[] -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in | _:: _,[] -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in
comb formal_params actual_params in comb formal_params actual_params in
@ -759,11 +759,11 @@ let rec get_taint_untaint pi =
| Sil.Aneq (e1, e2):: pi' -> | Sil.Aneq (e1, e2):: pi' ->
let p = Prop.replace_pi pi Prop.prop_emp in let p = Prop.replace_pi pi Prop.prop_emp in
(match Prop.get_taint_attribute p e1, Prop.get_taint_attribute p e2 with (match Prop.get_taint_attribute p e1, Prop.get_taint_attribute p e2 with
| Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u') | Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u')
| Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u') | Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u')
| _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u') | _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u')
| _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u') | _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u')
| _, _ -> get_taint_untaint pi') | _, _ -> get_taint_untaint pi')
| _ :: pi' -> get_taint_untaint pi' | _ :: pi' -> get_taint_untaint pi'
(* perform the taint analysis check *) (* perform the taint analysis check *)
@ -783,16 +783,16 @@ let do_taint_check caller_pname actual_pre missing_pi missing_sigma sub1 sub2 =
match intersection_taint_untaint taint2 untaint2 with match intersection_taint_untaint taint2 untaint2 with
| None -> L.d_str "^^^^^^NO TAINT ERROR" | None -> L.d_str "^^^^^^NO TAINT ERROR"
| Some e -> begin | Some e -> begin
L.d_str "^^^^^ERROR in TAINT ANALYSIS: "; L.d_str "^^^^^ERROR in TAINT ANALYSIS: ";
let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with
| Some (pv, _) -> Sil.Lvar pv | Some (pv, _) -> Sil.Lvar pv
| None -> e in | None -> e in
let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in
let exn = let exn =
Exceptions.Tainted_value_reaching_sensitive_function Exceptions.Tainted_value_reaching_sensitive_function
(err_desc, try assert false with Assert_failure x -> x) in (err_desc, try assert false with Assert_failure x -> x) in
Reporting.log_warning caller_pname exn Reporting.log_warning caller_pname exn
end end
let class_cast_exn pname_opt texp1 texp2 exp ml_location = let class_cast_exn pname_opt texp1 texp2 exp ml_location =
let desc = Errdesc.explain_class_cast_exception pname_opt texp1 texp2 exp (State.get_node ()) (State.get_loc ()) in let desc = Errdesc.explain_class_cast_exception pname_opt texp1 texp2 exp (State.get_node ()) (State.get_loc ()) in
@ -816,30 +816,30 @@ let exe_spec
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
let posts = let posts =
match ret_ids with match ret_ids with
| [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java -> | [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java ->
(* if we have seen a previous call to the same function, only use specs whose return value (* if we have seen a previous call to the same function, only use specs whose return value
is consistent with constraints on the return value of the previous call w.r.t to nullness. is consistent with constraints on the return value of the previous call w.r.t to nullness.
meant to eliminate false NPE warnings from the common "if (get() != null) get().something()" meant to eliminate false NPE warnings from the common "if (get() != null) get().something()"
pattern *) pattern *)
let last_call_ret_non_null = let last_call_ret_non_null =
list_exists
(fun (exp, attr) ->
match attr with
| Sil.Aretval pname when Procname.equal callee_pname pname ->
Prover.check_disequal prop exp Sil.exp_zero
| _ -> false)
(Prop.get_all_attributes prop) in
if last_call_ret_non_null then
let returns_null prop =
list_exists list_exists
(function (fun (exp, attr) ->
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar -> match attr with
Prover.check_equal (Prop.normalize prop) e Sil.exp_zero | Sil.Aretval pname when Procname.equal callee_pname pname ->
| _ -> false) Prover.check_disequal prop exp Sil.exp_zero
(Prop.get_sigma prop) in | _ -> false)
list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts (Prop.get_all_attributes prop) in
else spec.Specs.posts if last_call_ret_non_null then
| _ -> spec.Specs.posts in let returns_null prop =
list_exists
(function
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar ->
Prover.check_equal (Prop.normalize prop) e Sil.exp_zero
| _ -> false)
(Prop.get_sigma prop) in
list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts
else spec.Specs.posts
| _ -> spec.Specs.posts in
let actual_pre = mk_actual_precondition prop actual_params formal_params in let actual_pre = mk_actual_precondition prop actual_params formal_params in
let spec_pre = Specs.Jprop.to_prop spec.Specs.pre in let spec_pre = Specs.Jprop.to_prop spec.Specs.pre in
L.d_strln ("EXECUTING SPEC " ^ string_of_int n ^ "/" ^ string_of_int nspecs); L.d_strln ("EXECUTING SPEC " ^ string_of_int n ^ "/" ^ string_of_int nspecs);
@ -862,19 +862,19 @@ let exe_spec
(split, norm_missing_pi, norm_missing_sigma) in (split, norm_missing_pi, norm_missing_sigma) in
let report_valid_res split norm_missing_pi norm_missing_sigma = let report_valid_res split norm_missing_pi norm_missing_sigma =
match combine match combine
cfg ret_ids posts cfg ret_ids posts
actual_pre path_pre split actual_pre path_pre split
caller_pdesc callee_pname loc with caller_pdesc callee_pname loc with
| None -> Invalid_res Cannot_combine | None -> Invalid_res Cannot_combine
| Some results -> | Some results ->
let inconsistent_results, consistent_results = let inconsistent_results, consistent_results =
list_partition (fun (p, _) -> Prover.check_inconsistency p) results in list_partition (fun (p, _) -> Prover.check_inconsistency p) results in
let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in
Valid_res { incons_pre_missing = incons_pre_missing; Valid_res { incons_pre_missing = incons_pre_missing;
vr_pi = norm_missing_pi; vr_pi = norm_missing_pi;
vr_sigma = norm_missing_sigma; vr_sigma = norm_missing_sigma;
vr_cons_res = consistent_results; vr_cons_res = consistent_results;
vr_incons_res = inconsistent_results } in vr_incons_res = inconsistent_results } in
begin begin
list_iter log_check_exn checks; list_iter log_check_exn checks;
if (!Config.taint_analysis && !Config.developer_mode) then if (!Config.taint_analysis && !Config.developer_mode) then
@ -889,8 +889,8 @@ let exe_spec
| [] -> None | [] -> None
| (_, p):: l -> | (_, p):: l ->
(match join_paths l with (match join_paths l with
| None -> Some p | None -> Some p
| Some p' -> Some (Paths.Path.join p p')) in | Some p' -> Some (Paths.Path.join p p')) in
let pjoin = join_paths posts in (* join the paths from the posts *) let pjoin = join_paths posts in (* join the paths from the posts *)
Invalid_res (Dereference_error (deref_error, desc, pjoin)) Invalid_res (Dereference_error (deref_error, desc, pjoin))
| None -> | None ->
@ -925,7 +925,7 @@ let remove_constant_string_class prop =
Prop.normalize prop' Prop.normalize prop'
(** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths (** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths
and remove pointsto's whose lhs is a constant string *) and remove pointsto's whose lhs is a constant string *)
let quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t = let quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let fav = Prop.prop_fav prop in let fav = Prop.prop_fav prop in
Sil.fav_filter_ident fav Ident.is_path; Sil.fav_filter_ident fav Ident.is_path;
@ -943,7 +943,7 @@ let prop_pure_to_footprint (p: 'a Prop.t) : Prop.normal Prop.t =
if new_footprint_atoms == [] if new_footprint_atoms == []
then p then p
else (** add pure fact to footprint *) else (** add pure fact to footprint *)
Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p) Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p)
(** check whether 0|->- occurs in sigma *) (** check whether 0|->- occurs in sigma *)
let sigma_has_null_pointer sigma = let sigma_has_null_pointer sigma =
@ -976,62 +976,62 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
if !Config.footprint then if !Config.footprint then
begin begin
if valid_res_cons_pre_missing == [] then (* no valid results where actual pre and missing are consistent *) if valid_res_cons_pre_missing == [] then (* no valid results where actual pre and missing are consistent *)
begin begin
if deref_errors <> [] then (* dereference error detected *) if deref_errors <> [] then (* dereference error detected *)
let extend_path path_opt path_pos_opt = match path_opt with let extend_path path_opt path_pos_opt = match path_opt with
| None -> () | None -> ()
| Some path_post -> | Some path_post ->
let old_path, _ = State.get_path () in let old_path, _ = State.get_path () in
let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in
State.set_path new_path path_pos_opt in State.set_path new_path path_pos_opt in
match list_hd deref_errors with match list_hd deref_errors with
| Dereference_error (Deref_minusone, desc, path_opt) -> | Dereference_error (Deref_minusone, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None; extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x)) raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_null pos, desc, path_opt) -> | Dereference_error (Deref_null pos, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos); extend_path path_opt (Some pos);
if Localise.is_parameter_not_null_checked_desc desc then if Localise.is_parameter_not_null_checked_desc desc then
raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x)) raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x))
else if Localise.is_field_not_null_checked_desc desc then else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x)) raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x))
else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x)) else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_freed ra, desc, path_opt) -> | Dereference_error (Deref_freed ra, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None; extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x)) raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) -> | Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x))
| Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false
else (* no dereference error detected *)
let desc =
if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if list_exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos); raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x))
raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x)) end
| Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false
else (* no dereference error detected *)
let desc =
if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if list_exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met;
raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x))
end
else (* combine the valid results, and store diverging states *) else (* combine the valid results, and store diverging states *)
let process_valid_res vr = let process_valid_res vr =
let save_diverging_states () = let save_diverging_states () =
if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *) if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *)
let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in
State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in
save_diverging_states (); save_diverging_states ();
vr.vr_cons_res in vr.vr_cons_res in
list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res)) list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res))
end end
else if valid_res_no_miss_pi != [] then else if valid_res_no_miss_pi != [] then
list_flatten (list_map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi) list_flatten (list_map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
@ -1060,20 +1060,20 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
!Config.idempotent_getters && !Sil.curr_language = Sil.Java && is_likely_getter callee_pname in !Config.idempotent_getters && !Sil.curr_language = Sil.Java && is_likely_getter callee_pname in
match ret_ids with match ret_ids with
| [ret_id] when should_add_ret_attr ()-> | [ret_id] when should_add_ret_attr ()->
(* add attribute to remember what function call a return id came from *) (* add attribute to remember what function call a return id came from *)
let ret_var = Sil.Var ret_id in let ret_var = Sil.Var ret_id in
let mark_id_as_retval (p, path) = let mark_id_as_retval (p, path) =
(* check if the retval already has an important resource that should not be overwritten *) (* check if the retval already has an important resource that should not be overwritten *)
let has_important_resource_attr = let has_important_resource_attr =
match Prop.get_resource_undef_attribute p ret_var with match Prop.get_resource_undef_attribute p ret_var with
| Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true | Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true
| _ -> false in | _ -> false in
if has_important_resource_attr then p, path if has_important_resource_attr then p, path
else else
let check_attr_change att_old att_new = () in let check_attr_change att_old att_new = () in
let att_retval = Sil.Aretval callee_pname in let att_retval = Sil.Aretval callee_pname in
Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in
list_map mark_id_as_retval res list_map mark_id_as_retval res
| _ -> res | _ -> res
(** Execute the function call and return the list of results with return value *) (** Execute the function call and return the list of results with return value *)

106
infer/src/backend/type_prop.ml
Unescape View File

@ -29,7 +29,7 @@ sig
type context type context
type field_context type field_context
val collect_items : Exe_env.t -> Cfg.cfg -> Sil.tenv -> t -> map -> val collect_items : Exe_env.t -> Cfg.cfg -> Sil.tenv -> t -> map ->
context -> field_context -> context * field_context * map * ret_t list context -> field_context -> context * field_context * map * ret_t list
val to_t : ret_t -> t val to_t : ret_t -> t
val save_items_to_set : bool val save_items_to_set : bool
val t_to_string : t -> string val t_to_string : t -> string
@ -44,7 +44,7 @@ end
(* updating the map, add nodes for which the map changed back to TODO. 4. *) (* updating the map, add nodes for which the map changed back to TODO. 4. *)
(* Until the set is empty. *) (* Until the set is empty. *)
module Control_flow = module Control_flow =
functor (TM : TODO_MAP) -> functor (TM : TODO_MAP) ->
struct struct
let set_to_string set = let set_to_string set =
@ -112,8 +112,8 @@ struct
| [] -> "" | [] -> ""
| [s, typ] -> | [s, typ] ->
(match string_typ_to_string (s, typ) with (match string_typ_to_string (s, typ) with
| Some s -> s | Some s -> s
| None -> "") | None -> "")
| (s, typ):: rest -> | (s, typ):: rest ->
match string_typ_to_string (s, typ) with match string_typ_to_string (s, typ) with
| Some s -> s^", "^(type_signature_to_string rest) | Some s -> s^", "^(type_signature_to_string rest)
@ -203,9 +203,9 @@ struct
let print_stack stack = let print_stack stack =
let aux (typ, var_kind, level) = let aux (typ, var_kind, level) =
print_endline ( print_endline (
(string_of_int level)^":"^ (string_of_int level)^":"^
(Sil.typ_to_string typ)^"-"^ (Sil.typ_to_string typ)^"-"^
(var_kind_to_string var_kind)) in (var_kind_to_string var_kind)) in
Stack.iter aux stack Stack.iter aux stack
let print_map_value map_value = let print_map_value map_value =
@ -247,11 +247,11 @@ struct
let new_map_value = { map_value with type_stack = stack } in let new_map_value = { map_value with type_stack = stack } in
Map.add var new_map_value context Map.add var new_map_value context
with Not_found -> with Not_found ->
let var_kind = typ_to_var_kind new_typ in let var_kind = typ_to_var_kind new_typ in
let stack = Stack.create () in let stack = Stack.create () in
let _ = Stack.push (new_typ, var_kind, curr_level) stack in let _ = Stack.push (new_typ, var_kind, curr_level) stack in
let map_value = { var_level = curr_level; type_stack = stack } in let map_value = { var_level = curr_level; type_stack = stack } in
Map.add var map_value context Map.add var map_value context
(* Adds a type to a path starting from a variable. It replaces the top *) (* Adds a type to a path starting from a variable. It replaces the top *)
(* of the stack if the level if the same as the current level, or it *) (* of the stack if the level if the same as the current level, or it *)
@ -297,10 +297,10 @@ struct
with Not_found -> assert false in with Not_found -> assert false in
match Stack.top map_value.type_stack with match Stack.top map_value.type_stack with
| (typ, var_kind, level) -> | (typ, var_kind, level) ->
(* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *) (* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *)
(* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *) (* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *)
(* var_kind); print_string "the path is "; print_endline *) (* var_kind); print_string "the path is "; print_endline *)
(* (Utils.list_to_string Ident.fieldname_to_string path); *) (* (Utils.list_to_string Ident.fieldname_to_string path); *)
get_type_var_kind tenv typ path var_kind get_type_var_kind tenv typ path var_kind
end end
@ -317,8 +317,8 @@ let rec super tenv t =
| Sil.Tptr (dom_type, p) -> | Sil.Tptr (dom_type, p) ->
let super_dom_type = super tenv dom_type in let super_dom_type = super tenv dom_type in
(match super_dom_type with (match super_dom_type with
| None -> None | None -> None
| Some super -> Some (Sil.Tptr (super, p))) | Some super -> Some (Sil.Tptr (super, p)))
| _ -> None | _ -> None
let rec lub tenv t1 t2 = let rec lub tenv t1 t2 =
@ -444,20 +444,20 @@ struct
match exp with match exp with
| Sil.Var id -> | Sil.Var id ->
(match get_id_exptyp id id_context with (match get_id_exptyp id id_context with
| Exp exp -> aux exp | Exp exp -> aux exp
| Typ typ -> typ) | Typ typ -> typ)
| Sil.UnOp (unop, exp, typ) -> aux exp | Sil.UnOp (unop, exp, typ) -> aux exp
| Sil.BinOp (binop, exp1, exp2) -> aux exp1 | Sil.BinOp (binop, exp1, exp2) -> aux exp1
| Sil.Const const -> get_const_type const | Sil.Const const -> get_const_type const
| Sil.Cast (typ, exp) -> typ | Sil.Cast (typ, exp) -> typ
| Sil.Lfield (e, fld, typ) -> | Sil.Lfield (e, fld, typ) ->
(try Field_context.Map.find fld field_context (try Field_context.Map.find fld field_context
with Not_found -> retrieve_type tenv fld typ) with Not_found -> retrieve_type tenv fld typ)
| Sil.Lindex (Sil.Var id, i) -> | Sil.Lindex (Sil.Var id, i) ->
(match get_id_exptyp id id_context with (match get_id_exptyp id id_context with
| Exp (Sil.Lvar pvar) -> | Exp (Sil.Lvar pvar) ->
Context_map.get_type_content tenv pvar [] context Context_map.get_type_content tenv pvar [] context
| _ -> assert false) | _ -> assert false)
| Sil.Sizeof (typ, sub) -> assert false | Sil.Sizeof (typ, sub) -> assert false
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
Context_map.get_type pvar context Context_map.get_type pvar context
@ -488,8 +488,8 @@ struct
let pred = let pred =
try list_find (fun p -> not (Set.mem p set)) preds try list_find (fun p -> not (Set.mem p set)) preds
with Not_found -> with Not_found ->
try list_hd preds try list_hd preds
with Failure "hd" -> Set.min_elt set in with Failure "hd" -> Set.min_elt set in
(aux pred) in (aux pred) in
if (Set.mem old_node set) then backtrack () if (Set.mem old_node set) then backtrack ()
else else
@ -500,8 +500,8 @@ struct
node in node in
match el with match el with
| Some old_node -> | Some old_node ->
(* print_endline "choosing an element when old_element is "; *) (* print_endline "choosing an element when old_element is "; *)
(* print_endline (t_to_string old_node); *) (* print_endline (t_to_string old_node); *)
aux old_node aux old_node
| None -> choose_start_node () | None -> choose_start_node ()
@ -532,23 +532,23 @@ struct
let exp_typ = get_type tenv exp id_context context field_context in let exp_typ = get_type tenv exp id_context context field_context in
let context, field_context = let context, field_context =
(match exp1 with (match exp1 with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
(* print_endline ("trying to add variable "^(Context_map.key_to_string *) (* print_endline ("trying to add variable "^(Context_map.key_to_string *)
(* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *) (* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *)
(* print_endline "Context"; Context_map.print_map context; *) (* print_endline "Context"; Context_map.print_map context; *)
Context_map.add_type pvar exp_typ 0 context, field_context Context_map.add_type pvar exp_typ 0 context, field_context
| Sil.Lfield (e, fld, typ) -> | Sil.Lfield (e, fld, typ) ->
context, Field_context.add_type tenv fld exp_typ field_context context, Field_context.add_type tenv fld exp_typ field_context
| Sil.Lindex (Sil.Var id, _) -> | Sil.Lindex (Sil.Var id, _) ->
(match get_id_exptyp id id_context with (match get_id_exptyp id id_context with
| Exp (Sil.Lvar pvar) -> | Exp (Sil.Lvar pvar) ->
Context_map.add_type_content pvar [] exp_typ 0 context, field_context Context_map.add_type_content pvar [] exp_typ 0 context, field_context
| _ -> assert false) | _ -> assert false)
| _ -> assert false) in | _ -> assert false) in
id_context, context, field_context, map, list id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), actual_params, loc, call_flags) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), actual_params, loc, call_flags)
when not (SymExec.function_is_builtin callee_pname) -> when not (SymExec.function_is_builtin callee_pname) ->
(* TODO: constraint for virtual calls *) (* TODO: constraint for virtual calls *)
let cfg = let cfg =
if (Procname.Set.mem callee_pname !defined_methods) then if (Procname.Set.mem callee_pname !defined_methods) then
Exe_env.get_cfg exe_env callee_pname Exe_env.get_cfg exe_env callee_pname
@ -573,22 +573,22 @@ struct
id_context, context, field_context, map', list id_context, context, field_context, map', list
else id_context, context, field_context, map, list else id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), [(exp, class_type)], loc, call_flags) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), [(exp, class_type)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__new -> when Procname.equal callee_pname SymExec.ModelBuiltins.__new ->
let id_context = set_ids ret_ids class_type id_context in let id_context = set_ids ret_ids class_type id_context in
id_context, context, field_context, map, list id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(array_size, array_type)], loc, call_flags) [(array_size, array_type)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array -> when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array ->
let id_context = set_ids ret_ids array_type id_context in let id_context = set_ids ret_ids array_type id_context in
id_context, context, field_context, map, list id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags) [(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__cast -> when Procname.equal callee_pname SymExec.ModelBuiltins.__cast ->
let id_context = set_ids ret_ids typ id_context in let id_context = set_ids ret_ids typ id_context in
id_context, context, field_context, map, list id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags) [(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof -> when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof ->
let id_context = set_ids ret_ids (Sil.Tint Sil.IBool) id_context in let id_context = set_ids ret_ids (Sil.Tint Sil.IBool) id_context in
id_context, context, field_context, map, list id_context, context, field_context, map, list
| _ -> id_context, context, field_context, map, list in | _ -> id_context, context, field_context, map, list in
@ -710,8 +710,8 @@ let arg_desc =
let options_to_keep = ["-results_dir"] in let options_to_keep = ["-results_dir"] in
let filter arg_desc = let filter arg_desc =
list_filter (fun desc -> list_filter (fun desc ->
let (option_name, _, _, _) = desc in let (option_name, _, _, _) = desc in
list_mem string_equal option_name options_to_keep) list_mem string_equal option_name options_to_keep)
arg_desc in arg_desc in
let desc = (filter Utils.base_arg_desc) in let desc = (filter Utils.base_arg_desc) in
Utils.Arg2.create_options_desc false "Parsing Options" desc in Utils.Arg2.create_options_desc false "Parsing Options" desc in
@ -771,7 +771,7 @@ let load_cg_files _exe_env (source_dirs : DB.source_dir list) =
match Exe_env.add_cg _exe_env source_dir with match Exe_env.add_cg _exe_env source_dir with
| None -> () | None -> ()
| Some cg -> | Some cg ->
(*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in (*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in
list_iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs; list_iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs;
let exe_env = Exe_env.freeze _exe_env in let exe_env = Exe_env.freeze _exe_env in
exe_env exe_env

302
infer/src/backend/utils.ml
Unescape View File

@ -96,8 +96,8 @@ let list_split =
| [] -> (acc1, acc2) | [] -> (acc1, acc2)
| (x, y):: l -> split (x:: acc1) (y:: acc2) l in | (x, y):: l -> split (x:: acc1) (y:: acc2) l in
fun l -> fun l ->
let acc1, acc2 = split [] [] l in let acc1, acc2 = split [] [] l in
list_rev acc1, list_rev acc2 list_rev acc1, list_rev acc2
(** Like List.mem but without builtin equality *) (** Like List.mem but without builtin equality *)
let list_mem equal x l = list_exists (equal x) l let list_mem equal x l = list_exists (equal x) l
@ -309,7 +309,7 @@ let pe_extend_colormap pe (x: Obj.t) (c: color) =
{ pe with pe_cmap_norm = colormap } { pe with pe_cmap_norm = colormap }
(** Set the object substitution, which is supposed to preserve the type. (** Set the object substitution, which is supposed to preserve the type.
Currently only used for a map from (identifier) expressions to the program var containing them *) Currently only used for a map from (identifier) expressions to the program var containing them *)
let pe_set_obj_sub pe (sub: 'a -> 'a) = let pe_set_obj_sub pe (sub: 'a -> 'a) =
let new_obj_sub x = let new_obj_sub x =
let x' = Obj.repr (sub (Obj.obj x)) in let x' = Obj.repr (sub (Obj.obj x)) in
@ -351,10 +351,10 @@ let rec _pp_semicolon_seq oneline pe pp f =
| [x] -> F.fprintf f "%a" pp x | [x] -> F.fprintf f "%a" pp x
| x:: l -> | x:: l ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> | PP_TEXT | PP_HTML ->
F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l) F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l)
(** Print a ;-separated sequence with newlines. *) (** Print a ;-separated sequence with newlines. *)
let pp_semicolon_seq pe = _pp_semicolon_seq false pe let pp_semicolon_seq pe = _pp_semicolon_seq false pe
@ -368,12 +368,12 @@ let rec pp_or_seq pe pp f = function
| [x] -> F.fprintf f "%a" pp x | [x] -> F.fprintf f "%a" pp x
| x:: l -> | x:: l ->
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT -> | PP_TEXT ->
F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l
| PP_HTML -> | PP_HTML ->
F.fprintf f "%a &or; %a" pp x (pp_semicolon_seq pe pp) l F.fprintf f "%a &or; %a" pp x (pp_semicolon_seq pe pp) l
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l) F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l)
(** Produce a string from a 1-argument pretty printer function *) (** Produce a string from a 1-argument pretty printer function *)
let pp_to_string pp x = let pp_to_string pp x =
@ -634,19 +634,19 @@ let copy_file fname_from fname_to =
None None
module FileLOC = (** count lines of code of files and keep processed results in a cache *) module FileLOC = (** count lines of code of files and keep processed results in a cache *)
struct struct
let include_loc_hash = Hashtbl.create 1 let include_loc_hash = Hashtbl.create 1
let reset () = Hashtbl.clear include_loc_hash let reset () = Hashtbl.clear include_loc_hash
let file_get_loc fname = let file_get_loc fname =
try Hashtbl.find include_loc_hash fname with Not_found -> try Hashtbl.find include_loc_hash fname with Not_found ->
let loc = match read_file fname with let loc = match read_file fname with
| None -> 0 | None -> 0
| Some l -> list_length l in | Some l -> list_length l in
Hashtbl.add include_loc_hash fname loc; Hashtbl.add include_loc_hash fname loc;
loc loc
end end
(** type for files used for printing *) (** type for files used for printing *)
type outfile = type outfile =
@ -661,8 +661,8 @@ let create_outfile fname =
let fmt = F.formatter_of_out_channel out_c in let fmt = F.formatter_of_out_channel out_c in
Some { fname = fname; out_c = out_c; fmt = fmt } Some { fname = fname; out_c = out_c; fmt = fmt }
with Sys_error _ -> with Sys_error _ ->
F.fprintf F.err_formatter "error: cannot create file %s@." fname; F.fprintf F.err_formatter "error: cannot create file %s@." fname;
None None
(** operate on an outfile reference if it is not None *) (** operate on an outfile reference if it is not None *)
let do_outf outf_ref f = let do_outf outf_ref f =
@ -769,63 +769,63 @@ let filename_to_relative root fname =
let base_arg_desc = let base_arg_desc =
[ [
"-results_dir", "-results_dir",
Arg.String (fun s -> Config.results_dir := s), Arg.String (fun s -> Config.results_dir := s),
Some "dir", Some "dir",
"set the project results directory (default dir=" ^ Config.default_results_dir ^ ")"; "set the project results directory (default dir=" ^ Config.default_results_dir ^ ")";
"-coverage", "-coverage",
Arg.Unit (fun () -> Config.worklist_mode:= 2), Arg.Unit (fun () -> Config.worklist_mode:= 2),
None, None,
"analysis mode to maximize coverage (can take longer)"; "analysis mode to maximize coverage (can take longer)";
"-lib", "-lib",
Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library), Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library),
Some "dir", Some "dir",
"add dir to the list of directories to be searched for spec files"; "add dir to the list of directories to be searched for spec files";
"-models", "-models",
Arg.String (fun s -> Config.add_models (filename_to_absolute s)), Arg.String (fun s -> Config.add_models (filename_to_absolute s)),
Some "zip file", Some "zip file",
"add a zip file containing the models"; "add a zip file containing the models";
"-ziplib", "-ziplib",
Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)), Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)),
Some "zip file", Some "zip file",
"add a zip file containing library spec files"; "add a zip file containing library spec files";
"-project_root", "-project_root",
Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)), Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)),
Some "dir", Some "dir",
"root directory of the project"; "root directory of the project";
"-infer_cache", "-infer_cache",
Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)), Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)),
Some "dir", Some "dir",
"Select a directory to contain the infer cache"; "Select a directory to contain the infer cache";
] ]
let reserved_arg_desc = let reserved_arg_desc =
[ [
"-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)"; "-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)";
"-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)"; "-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)";
"-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)"; "-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)";
"-developer_mode", Arg.Set Config.developer_mode, None, "reserved"; "-developer_mode", Arg.Set Config.developer_mode, None, "reserved";
"-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory"; "-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory";
"-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first"; "-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first";
"-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory"; "-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory";
"-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)"; "-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)";
"-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction"; "-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction";
"-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)"; "-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)";
"-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props"; "-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props";
"-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs"; "-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs";
"-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off"; "-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off";
"-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing"; "-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing";
"-notest", Arg.Clear Config.test, None, "turn test mode off"; "-notest", Arg.Clear Config.test, None, "turn test mode off";
"-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)"; "-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)";
"-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase"; "-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions"; "-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions";
"-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument"; "-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument";
"-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)"; "-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)";
"-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation"; "-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation";
"-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join"; "-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join";
"-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement"; "-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement";
"-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first"; "-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first";
] ]
(**************** START MODULE Arg2 -- modified from Arg in the ocaml distribution ***************) (**************** START MODULE Arg2 -- modified from Arg in the ocaml distribution ***************)
@ -864,7 +864,7 @@ module Arg2 = struct
let print_spec buf (key, spec, doc) = let print_spec buf (key, spec, doc) =
match spec with match spec with
| Arg.Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) | Arg.Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l)
doc doc
| _ -> | _ ->
let sep = if String.length doc != 0 && String.get doc 0 = '=' then "" else " " in let sep = if String.length doc != 0 && String.get doc 0 = '=' then "" else " " in
bprintf buf " %s%s%s\n" key sep doc bprintf buf " %s%s%s\n" key sep doc
@ -875,11 +875,11 @@ module Arg2 = struct
let add1 = let add1 =
try ignore (assoc3 "-help" speclist); [] try ignore (assoc3 "-help" speclist); []
with Not_found -> with Not_found ->
["-help", Arg.Unit help_action, " Display this list of options"] ["-help", Arg.Unit help_action, " Display this list of options"]
and add2 = and add2 =
try ignore (assoc3 "--help" speclist); [] try ignore (assoc3 "--help" speclist); []
with Not_found -> with Not_found ->
["--help", Arg.Unit help_action, " Display this list of options"] ["--help", Arg.Unit help_action, " Display this list of options"]
in in
speclist @ (add1 @ add2) speclist @ (add1 @ add2)
@ -926,72 +926,72 @@ module Arg2 = struct
with Not_found -> stop (Unknown s) with Not_found -> stop (Unknown s)
in in
begin try begin try
let rec treat_action = function let rec treat_action = function
| Arg.Unit f -> f (); | Arg.Unit f -> f ();
| Arg.Bool f when !current + 1 < l -> | Arg.Bool f when !current + 1 < l ->
let arg = argv.(!current + 1) in let arg = argv.(!current + 1) in
begin try f (bool_of_string arg) begin try f (bool_of_string arg)
with Invalid_argument "bool_of_string" -> with Invalid_argument "bool_of_string" ->
raise (Stop (Wrong (s, arg, "a boolean"))) raise (Stop (Wrong (s, arg, "a boolean")))
end; end;
incr current;
| Arg.Set r -> r := true;
| Arg.Clear r -> r := false;
| Arg.String f when !current + 1 < l ->
f argv.(!current + 1);
incr current;
| Arg.Symbol (symb, f) when !current + 1 < l ->
let arg = argv.(!current + 1) in
if list_mem string_equal arg symb then begin
f argv.(!current + 1);
incr current; incr current;
end else begin | Arg.Set r -> r := true;
raise (Stop (Wrong (s, arg, "one of: " | Arg.Clear r -> r := false;
^ (make_symlist "" " " "" symb)))) | Arg.String f when !current + 1 < l ->
end
| Arg.Set_string r when !current + 1 < l ->
r := argv.(!current + 1);
incr current;
| Arg.Int f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Set_int r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Float f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Set_float r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Tuple specs ->
list_iter treat_action specs;
| Arg.Rest f ->
while !current < l - 1 do
f argv.(!current + 1); f argv.(!current + 1);
incr current; incr current;
done; | Arg.Symbol (symb, f) when !current + 1 < l ->
| _ -> raise (Stop (Missing s)) let arg = argv.(!current + 1) in
in if list_mem string_equal arg symb then begin
treat_action action f argv.(!current + 1);
with Bad m -> stop (Message m); incr current;
| Stop e -> stop e; end else begin
raise (Stop (Wrong (s, arg, "one of: "
^ (make_symlist "" " " "" symb))))
end
| Arg.Set_string r when !current + 1 < l ->
r := argv.(!current + 1);
incr current;
| Arg.Int f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Set_int r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Float f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Set_float r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Tuple specs ->
list_iter treat_action specs;
| Arg.Rest f ->
while !current < l - 1 do
f argv.(!current + 1);
incr current;
done;
| _ -> raise (Stop (Missing s))
in
treat_action action
with Bad m -> stop (Message m);
| Stop e -> stop e;
end; end;
incr current; incr current;
end else begin end else begin
@ -1117,8 +1117,8 @@ let join_strings sep = function
let next compare = let next compare =
fun x y n -> fun x y n ->
if n <> 0 then n if n <> 0 then n
else compare x y else compare x y
let directory_fold f init path = let directory_fold f init path =
@ -1130,7 +1130,7 @@ let directory_fold f init path =
else else
(f accu full_path, dirs) (f accu full_path, dirs)
with Sys_error _ -> with Sys_error _ ->
(accu, dirs) in (accu, dirs) in
let rec loop accu dirs = let rec loop accu dirs =
match dirs with match dirs with
| [] -> accu | [] -> accu
@ -1153,7 +1153,7 @@ let directory_iter f path =
let () = f full_path in let () = f full_path in
dirs dirs
with Sys_error _ -> with Sys_error _ ->
dirs in dirs in
let rec loop dirs = let rec loop dirs =
match dirs with match dirs with
| [] -> () | [] -> ()

20
infer/src/checkers/annotations.ml
Unescape View File

@ -40,9 +40,9 @@ let get_field_type_and_annotation fn = function
| Sil.Tptr (Sil.Tstruct (ftal, sftal, _, _, _, _, _), _) | Sil.Tptr (Sil.Tstruct (ftal, sftal, _, _, _, _, _), _)
| Sil.Tstruct (ftal, sftal, _, _, _, _, _) -> | Sil.Tstruct (ftal, sftal, _, _, _, _, _) ->
(try (try
let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in
Some (t, a) Some (t, a)
with Not_found -> None) with Not_found -> None)
| _ -> None | _ -> None
let ia_iter f = let ia_iter f =
@ -140,7 +140,7 @@ let ia_is ann ia = match ann with
type get_method_annotation = Procname.t -> Cfg.Procdesc.t -> Sil.method_annotation type get_method_annotation = Procname.t -> Cfg.Procdesc.t -> Sil.method_annotation
(** Get a method signature with annotations from a proc_name and proc_desc, (** Get a method signature with annotations from a proc_name and proc_desc,
or search in the .specs file if it is not defined in the proc_desc. *) or search in the .specs file if it is not defined in the proc_desc. *)
let get_annotated_signature get_method_annotation proc_desc proc_name : annotated_signature = let get_annotated_signature get_method_annotation proc_desc proc_name : annotated_signature =
let method_annotation = get_method_annotation proc_name proc_desc in let method_annotation = get_method_annotation proc_name proc_desc in
let formals = Cfg.Procdesc.get_formals proc_desc in let formals = Cfg.Procdesc.get_formals proc_desc in
@ -157,8 +157,8 @@ let get_annotated_signature get_method_annotation proc_desc proc_name : annotate
annotated_signature annotated_signature
(** Check if the annotated signature is for a wrapper of an anonymous inner class method. (** Check if the annotated signature is for a wrapper of an anonymous inner class method.
These wrappers have the same name as the original method, every type is Object, and the parameters These wrappers have the same name as the original method, every type is Object, and the parameters
are called x0, x1, x2. *) are called x0, x1, x2. *)
let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name = let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
let check_ret (ia, t) = let check_ret (ia, t) =
Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in
@ -188,10 +188,10 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
(** Check if the given parameter has a Nullable annotation in the given signature *) (** Check if the given parameter has a Nullable annotation in the given signature *)
let param_is_nullable pvar ann_sig = let param_is_nullable pvar ann_sig =
let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in
list_exists list_exists
(fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot) (fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot)
ann_sig.params ann_sig.params
(** Pretty print a method signature with annotations. *) (** Pretty print a method signature with annotations. *)
let pp_annotated_signature proc_name fmt annotated_signature = let pp_annotated_signature proc_name fmt annotated_signature =

44
infer/src/checkers/callbackChecker.ml
Unescape View File

@ -23,7 +23,7 @@ let get_fields_nullified procdesc =
(* walk through the instructions and look for instance fields that are assigned to null *) (* walk through the instructions and look for instance fields that are assigned to null *)
let collect_nullified_flds (nullified_flds, this_ids) _ = function let collect_nullified_flds (nullified_flds, this_ids) _ = function
| Sil.Set (Sil.Lfield (Sil.Var lhs, fld, _), typ, rhs, loc) | Sil.Set (Sil.Lfield (Sil.Var lhs, fld, _), typ, rhs, loc)
when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids -> when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids ->
(FldSet.add fld nullified_flds, this_ids) (FldSet.add fld nullified_flds, this_ids)
| Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs -> | Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs ->
(nullified_flds, IdSet.add id this_ids) (nullified_flds, IdSet.add id this_ids)
@ -44,12 +44,12 @@ let android_lifecycle_typs = ref []
let get_or_create_lifecycle_typs tenv = match !android_lifecycle_typs with let get_or_create_lifecycle_typs tenv = match !android_lifecycle_typs with
| [] -> | [] ->
let lifecycle_typs = list_fold_left (fun typs (pkg, clazz, methods) -> let lifecycle_typs = list_fold_left (fun typs (pkg, clazz, methods) ->
let qualified_name = Mangled.from_package_class pkg clazz in let qualified_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt match AndroidFramework.get_lifecycle_for_framework_typ_opt
qualified_name methods tenv with qualified_name methods tenv with
| Some (framework_typ, _) -> framework_typ :: typs | Some (framework_typ, _) -> framework_typ :: typs
| None -> typs | None -> typs
) [] AndroidFramework.get_lifecycles in ) [] AndroidFramework.get_lifecycles in
android_lifecycle_typs := lifecycle_typs; android_lifecycle_typs := lifecycle_typs;
lifecycle_typs lifecycle_typs
| typs -> typs | typs -> typs
@ -64,21 +64,21 @@ let done_checking num_methods =
!num_methods_checked = num_methods !num_methods_checked = num_methods
(** ask Eradicate to check each of the procs in [registered_callback_procs] (and their transitive (** ask Eradicate to check each of the procs in [registered_callback_procs] (and their transitive
* callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *) * callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *)
let do_eradicate_check all_procs get_procdesc idenv tenv = let do_eradicate_check all_procs get_procdesc idenv tenv =
(* tell Eradicate to treat each of the fields nullified in on_destroy as nullable *) (* tell Eradicate to treat each of the fields nullified in on_destroy as nullable *)
FldSet.iter (fun fld -> Models.Inference.field_add_nullable_annotation fld) !fields_nullified; FldSet.iter (fun fld -> Models.Inference.field_add_nullable_annotation fld) !fields_nullified;
Procname.Set.iter Procname.Set.iter
(fun proc_name -> (fun proc_name ->
match get_procdesc proc_name with match get_procdesc proc_name with
| Some proc_desc -> | Some proc_desc ->
do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc
| None -> ()) | None -> ())
!registered_callback_procs !registered_callback_procs
(** if [procname] belongs to an Android lifecycle type, save the set of callbacks registered in (** if [procname] belongs to an Android lifecycle type, save the set of callbacks registered in
* [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of * [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of
* fields that are nullified *) * fields that are nullified *)
let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc = let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc =
match Sil.get_typ (Mangled.from_string (Procname.java_get_class proc_name)) None tenv with match Sil.get_typ (Mangled.from_string (Procname.java_get_class proc_name)) None tenv with
| Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) -> | Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) ->
@ -93,15 +93,15 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
(* find the callbacks registered by this procedure and update the list *) (* find the callbacks registered by this procedure and update the list *)
let registered_callback_procs' = list_fold_left let registered_callback_procs' = list_fold_left
(fun callback_procs callback_typ -> (fun callback_procs callback_typ ->
match callback_typ with match callback_typ with
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) -> | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) ->
list_fold_left list_fold_left
(fun callback_procs callback_proc -> (fun callback_procs callback_proc ->
if Procname.is_constructor callback_proc then callback_procs if Procname.is_constructor callback_proc then callback_procs
else Procname.Set.add callback_proc callback_procs) else Procname.Set.add callback_proc callback_procs)
callback_procs callback_procs
methods methods
| typ -> callback_procs) | typ -> callback_procs)
!registered_callback_procs !registered_callback_procs
registered_callback_typs in registered_callback_typs in
registered_callback_procs := registered_callback_procs'; registered_callback_procs := registered_callback_procs';

136
infer/src/checkers/checkers.ml
Unescape View File

@ -18,7 +18,7 @@ let verbose = ref true
(** Convenience functions for chechers to print information *) (** Convenience functions for chechers to print information *)
module PP = struct module PP = struct
(** Print a range of lines of the source file in [loc], including [nbefore] lines before loc (** Print a range of lines of the source file in [loc], including [nbefore] lines before loc
and [nafter] lines after [loc] *) and [nafter] lines after [loc] *)
let pp_loc_range linereader nbefore nafter fmt loc = let pp_loc_range linereader nbefore nafter fmt loc =
let printline n = match Printer.LineReader.from_loc linereader { loc with Sil.line = n } with let printline n = match Printer.LineReader.from_loc linereader { loc with Sil.line = n } with
| Some s -> F.fprintf fmt "%s%s@\n" (if n = loc.Sil.line then "-->" else " ") s | Some s -> F.fprintf fmt "%s%s@\n" (if n = loc.Sil.line then "-->" else " ") s
@ -56,7 +56,7 @@ module ST = struct
let store_summary proc_name = let store_summary proc_name =
Option.may Option.may
(fun summary -> (fun summary ->
try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s) try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s)
(Specs.get_summary proc_name) (Specs.get_summary proc_name)
let report_error let report_error
@ -77,10 +77,10 @@ module ST = struct
let exn = exception_kind kind localized_description in let exn = exception_kind kind localized_description in
(* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be (* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be
suppressed with the following annotations: suppressed with the following annotations:
- @android.annotation.SuppressLint("checker-error-name") - @android.annotation.SuppressLint("checker-error-name")
- @some.PrefixErrorName - @some.PrefixErrorName
where the kind matching is case - insensitive and ignores '-' and '_' characters. *) where the kind matching is case - insensitive and ignores '-' and '_' characters. *)
let suppressed = let suppressed =
let annotation_matches a = let annotation_matches a =
let normalize str = let normalize str =
@ -106,19 +106,19 @@ module ST = struct
let is_field_suppressed = let is_field_suppressed =
match field_name, PatternMatch.get_this_type proc_desc with match field_name, PatternMatch.get_this_type proc_desc with
| Some field_name, Some t -> begin | Some field_name, Some t -> begin
match (Annotations.get_field_type_and_annotation field_name t) with match (Annotations.get_field_type_and_annotation field_name t) with
| Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches | Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false | None -> false
end end
| _ -> false in | _ -> false in
let is_class_suppressed = let is_class_suppressed =
match (PatternMatch.get_this_type proc_desc) with match (PatternMatch.get_this_type proc_desc) with
| Some t -> begin | Some t -> begin
match (PatternMatch.type_get_annotation t) with match (PatternMatch.type_get_annotation t) with
| Some ia -> Annotations.ia_has_annotation_with ia annotation_matches | Some ia -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false | None -> false
end end
| None -> false in | None -> false in
is_method_suppressed || is_field_suppressed || is_class_suppressed in is_method_suppressed || is_field_suppressed || is_class_suppressed in
@ -213,8 +213,8 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
let class_name = Procname.java_get_class proc_name in let class_name = Procname.java_get_class proc_name in
let method_name = Procname.java_get_method proc_name in let method_name = Procname.java_get_method proc_name in
(try (try
class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read") class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read")
with Invalid_argument _ -> false) with Invalid_argument _ -> false)
| _ -> assert false in | _ -> assert false in
let is_inverse rc wc = let is_inverse rc wc =
@ -256,9 +256,9 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
match parcel_constructors this_type with match parcel_constructors this_type with
| x :: xs -> | x :: xs ->
(match get_proc_desc x with (match get_proc_desc x with
| Some x_proc_desc -> | Some x_proc_desc ->
check x x_proc_desc proc_name proc_desc check x x_proc_desc proc_name proc_desc
| None -> raise Not_found) | None -> raise Not_found)
| _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name | _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name
with Not_found -> if !verbose then L.stdout "Methods not available@." with Not_found -> if !verbose then L.stdout "Methods not available@."
end end
@ -270,15 +270,15 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc
let verbose = ref false in let verbose = ref false in
let class_formal_names = lazy ( let class_formal_names = lazy (
let formals = Cfg.Procdesc.get_formals proc_desc in let formals = Cfg.Procdesc.get_formals proc_desc in
let class_formals = let class_formals =
let is_class_type = function let is_class_type = function
| "this", Sil.Tptr _ -> false (* no need to null check 'this' *) | "this", Sil.Tptr _ -> false (* no need to null check 'this' *)
| _, Sil.Tstruct _ -> true | _, Sil.Tstruct _ -> true
| _, Sil.Tptr (Sil.Tstruct _, _) -> true | _, Sil.Tptr (Sil.Tstruct _, _) -> true
| _ -> false in | _ -> false in
list_filter is_class_type formals in list_filter is_class_type formals in
list_map (fun (s, _) -> Mangled.from_string s) class_formals) in list_map (fun (s, _) -> Mangled.from_string s) class_formals) in
let equal_formal_param exp formal_name = match exp with let equal_formal_param exp formal_name = match exp with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
let name = Sil.pvar_get_name pvar in let name = Sil.pvar_get_name pvar in
@ -363,40 +363,40 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p
try try
ST.pname_find proc_name' ret_const_key ST.pname_find proc_name' ret_const_key
with Not_found -> with Not_found ->
match get_proc_desc proc_name' with match get_proc_desc proc_name' with
Some proc_desc' -> Some proc_desc' ->
let is_return_instr = function let is_return_instr = function
| Sil.Set (Sil.Lvar p, _, _, _) | Sil.Set (Sil.Lvar p, _, _, _)
when Sil.pvar_equal p (Cfg.Procdesc.get_ret_var proc_desc') -> true when Sil.pvar_equal p (Cfg.Procdesc.get_ret_var proc_desc') -> true
| _ -> false in | _ -> false in
(match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with (match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with
| Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n | Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n
| _ -> "<" ^ (Procname.to_string proc_name') ^ ">") | _ -> "<" ^ (Procname.to_string proc_name') ^ ">")
| None -> "?" in | None -> "?" in
let get_actual_arguments node instr = match instr with let get_actual_arguments node instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> (try | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> (try
let find_const exp typ = let find_const exp typ =
let expanded = Idenv.expand_expr idenv exp in let expanded = Idenv.expand_expr idenv exp in
match expanded with match expanded with
| Sil.Const (Sil.Cclass n) -> Ident.name_to_string n | Sil.Const (Sil.Cclass n) -> Ident.name_to_string n
| Sil.Lvar p -> ( | Sil.Lvar p -> (
let is_call_instr set call = match set, call with let is_call_instr set call = match set, call with
| Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _) when Ident.equal i1 i2 -> true | Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _) when Ident.equal i1 i2 -> true
| _ -> false in | _ -> false in
let is_set_instr = function let is_set_instr = function
| Sil.Set (e1, t, e2, l) when Sil.exp_equal expanded e1 -> true | Sil.Set (e1, t, e2, l) when Sil.exp_equal expanded e1 -> true
| _ -> false in | _ -> false in
match reverse_find_instr is_set_instr node with (** Look for ivar := tmp *) match reverse_find_instr is_set_instr node with (** Look for ivar := tmp *)
| Some s -> ( | Some s -> (
match reverse_find_instr (is_call_instr s) node with (** Look for tmp := foo() *) match reverse_find_instr (is_call_instr s) node with (** Look for tmp := foo() *)
| Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, l, _)) -> get_return_const pn | Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, l, _)) -> get_return_const pn
| _ -> "?") | _ -> "?")
| _ -> "?") | _ -> "?")
| _ -> "?" in | _ -> "?" in
let arg_name (exp, typ) = find_const exp typ in let arg_name (exp, typ) = find_const exp typ in
Some (list_map arg_name args) Some (list_map arg_name args)
with _ -> None) with _ -> None)
| _ -> None in | _ -> None in
let process_result instr result = let process_result instr result =
@ -406,22 +406,22 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p
); );
match result with match result with
| str when (Str.string_match (Str.regexp "<\\(.*\\)>") str 0) -> ( | str when (Str.string_match (Str.regexp "<\\(.*\\)>") str 0) -> (
let missing_proc_name = Str.matched_group 1 str in let missing_proc_name = Str.matched_group 1 str in
L.stdout "Deserialization of %s requires 2nd phase: " str; L.stdout "Deserialization of %s requires 2nd phase: " str;
L.stdout "missing: %s@." missing_proc_name) L.stdout "missing: %s@." missing_proc_name)
| "?" -> L.stdout "Unable to resolve deserialization\n\n@." | "?" -> L.stdout "Unable to resolve deserialization\n\n@."
| _ -> L.stdout "Deserialization of %s\n\n@." result in | _ -> L.stdout "Deserialization of %s\n\n@." result in
let do_instr node instr = let do_instr node instr =
match PatternMatch.get_java_method_call_formal_signature instr with match PatternMatch.get_java_method_call_formal_signature instr with
| Some (_, "readValue", _, _) -> ( | Some (_, "readValue", _, _) -> (
match get_actual_arguments node instr with match get_actual_arguments node instr with
| Some [_; cl] -> process_result instr cl | Some [_; cl] -> process_result instr cl
| _ -> process_result instr "?") | _ -> process_result instr "?")
| Some (_, "readValueAs", _, _) -> ( | Some (_, "readValueAs", _, _) -> (
match get_actual_arguments node instr with match get_actual_arguments node instr with
| Some [cl] -> process_result instr cl | Some [cl] -> process_result instr cl
| _ -> process_result instr "?") | _ -> process_result instr "?")
| _ -> () in | _ -> () in
let store_return () = let store_return () =
@ -478,7 +478,7 @@ let callback_check_field_access all_procs get_proc_desc idenv tenv proc_name pro
let callback_print_c_method_calls all_procs get_proc_desc idenv tenv proc_name proc_desc = let callback_print_c_method_calls all_procs get_proc_desc idenv tenv proc_name proc_desc =
let do_instr node = function let do_instr node = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (e, t):: args, loc, cf) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (e, t):: args, loc, cf)
when Procname.is_c_method pn -> when Procname.is_c_method pn ->
let receiver = match Errdesc.exp_rv_dexp node e with let receiver = match Errdesc.exp_rv_dexp node e with
| Some de -> Sil.dexp_to_string de | Some de -> Sil.dexp_to_string de
| None -> "?" in | None -> "?" in

10
infer/src/checkers/codeQuery.ml
Unescape View File

@ -47,9 +47,9 @@ module Err = struct
} in } in
[(Specs.spec_normalize spec)] in [(Specs.spec_normalize spec)] in
let new_summ = { old_summ with let new_summ = { old_summ with
Specs.loc = Cfg.Procdesc.get_loc proc_desc; Specs.loc = Cfg.Procdesc.get_loc proc_desc;
Specs.nodes = nodes; Specs.nodes = nodes;
Specs.payload = Specs.PrePosts specs } in Specs.payload = Specs.PrePosts specs } in
Specs.add_summary proc_name new_summ Specs.add_summary proc_name new_summ
let add_error_to_spec proc_name s node loc = let add_error_to_spec proc_name s node loc =
@ -84,8 +84,8 @@ module Match = struct
let value' = Hashtbl.find env id in let value' = Hashtbl.find env id in
value_equal value value' value_equal value value'
with Not_found -> with Not_found ->
Hashtbl.add env id value; Hashtbl.add env id value;
true true
let pp_env fmt env = let pp_env fmt env =
let pp_item id value = let pp_item id value =
F.fprintf fmt "%s=%a " id pp_value value in F.fprintf fmt "%s=%a " id pp_value value in

42
infer/src/checkers/constantPropagation.ml
Unescape View File

@ -41,8 +41,8 @@ module ConstantFlow = Dataflow.MakeDF(struct
Format.fprintf fmt "]@." Format.fprintf fmt "]@."
(* Item - wise equality where values are equal iff (* Item - wise equality where values are equal iff
- both are None - both are None
- both are a constant and equal wrt. Sil.const_equal *) - both are a constant and equal wrt. Sil.const_equal *)
let equal m n = ConstantMap.equal (opt_equal Sil.const_equal) m n let equal m n = ConstantMap.equal (opt_equal Sil.const_equal) m n
let join = ConstantMap.merge merge_values let join = ConstantMap.merge merge_values
@ -71,32 +71,32 @@ module ConstantFlow = Dataflow.MakeDF(struct
(* Handle propagation of string with StringBuilder. Does not handle null case *) (* Handle propagation of string with StringBuilder. Does not handle null case *)
| Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var sb, _):: [], _, _) | Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var sb, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder" when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "<init>" -> (* StringBuilder.<init> *) && Procname.java_get_method pn = "<init>" -> (* StringBuilder.<init> *)
update (Sil.Var sb) (Some (Sil.Cstr "")) constants update (Sil.Var sb) (Some (Sil.Cstr "")) constants
| Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: [], _, _) | Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder" when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *) && Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *)
update (Sil.Var i) (ConstantMap.find (Sil.Var i1) constants) constants update (Sil.Var i) (ConstantMap.find (Sil.Var i1) constants) constants
| Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], _, _) | Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder" when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" -> (* StringBuilder.append *) && Procname.java_get_method pn = "append" -> (* StringBuilder.append *)
(match (match
ConstantMap.find (Sil.Var i1) constants, ConstantMap.find (Sil.Var i1) constants,
ConstantMap.find (Sil.Var i2) constants with ConstantMap.find (Sil.Var i2) constants with
| Some (Sil.Cstr s1), Some (Sil.Cstr s2) -> | Some (Sil.Cstr s1), Some (Sil.Cstr s2) ->
begin begin
let s = s1 ^ s2 in let s = s1 ^ s2 in
let u = let u =
if String.length s < string_widening_limit then if String.length s < string_widening_limit then
Some (Sil.Cstr s) Some (Sil.Cstr s)
else else
None in None in
update (Sil.Var i) u constants update (Sil.Var i) u constants
end end
| _ -> constants) | _ -> constants)
| _ -> constants | _ -> constants
with Not_found -> constants in with Not_found -> constants in

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

@ -49,10 +49,10 @@ let node_throws node (proc_throws : Procname.t -> throws) : throws =
Sil.pvar_equal pvar ret_pvar in Sil.pvar_equal pvar ret_pvar in
match instr with match instr with
| Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> | Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar ->
(* assignment to return variable is an artifact of a throw instruction *) (* assignment to return variable is an artifact of a throw instruction *)
Throws Throws
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _) | Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _)
when SymExec.function_is_builtin callee_pn -> when SymExec.function_is_builtin callee_pn ->
if Procname.equal callee_pn SymExec.ModelBuiltins.__cast if Procname.equal callee_pn SymExec.ModelBuiltins.__cast
then DontKnow then DontKnow
else DoesNotThrow else DoesNotThrow

46
infer/src/checkers/eradicate.ml
Unescape View File

@ -32,9 +32,9 @@ type parameters = TypeState.parameters
module type CallBackT = module type CallBackT =
sig sig
val callback : val callback :
TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc -> TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc ->
Idenv.t -> Sil.tenv -> Procname.t -> Idenv.t -> Sil.tenv -> Procname.t ->
Cfg.Procdesc.t -> unit Cfg.Procdesc.t -> unit
end (* CallBackT *) end (* CallBackT *)
(** Extension to the type checker. *) (** Extension to the type checker. *)
@ -47,7 +47,7 @@ end
(** Create a module with the toplevel callback. *) (** Create a module with the toplevel callback. *)
module MkCallback module MkCallback
(Extension : ExtensionT) (Extension : ExtensionT)
: CallBackT = : CallBackT =
struct struct
(** Update the summary with stats from the checker. *) (** Update the summary with stats from the checker. *)
let update_summary proc_name proc_desc final_typestate_opt = let update_summary proc_name proc_desc final_typestate_opt =
@ -126,10 +126,10 @@ struct
find_canonical_duplicate annotated_signature typestate node linereader in find_canonical_duplicate annotated_signature typestate node linereader in
if trace then if trace then
list_iter (fun typestate_succ -> list_iter (fun typestate_succ ->
L.stdout L.stdout
"Typestate After Node %a@\n%a@." "Typestate After Node %a@\n%a@."
Cfg.Node.pp node Cfg.Node.pp node
(TypeState.pp Extension.ext) typestate_succ) (TypeState.pp Extension.ext) typestate_succ)
typestates_succ; typestates_succ;
typestates_succ, typestates_exn typestates_succ, typestates_exn
let proc_throws pn = DontKnow let proc_throws pn = DontKnow
@ -190,7 +190,7 @@ struct
!res in !res in
(** Get the initializers recursively called by computing a fixpoint. (** Get the initializers recursively called by computing a fixpoint.
Start from the initializers of the current class and the current procedure. *) Start from the initializers of the current class and the current procedure. *)
let initializers_recursive : init list = let initializers_recursive : init list =
let initializers_base_case = initializers_current_class in let initializers_base_case = initializers_current_class in
@ -227,8 +227,8 @@ struct
let pname_and_pdescs_with f = let pname_and_pdescs_with f =
list_map list_map
(fun n -> match get_proc_desc n with (fun n -> match get_proc_desc n with
| Some d -> [(n, d)] | Some d -> [(n, d)]
| None -> []) | None -> [])
all_procs all_procs
|> list_flatten |> list_flatten
|> list_filter f |> list_filter f
@ -243,8 +243,8 @@ struct
let initializers_current_class = let initializers_current_class =
pname_and_pdescs_with pname_and_pdescs_with
(fun (pname, pdesc) -> (fun (pname, pdesc) ->
is_initializer pdesc pname && is_initializer pdesc pname &&
Procname.java_get_class pname = Procname.java_get_class curr_pname) in Procname.java_get_class pname = Procname.java_get_class curr_pname) in
final_typestates ((curr_pname, curr_pdesc):: initializers_current_class) final_typestates ((curr_pname, curr_pdesc):: initializers_current_class)
end end
@ -254,8 +254,8 @@ struct
let constructors_current_class = let constructors_current_class =
pname_and_pdescs_with pname_and_pdescs_with
(fun (n, d) -> (fun (n, d) ->
Procname.is_constructor n && Procname.is_constructor n &&
Procname.java_get_class n = Procname.java_get_class curr_pname) in Procname.java_get_class n = Procname.java_get_class curr_pname) in
final_typestates constructors_current_class final_typestates constructors_current_class
end end
@ -265,8 +265,8 @@ struct
let do_typestate typestate = let do_typestate typestate =
let start_node = Cfg.Procdesc.get_start_node curr_pdesc in let start_node = Cfg.Procdesc.get_start_node curr_pdesc in
if not calls_this && (* if 'this(...)' is called, no need to check initialization *) if not calls_this && (* if 'this(...)' is called, no need to check initialization *)
check_field_initialization && check_field_initialization &&
checks.TypeCheck.eradicate checks.TypeCheck.eradicate
then begin then begin
EradicateChecks.check_constructor_initialization EradicateChecks.check_constructor_initialization
find_canonical_duplicate find_canonical_duplicate
@ -305,7 +305,7 @@ struct
let filter_special_cases () = let filter_special_cases () =
if Procname.java_is_access_method proc_name || if Procname.java_is_access_method proc_name ||
(Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method (Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method
then None then None
else else
begin begin
@ -313,11 +313,11 @@ struct
if (Specs.proc_get_attributes proc_name proc_desc).Sil.is_abstract then if (Specs.proc_get_attributes proc_name proc_desc).Sil.is_abstract then
begin begin
if Models.infer_library_return && if Models.infer_library_return &&
EradicateChecks.classify_procedure proc_name proc_desc = "L" then EradicateChecks.classify_procedure proc_name proc_desc = "L" then
(let ret_is_nullable = (* get the existing annotation *) (let ret_is_nullable = (* get the existing annotation *)
let ia, _ = annotated_signature.Annotations.ret in let ia, _ = annotated_signature.Annotations.ret in
Annotations.ia_is_nullable ia in Annotations.ia_is_nullable ia in
EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name); EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name);
Some annotated_signature Some annotated_signature
end end
else else
@ -342,7 +342,7 @@ end (* MkCallback *)
(** Given an extension to the typestate with a check, call the check on each instruction. *) (** Given an extension to the typestate with a check, call the check on each instruction. *)
module Build module Build
(Extension : ExtensionT) (Extension : ExtensionT)
: CallBackT = : CallBackT =
struct struct
module Callback = MkCallback(Extension) module Callback = MkCallback(Extension)
let callback = Callback.callback let callback = Callback.callback

30
infer/src/checkers/eradicateChecks.ml
Unescape View File

@ -42,7 +42,7 @@ let get_field_annotation fn typ =
(* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *) (* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *)
(* outside of Eradicate in some other way *) (* outside of Eradicate in some other way *)
if (Models.Inference.enabled || not !Config.eradicate) if (Models.Inference.enabled || not !Config.eradicate)
&& Models.Inference.field_is_marked fn && Models.Inference.field_is_marked fn
then Annotations.mk_ia Annotations.Nullable ia then Annotations.mk_ia Annotations.Nullable ia
else ia in else ia in
Some (t, ia') Some (t, ia')
@ -138,7 +138,7 @@ let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname
| _ -> false in | _ -> false in
let do_instr = function let do_instr = function
| Sil.Call (_, Sil.Const (Sil.Cfun pn), [_; (Sil.Sizeof(t, _), _)], _, _) when | Sil.Call (_, Sil.Const (Sil.Cfun pn), [_; (Sil.Sizeof(t, _), _)], _, _) when
Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t -> Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t ->
throwable_found := true throwable_found := true
| _ -> () in | _ -> () in
let do_node n = let do_node n =
@ -264,10 +264,10 @@ let check_constructor_initialization
| None -> unknown in | None -> unknown in
list_exists list_exists
(function pname, typestate -> (function pname, typestate ->
let pvar = Sil.mk_pvar let pvar = Sil.mk_pvar
(Mangled.from_string (Ident.fieldname_to_string fn)) (Mangled.from_string (Ident.fieldname_to_string fn))
pname in pname in
filter_range_opt (TypeState.lookup_pvar pvar typestate)) filter_range_opt (TypeState.lookup_pvar pvar typestate))
list in list in
let may_be_assigned_in_final_typestate = let may_be_assigned_in_final_typestate =
@ -299,7 +299,7 @@ let check_constructor_initialization
(* Check if field is missing annotation. *) (* Check if field is missing annotation. *)
if not (nullable_annotated || nonnull_annotated) && if not (nullable_annotated || nonnull_annotated) &&
not may_be_assigned_in_final_typestate then not may_be_assigned_in_final_typestate then
report_error report_error
find_canonical_duplicate find_canonical_duplicate
start_node start_node
@ -310,8 +310,8 @@ let check_constructor_initialization
(* Check if field is over-annotated. *) (* Check if field is over-annotated. *)
if activate_field_over_annotated && if activate_field_over_annotated &&
nullable_annotated && nullable_annotated &&
not (may_be_nullable_in_final_typestate ()) then not (may_be_nullable_in_final_typestate ()) then
report_error report_error
find_canonical_duplicate find_canonical_duplicate
start_node start_node
@ -410,7 +410,7 @@ let check_call_receiver
find_canonical_duplicate find_canonical_duplicate
node node
(TypeErr.Call_receiver_annotation_inconsistent (TypeErr.Call_receiver_annotation_inconsistent
(ann, descr, callee_pname, origin_descr)) (ann, descr, callee_pname, origin_descr))
(Some instr_ref) (Some instr_ref)
loc curr_pname loc curr_pname
end end
@ -484,7 +484,7 @@ let check_call_parameters
check (list_rev sig_params) (list_rev call_params) check (list_rev sig_params) (list_rev call_params)
(** Checks if the annotations are consistent with the inherited class or with the (** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *) implemented interfaces *)
let check_overridden_annotations let check_overridden_annotations
find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature = find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature =
@ -512,12 +512,12 @@ let check_overridden_annotations
let _, overriden_ia, overriden_type = overriden_param in let _, overriden_ia, overriden_type = overriden_param in
let () = let () =
if not (Annotations.ia_is_nullable current_ia) if not (Annotations.ia_is_nullable current_ia)
&& Annotations.ia_is_nullable overriden_ia then && Annotations.ia_is_nullable overriden_ia then
report_error report_error
find_canonical_duplicate find_canonical_duplicate
start_node start_node
(TypeErr.Inconsistent_subclass_parameter_annotation (TypeErr.Inconsistent_subclass_parameter_annotation
(current_name, pos, proc_name, overriden_proc_name)) (current_name, pos, proc_name, overriden_proc_name))
None None
loc proc_name in loc proc_name in
(pos + 1) in (pos + 1) in
@ -549,8 +549,8 @@ let check_overridden_annotations
not (Procname.is_constructor pname) in not (Procname.is_constructor pname) in
list_iter list_iter
(fun pname -> (fun pname ->
if is_override pname if is_override pname
then check pname) then check pname)
methods methods
| _ -> () in | _ -> () in

12
infer/src/checkers/idenv.ml
Unescape View File

@ -8,7 +8,7 @@
*) *)
(** Environment for temporary identifiers used in instructions. (** Environment for temporary identifiers used in instructions.
Lazy implementation: only created when actually used. *) Lazy implementation: only created when actually used. *)
type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg
@ -41,8 +41,8 @@ let lookup (_map, _) id =
let expand_expr idenv e = match e with let expand_expr idenv e = match e with
| Sil.Var id -> | Sil.Var id ->
(match lookup idenv id with (match lookup idenv id with
| Some e' -> e' | Some e' -> e'
| None -> e) | None -> e)
| _ -> e | _ -> e
let expand_expr_temps idenv node _exp = let expand_expr_temps idenv node _exp =
@ -50,9 +50,9 @@ let expand_expr_temps idenv node _exp =
match exp with match exp with
| Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar -> | Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar ->
(match Errdesc.find_program_variable_assignment node pvar with (match Errdesc.find_program_variable_assignment node pvar with
| None -> exp | None -> exp
| Some (_, id) -> | Some (_, id) ->
expand_expr idenv (Sil.Var id)) expand_expr idenv (Sil.Var id))
| _ -> exp | _ -> exp
(** Return true if the expression is a temporary variable introduced by the front-end. *) (** Return true if the expression is a temporary variable introduced by the front-end. *)

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

@ -18,14 +18,14 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc :
begin begin
let casts = let casts =
[ [
"java.util.List", "com.google.common.collect.ImmutableList"; "java.util.List", "com.google.common.collect.ImmutableList";
"java.util.Map", "com.google.common.collect.ImmutableMap"; "java.util.Map", "com.google.common.collect.ImmutableMap";
"java.util.Set", "com.google.common.collect.ImmutableSet" "java.util.Set", "com.google.common.collect.ImmutableSet"
] in ] in
let in_casts expected given = let in_casts expected given =
list_exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in list_exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in
match PatternMatch.type_get_class_name typ_expected, match PatternMatch.type_get_class_name typ_expected,
PatternMatch.type_get_class_name typ_found with PatternMatch.type_get_class_name typ_found with
| Some name_expected, Some name_given -> | Some name_expected, Some name_given ->
if in_casts name_expected name_given then if in_casts name_expected name_given then
begin begin

162
infer/src/checkers/models.ml
Unescape View File

@ -121,69 +121,69 @@ let check_not_null_parameter_list, check_not_null_list =
let x = if check_not_null_strict then o else n in let x = if check_not_null_strict then o else n in
let list = let list =
[ [
1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; 1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; 1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; 1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; 1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; 1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; 1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void"; 1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void";
2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void"; 2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object"; 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object"; 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object"; 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object"; 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
] in ] in
list_map (fun (x, y, z) -> (x, z)) list, list_map (fun (x, y, z) -> (y, z)) list list_map (fun (x, y, z) -> (x, z)) list, list_map (fun (x, y, z) -> (y, z)) list
let check_state_list = let check_state_list =
[ [
(o, [n]), "Preconditions.checkState(boolean):void"; (o, [n]), "Preconditions.checkState(boolean):void";
(o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void"; (o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void"; (o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void"; (o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void"; (o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; (o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void"; (o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void"; (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void"; (o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void"; (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void";
] ]
let check_argument_list = let check_argument_list =
[ [
(o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void"; (o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void"; (o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void"; (o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void"; (o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; (o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
] ]
let optional_get_list : ((_ * bool list) * _) list = let optional_get_list : ((_ * bool list) * _) list =
[ [
(o, []), "Optional.get():java.lang.Object"; (o, []), "Optional.get():java.lang.Object";
(o, []), "com.google.common.base.Optional.get():java.lang.Object"; (o, []), "com.google.common.base.Optional.get():java.lang.Object";
] ]
let optional_isPresent_list : ((_ * bool list) * _) list = let optional_isPresent_list : ((_ * bool list) * _) list =
[ [
(o, []), "Optional.isPresent():boolean"; (o, []), "Optional.isPresent():boolean";
(o, []), "com.google.common.base.Optional.isPresent():boolean"; (o, []), "com.google.common.base.Optional.isPresent():boolean";
] ]
(** Models for Map.containsKey *) (** Models for Map.containsKey *)
let containsKey_list = let containsKey_list =
[ [
n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean"; n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean";
n1, "java.util.Map.containsKey(java.lang.Object):boolean"; n1, "java.util.Map.containsKey(java.lang.Object):boolean";
] ]
(** Models for @Strict annotations *) (** Models for @Strict annotations *)
let annotated_list_strict = let annotated_list_strict =
[ [
(n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object"; (n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object";
] ]
(** Models for @Nullable annotations *) (** Models for @Nullable annotations *)
@ -191,53 +191,53 @@ let annotated_list_nullable =
check_not_null_list @ check_state_list @ check_argument_list @ check_not_null_list @ check_state_list @ check_argument_list @
annotated_list_strict @ annotated_list_strict @
[ [
n1, "android.os.Parcel.writeList(java.util.List):void"; n1, "android.os.Parcel.writeList(java.util.List):void";
n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void"; n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void";
n1, "android.os.Parcel.writeString(java.lang.String):void"; n1, "android.os.Parcel.writeString(java.lang.String):void";
(o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.<init>(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)"; (o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.<init>(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)";
(o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine"; (o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine";
on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object"; on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object";
on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper"; on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper";
n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean"; n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean";
n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional"; n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional";
(n, []), "com.google.common.base.Optional.orNull():java.lang.Object"; (n, []), "com.google.common.base.Optional.orNull():java.lang.Object";
n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String"; n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String";
cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *) cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *)
o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder"; o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder"; o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder"; o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder";
on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object"; on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object";
o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean"; o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean";
o1, "java.io.File.<init>(java.lang.String)"; o1, "java.io.File.<init>(java.lang.String)";
n1, "java.io.PrintStream.print(java.lang.String):void"; n1, "java.io.PrintStream.print(java.lang.String):void";
o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean"; o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean";
n1, "java.lang.Integer.equals(java.lang.Object):boolean"; n1, "java.lang.Integer.equals(java.lang.Object):boolean";
n2, "java.lang.RuntimeException.<init>(java.lang.String,java.lang.Throwable)"; n2, "java.lang.RuntimeException.<init>(java.lang.String,java.lang.Throwable)";
n1, "java.lang.String.equals(java.lang.Object):boolean"; n1, "java.lang.String.equals(java.lang.Object):boolean";
n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder"; n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder";
on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader"; on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader";
n1, "java.util.AbstractList.equals(java.lang.Object):boolean"; n1, "java.util.AbstractList.equals(java.lang.Object):boolean";
ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *) ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *)
ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *) ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *)
cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *) cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *)
cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *) cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *)
n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager"; n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager";
(n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; (n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; (n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(* References *) (* References *)
ng, "java.lang.ref.Reference.get():java.lang.Object"; ng, "java.lang.ref.Reference.get():java.lang.Object";
ng, "java.lang.ref.PhantomReference.get():java.lang.Object"; ng, "java.lang.ref.PhantomReference.get():java.lang.Object";
ng, "java.lang.ref.SoftReference.get():java.lang.Object"; ng, "java.lang.ref.SoftReference.get():java.lang.Object";
ng, "java.lang.ref.WeakReference.get():java.lang.Object"; ng, "java.lang.ref.WeakReference.get():java.lang.Object";
ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object"; ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object";
] ]
(** Models for @Present annotations *) (** Models for @Present annotations *)
let annotated_list_present = let annotated_list_present =
[ [
(n, [o]), "Optional.of(java.lang.Object):Optional"; (n, [o]), "Optional.of(java.lang.Object):Optional";
(n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional"; (n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional";
] ]
let mk_table list = let mk_table list =
@ -304,7 +304,7 @@ let get_annotated_signature callee_pdesc callee_pname =
let mark = Hashtbl.find annotated_table_nullable proc_id in let mark = Hashtbl.find annotated_table_nullable proc_id in
Annotations.annotated_signature_mark callee_pname Annotations.Nullable ann_sig mark Annotations.annotated_signature_mark callee_pname Annotations.Nullable ann_sig mark
with Not_found -> with Not_found ->
ann_sig ann_sig
else ann_sig in else ann_sig in
let lookup_models_present ann_sig = let lookup_models_present ann_sig =
if use_models then if use_models then
@ -312,11 +312,11 @@ let get_annotated_signature callee_pdesc callee_pname =
let mark = Hashtbl.find annotated_table_present proc_id in let mark = Hashtbl.find annotated_table_present proc_id in
Annotations.annotated_signature_mark callee_pname Annotations.Present ann_sig mark Annotations.annotated_signature_mark callee_pname Annotations.Present ann_sig mark
with Not_found -> with Not_found ->
ann_sig ann_sig
else ann_sig in else ann_sig in
let lookup_models_strict ann_sig = let lookup_models_strict ann_sig =
if use_models if use_models
&& Hashtbl.mem annotated_table_strict proc_id && Hashtbl.mem annotated_table_strict proc_id
then then
Annotations.annotated_signature_mark_return_strict callee_pname ann_sig Annotations.annotated_signature_mark_return_strict callee_pname ann_sig
else else

56
infer/src/checkers/patternMatch.ml
Unescape View File

@ -21,9 +21,9 @@ let type_is_object = function
let java_proc_name_with_class_method pn class_with_path method_name = let java_proc_name_with_class_method pn class_with_path method_name =
(try (try
Procname.java_get_class pn = class_with_path && Procname.java_get_class pn = class_with_path &&
Procname.java_get_method pn = method_name Procname.java_get_method pn = method_name
with _ -> false) with _ -> false)
let is_direct_subtype_of this_type super_type_name = let is_direct_subtype_of this_type super_type_name =
match this_type with match this_type with
@ -135,12 +135,12 @@ let get_field_type_name
match typ with match typ with
| Sil.Tstruct (fields, _, _, _, _, _, _) | Sil.Tstruct (fields, _, _, _, _, _, _)
| Sil.Tptr (Sil.Tstruct (fields, _, _, _, _, _, _), _) -> ( | Sil.Tptr (Sil.Tstruct (fields, _, _, _, _, _, _), _) -> (
try try
let _, ft, _ = list_find let _, ft, _ = list_find
(function | (fn, _, _) -> Ident.fieldname_equal fn fieldname) (function | (fn, _, _) -> Ident.fieldname_equal fn fieldname)
fields in fields in
Some (get_type_name ft) Some (get_type_name ft)
with Not_found -> None) with Not_found -> None)
| _ -> None | _ -> None
let java_get_const_type_name let java_get_const_type_name
@ -158,9 +158,9 @@ let get_vararg_type_names
let rec initializes_array instrs = let rec initializes_array instrs =
match instrs with match instrs with
| Sil.Call ([t1], Sil.Const (Sil.Cfun pn), _, _, _):: | Sil.Call ([t1], Sil.Const (Sil.Cfun pn), _, _, _)::
Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is -> Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is ->
(Sil.pvar_equal ivar iv && Ident.equal t1 t2 && (Sil.pvar_equal ivar iv && Ident.equal t1 t2 &&
Procname.equal pn (Procname.from_string_c_fun "__new_array")) Procname.equal pn (Procname.from_string_c_fun "__new_array"))
|| initializes_array is || initializes_array is
| i:: is -> initializes_array is | i:: is -> initializes_array is
| _ -> false in | _ -> false in
@ -170,24 +170,24 @@ let get_vararg_type_names
let rec nvar_type_name nvar instrs = let rec nvar_type_name nvar instrs =
match instrs with match instrs with
| Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _ | Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _
when Ident.equal nv nvar -> get_field_type_name t id when Ident.equal nv nvar -> get_field_type_name t id
| Sil.Letderef (nv, e, t, _):: _ | Sil.Letderef (nv, e, t, _):: _
when Ident.equal nv nvar -> when Ident.equal nv nvar ->
Some (get_type_name t) Some (get_type_name t)
| i:: is -> nvar_type_name nvar is | i:: is -> nvar_type_name nvar is
| _ -> None in | _ -> None in
let rec added_nvar array_nvar instrs = let rec added_nvar array_nvar instrs =
match instrs with match instrs with
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Var nvar, _):: _ | Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Var nvar, _):: _
when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node) when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node)
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _ | Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _
when Ident.equal iv array_nvar -> Some (java_get_const_type_name c) when Ident.equal iv array_nvar -> Some (java_get_const_type_name c)
| i:: is -> added_nvar array_nvar is | i:: is -> added_nvar array_nvar is
| _ -> None in | _ -> None in
let rec array_nvar instrs = let rec array_nvar instrs =
match instrs with match instrs with
| Sil.Letderef (nv, Sil.Lvar iv, _, _):: _ | Sil.Letderef (nv, Sil.Lvar iv, _, _):: _
when Sil.pvar_equal iv ivar -> when Sil.pvar_equal iv ivar ->
added_nvar nv instrs added_nvar nv instrs
| i:: is -> array_nvar is | i:: is -> array_nvar is
| _ -> None in | _ -> None in
@ -200,8 +200,8 @@ let get_vararg_type_names
else else
match (Cfg.Node.get_preds node) with match (Cfg.Node.get_preds node) with
| [n] -> (match (added_type_name node) with | [n] -> (match (added_type_name node) with
| Some name -> name:: type_names n | Some name -> name:: type_names n
| None -> type_names n) | None -> type_names n)
| _ -> raise Not_found in | _ -> raise Not_found in
list_rev (type_names call_node) list_rev (type_names call_node)
@ -232,15 +232,15 @@ let get_java_field_access_signature = function
| _ -> None | _ -> None
(** Returns the formal signature (class name, method name, (** Returns the formal signature (class name, method name,
argument type names and return type name) *) argument type names and return type name) *)
let get_java_method_call_formal_signature = function let get_java_method_call_formal_signature = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) ->
(try (try
let arg_names = list_map (function | e, t -> get_type_name t) args in let arg_names = list_map (function | e, t -> get_type_name t) args in
let rt_name = Procname.java_get_return_type pn in let rt_name = Procname.java_get_return_type pn in
let m_name = Procname.java_get_method pn in let m_name = Procname.java_get_method pn in
Some (get_type_name tt, m_name, arg_names, rt_name) Some (get_type_name tt, m_name, arg_names, rt_name)
with _ -> None) with _ -> None)
| _ -> None | _ -> None
@ -256,14 +256,14 @@ let initializer_classes = list_map Mangled.from_string [
"android.app.Application"; "android.app.Application";
"android.app.Fragment"; "android.app.Fragment";
"android.support.v4.app.Fragment"; "android.support.v4.app.Fragment";
] ]
let initializer_methods = [ let initializer_methods = [
"onActivityCreated"; "onActivityCreated";
"onAttach"; "onAttach";
"onCreate"; "onCreate";
"onCreateView"; "onCreateView";
] ]
(** Check if the type has in its supertypes from the initializer_classes list. *) (** Check if the type has in its supertypes from the initializer_classes list. *)
let type_has_initializer let type_has_initializer
@ -291,8 +291,8 @@ let java_get_vararg_values node pvar idenv pdesc =
let values = ref [] in let values = ref [] in
let do_instr = function let do_instr = function
| Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _) | Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _)
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) -> when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) ->
(* Each vararg argument is an assigment to a pvar denoting an array of objects. *) (* Each vararg argument is an assigment to a pvar denoting an array of objects. *)
values := content_exp :: !values values := content_exp :: !values
| _ -> () in | _ -> () in
let do_node n = let do_node n =

108
infer/src/checkers/printfArgs.ml
Unescape View File

@ -30,22 +30,22 @@ let printf_signature_to_string
let printf_like_functions = let printf_like_functions =
ref ref
[ [
{ unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream"; { unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 1; format_pos = 1;
fixed_pos = []; fixed_pos = [];
vararg_pos = Some 2 }; vararg_pos = Some 2 };
{ unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream"; { unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 2; format_pos = 2;
fixed_pos = []; fixed_pos = [];
vararg_pos = Some 3 }; vararg_pos = Some 3 };
{ unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String"; { unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 1; format_pos = 1;
fixed_pos = []; fixed_pos = [];
vararg_pos = Some 2 }; vararg_pos = Some 2 };
{ unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String"; { unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 2; format_pos = 2;
fixed_pos = []; fixed_pos = [];
vararg_pos = Some 3 }; vararg_pos = Some 3 };
] ]
let add_printf_like_function plf = let add_printf_like_function plf =
@ -169,18 +169,18 @@ let callback_printf_args
let rec array_ivar instrs nvar = let rec array_ivar instrs nvar =
match instrs, nvar with match instrs, nvar with
| Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid | Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid
when Ident.equal id nid -> iv when Ident.equal id nid -> iv
| i:: is, _ -> array_ivar is nvar | i:: is, _ -> array_ivar is nvar
| _ -> raise Not_found in | _ -> raise Not_found in
let rec fixed_nvar_type_name instrs nvar = let rec fixed_nvar_type_name instrs nvar =
match nvar with match nvar with
| Sil.Var nid -> ( | Sil.Var nid -> (
match instrs with match instrs with
| Sil.Letderef (id, Sil.Lvar iv, t, _):: _ | Sil.Letderef (id, Sil.Lvar iv, t, _):: _
when Ident.equal id nid -> PatternMatch.get_type_name t when Ident.equal id nid -> PatternMatch.get_type_name t
| i:: is -> fixed_nvar_type_name is nvar | i:: is -> fixed_nvar_type_name is nvar
| _ -> raise Not_found) | _ -> raise Not_found)
| Sil.Const c -> PatternMatch.java_get_const_type_name c | Sil.Const c -> PatternMatch.java_get_const_type_name c
| _ -> raise (Failure "Could not resolve fixed type name") in | _ -> raise (Failure "Could not resolve fixed type name") in
@ -189,39 +189,39 @@ let callback_printf_args
(instr: Sil.instr): unit = (instr: Sil.instr): unit =
match instr with match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun pn), args, cl, _) -> ( | Sil.Call (_, Sil.Const (Sil.Cfun pn), args, cl, _) -> (
match printf_like_function pn with match printf_like_function pn with
| Some printf -> ( | Some printf -> (
try try
let fmt, fixed_nvars, array_nvar = format_arguments printf args in let fmt, fixed_nvars, array_nvar = format_arguments printf args in
let instrs = Cfg.Node.get_instrs node in let instrs = Cfg.Node.get_instrs node in
let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in
let vararg_ivar_type_names = match array_nvar with let vararg_ivar_type_names = match array_nvar with
| Some nvar -> ( | Some nvar -> (
let ivar = array_ivar instrs nvar in let ivar = array_ivar instrs nvar in
PatternMatch.get_vararg_type_names node ivar) PatternMatch.get_vararg_type_names node ivar)
| None -> [] in | None -> [] in
match fmt with match fmt with
| Some fmt -> | Some fmt ->
check_type_names check_type_names
cl cl
(printf.format_pos + 1) (printf.format_pos + 1)
pn pn
(format_string_type_names fmt 0) (format_string_type_names fmt 0)
(fixed_nvar_type_names@ vararg_ivar_type_names) (fixed_nvar_type_names@ vararg_ivar_type_names)
| None -> | None ->
Checkers.ST.report_error Checkers.ST.report_error
proc_name proc_name
proc_desc proc_desc
printf_args_name printf_args_name
cl cl
"Format string must be string literal" "Format string must be string literal"
with e -> with e ->
L.stderr L.stderr
"%s Exception when analyzing %s: %s@." "%s Exception when analyzing %s: %s@."
printf_args_name printf_args_name
(Procname.to_string proc_name) (Procname.to_string proc_name)
(Printexc.to_string e)) (Printexc.to_string e))
| None -> ()) | None -> ())
| _ -> () in | _ -> () in
Cfg.Procdesc.iter_instrs do_instr proc_desc Cfg.Procdesc.iter_instrs do_instr proc_desc

34
infer/src/checkers/registerCheckers.ml
Unescape View File

@ -20,28 +20,28 @@ let active_procedure_checkers () =
let java_checkers = let java_checkers =
let l = let l =
[ [
CallbackChecker.callback_checker_main, false; CallbackChecker.callback_checker_main, false;
Checkers.callback_check_access, false; Checkers.callback_check_access, false;
Checkers.callback_monitor_nullcheck, false; Checkers.callback_monitor_nullcheck, false;
Checkers.callback_test_state , false; Checkers.callback_test_state , false;
Checkers.callback_checkVisibleForTesting, false; Checkers.callback_checkVisibleForTesting, false;
Checkers.callback_check_write_to_parcel, false; Checkers.callback_check_write_to_parcel, false;
Checkers.callback_find_deserialization, false; Checkers.callback_find_deserialization, false;
Dataflow.callback_test_dataflow, false; Dataflow.callback_test_dataflow, false;
SqlChecker.callback_sql, false; SqlChecker.callback_sql, false;
Eradicate.callback_eradicate, !Config.eradicate; Eradicate.callback_eradicate, !Config.eradicate;
CodeQuery.code_query_callback, !CodeQuery.query <> None; CodeQuery.code_query_callback, !CodeQuery.query <> None;
Checkers.callback_check_field_access, false; Checkers.callback_check_field_access, false;
ImmutableChecker.callback_check_immutable_cast, checkers_enabled; ImmutableChecker.callback_check_immutable_cast, checkers_enabled;
RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled; RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled;
PrintfArgs.callback_printf_args, checkers_enabled; PrintfArgs.callback_printf_args, checkers_enabled;
] in ] in
list_map (fun (x, y) -> (x, y, Some Sil.Java)) l in list_map (fun (x, y) -> (x, y, Some Sil.Java)) l in
let c_cpp_checkers = let c_cpp_checkers =
let l = let l =
[ [
Checkers.callback_print_c_method_calls, false; Checkers.callback_print_c_method_calls, false;
CheckDeadCode.callback_check_dead_code, checkers_enabled; CheckDeadCode.callback_check_dead_code, checkers_enabled;
] in ] in
list_map (fun (x, y) -> (x, y, Some Sil.C_CPP)) l in list_map (fun (x, y) -> (x, y, Some Sil.C_CPP)) l in

10
infer/src/checkers/repeatedCallsChecker.ml
Unescape View File

@ -25,7 +25,7 @@ struct
type t = Sil.instr type t = Sil.instr
let compare i1 i2 = match i1, i2 with let compare i1 i2 = match i1, i2 with
| Sil.Call (ret1, e1, etl1, loc1, cf1), Sil.Call (ret2, e2, etl2, loc2, cf2) -> | Sil.Call (ret1, e1, etl1, loc1, cf1), Sil.Call (ret2, e2, etl2, loc2, cf2) ->
(* ignore return ids and call flags *) (* ignore return ids and call flags *)
let n = Sil.exp_compare e1 e2 in let n = Sil.exp_compare e1 e2 in
if n <> 0 then n else let n = list_compare Sil.exp_typ_compare etl1 etl2 in if n <> 0 then n else let n = list_compare Sil.exp_typ_compare etl1 etl2 in
if n <> 0 then n else Sil.call_flags_compare cf1 cf2 if n <> 0 then n else Sil.call_flags_compare cf1 cf2
@ -61,8 +61,8 @@ struct
| SomePath (** Check if some path exists *) | SomePath (** Check if some path exists *)
(** Check if the procedure performs an allocation operation. (** Check if the procedure performs an allocation operation.
If [paths] is AllPaths, check if an allocation happens on all paths. If [paths] is AllPaths, check if an allocation happens on all paths.
If [paths] is SomePath, check if a path with an allocation exists. *) If [paths] is SomePath, check if a path with an allocation exists. *)
let proc_performs_allocation pdesc paths : Sil.location option = let proc_performs_allocation pdesc paths : Sil.location option =
let node_allocates node : Sil.location option = let node_allocates node : Sil.location option =
@ -113,14 +113,14 @@ struct
let arguments_not_temp args = let arguments_not_temp args =
let filter_arg (e, t) = match e with let filter_arg (e, t) = match e with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
(* same temporary variable does not imply same value *) (* same temporary variable does not imply same value *)
not (Errdesc.pvar_is_frontend_tmp pvar) not (Errdesc.pvar_is_frontend_tmp pvar)
| _ -> true in | _ -> true in
list_for_all filter_arg args in list_for_all filter_arg args in
match instr with match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _, loc, call_flags) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _, loc, call_flags)
when ret_ids <> [] && arguments_not_temp normalized_etl -> when ret_ids <> [] && arguments_not_temp normalized_etl ->
let instr_normalized_args = Sil.Call ( let instr_normalized_args = Sil.Call (
ret_ids, ret_ids,
Sil.Const (Sil.Cfun callee_pname), Sil.Const (Sil.Cfun callee_pname),

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

@ -23,14 +23,14 @@ let callback_sql all_procs get_proc_desc idenv tenv proc_name proc_desc =
"insert into.*"; "insert into.*";
"update .* set.*"; "update .* set.*";
"delete .* from.*"; "delete .* from.*";
] in ] in
list_map Str.regexp_case_fold _sql_start in list_map Str.regexp_case_fold _sql_start in
(* Check for SQL string concatenations *) (* Check for SQL string concatenations *)
let do_instr const_map node = function let do_instr const_map node = function
| Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], l, _) | Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], l, _)
when Procname.java_get_class pn = "java.lang.StringBuilder" when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" -> && Procname.java_get_method pn = "append" ->
let rvar1 = Sil.Var i1 in let rvar1 = Sil.Var i1 in
let rvar2 = Sil.Var i2 in let rvar2 = Sil.Var i2 in
begin begin

106
infer/src/checkers/typeCheck.ml
Unescape View File

@ -22,8 +22,8 @@ let debug = Config.from_env_variable "ERADICATE_DEBUG"
(** Module to treat selected complex expressions as constants. *) (** Module to treat selected complex expressions as constants. *)
module ComplexExpressions = struct module ComplexExpressions = struct
(** What complex expressions are considered constant, each case includes the previous ones. (** What complex expressions are considered constant, each case includes the previous ones.
Boolean checks (e.g. null check) and assignments on expressions considered constant are Boolean checks (e.g. null check) and assignments on expressions considered constant are
retained across the control flow assuming there are no modifications in between. *) retained across the control flow assuming there are no modifications in between. *)
type expressions_constant = type expressions_constant =
| FL_NO (* none *) | FL_NO (* none *)
| FL_PARAMETER_STATIC (* parameter.field and static fields *) | FL_PARAMETER_STATIC (* parameter.field and static fields *)
@ -82,7 +82,7 @@ module ComplexExpressions = struct
dexp_to_string de dexp_to_string de
| Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) | Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
| Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) | Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
when functions_idempotent () -> when functions_idempotent () ->
let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in
let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in
let pp fmt () = let pp fmt () =
@ -140,12 +140,12 @@ let rec typecheck_expr
typestate e tr_default loc : TypeState.range = match e with typestate e tr_default loc : TypeState.range = match e with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
(match TypeState.lookup_pvar pvar typestate with (match TypeState.lookup_pvar pvar typestate with
| Some tr -> TypeState.range_add_locs tr [loc] | Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default) | None -> tr_default)
| Sil.Var id -> | Sil.Var id ->
(match TypeState.lookup_id id typestate with (match TypeState.lookup_id id typestate with
| Some tr -> TypeState.range_add_locs tr [loc] | Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default) | None -> tr_default)
| Sil.Const (Sil.Cint i) when Sil.Int.iszero i -> | Sil.Const (Sil.Cint i) when Sil.Int.iszero i ->
let (typ, _, locs) = tr_default in let (typ, _, locs) = tr_default in
if PatternMatch.type_is_class typ if PatternMatch.type_is_class typ
@ -223,8 +223,8 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
L.stdout " %a@." (Sil.pp_instr pe_text) instr in L.stdout " %a@." (Sil.pp_instr pe_text) instr in
(** Handle the case where a field access X.f happens via a temporary variable $Txxx. (** Handle the case where a field access X.f happens via a temporary variable $Txxx.
This has been observed in assignments this.f = exp when exp contains an ifthenelse. This has been observed in assignments this.f = exp when exp contains an ifthenelse.
Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *) Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *)
let handle_field_access_via_temporary typestate exp loc = let handle_field_access_via_temporary typestate exp loc =
let name_is_temporary name = let name_is_temporary name =
let prefix = "$T" in let prefix = "$T" in
@ -254,7 +254,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> exp in | _ -> exp in
(** Convert a complex expressions into a pvar. (** Convert a complex expressions into a pvar.
When [is_assigment] is true, update the relevant annotations for the pvar. *) When [is_assigment] is true, update the relevant annotations for the pvar. *)
let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc = let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc =
let exp = let exp =
handle_field_access_via_temporary handle_field_access_via_temporary
@ -269,21 +269,21 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Some _ when not is_assignment -> typestate | Some _ when not is_assignment -> typestate
| _ -> | _ ->
(match EradicateChecks.get_field_annotation fn typ with (match EradicateChecks.get_field_annotation fn typ with
| Some (t, ia) -> | Some (t, ia) ->
let range = let range =
( (
t, t,
TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)), TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)),
[loc] [loc]
) in ) in
TypeState.add_pvar pvar range typestate TypeState.add_pvar pvar range typestate
| None -> typestate) in | None -> typestate) in
(* Convert a function call to a pvar. *) (* Convert a function call to a pvar. *)
let handle_function_call call_node id = let handle_function_call call_node id =
match Errdesc.find_normal_variable_funcall call_node id with match Errdesc.find_normal_variable_funcall call_node id with
| Some (Sil.Const (Sil.Cfun pn), _, _, _) | Some (Sil.Const (Sil.Cfun pn), _, _, _)
when not (ComplexExpressions.procname_used_in_condition pn) -> when not (ComplexExpressions.procname_used_in_condition pn) ->
begin begin
match ComplexExpressions.exp_to_string node' exp with match ComplexExpressions.exp_to_string node' exp with
| None -> default | None -> default
@ -299,12 +299,12 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
match exp with match exp with
| Sil.Var id when | Sil.Var id when
ComplexExpressions.functions_idempotent () && ComplexExpressions.functions_idempotent () &&
Errdesc.find_normal_variable_funcall node' id <> None -> Errdesc.find_normal_variable_funcall node' id <> None ->
handle_function_call node' id handle_function_call node' id
| Sil.Lvar pvar when | Sil.Lvar pvar when
ComplexExpressions.functions_idempotent () && ComplexExpressions.functions_idempotent () &&
Errdesc.pvar_is_frontend_tmp pvar -> Errdesc.pvar_is_frontend_tmp pvar ->
let frontend_variable_assignment = let frontend_variable_assignment =
Errdesc.find_program_variable_assignment node pvar in Errdesc.find_program_variable_assignment node pvar in
begin begin
@ -339,13 +339,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let typestate' = update_typestate_fld pvar fn typ in let typestate' = update_typestate_fld pvar fn typ in
(Sil.Lvar pvar, typestate') (Sil.Lvar pvar, typestate')
| Sil.Lfield (_exp', fn', typ') when Ident.java_fieldname_is_outer_instance fn' -> | Sil.Lfield (_exp', fn', typ') when Ident.java_fieldname_is_outer_instance fn' ->
(** handle double dereference when accessing a field from an outer class *) (** handle double dereference when accessing a field from an outer class *)
let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in
let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in
let typestate' = update_typestate_fld pvar fn typ in let typestate' = update_typestate_fld pvar fn typ in
(Sil.Lvar pvar, typestate') (Sil.Lvar pvar, typestate')
| Sil.Lvar _ | Sil.Lfield _ when ComplexExpressions.all_nested_fields () -> | Sil.Lvar _ | Sil.Lfield _ when ComplexExpressions.all_nested_fields () ->
(** treat var.field1. ... .fieldn as a constant *) (** treat var.field1. ... .fieldn as a constant *)
begin begin
match ComplexExpressions.exp_to_string node' exp with match ComplexExpressions.exp_to_string node' exp with
| Some exp_str -> | Some exp_str ->
@ -395,7 +395,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(* Drop parameters from the signature which we do not check in a call. *) (* Drop parameters from the signature which we do not check in a call. *)
let drop_unchecked_signature_params pdesc pname annotated_signature = let drop_unchecked_signature_params pdesc pname annotated_signature =
if Procname.is_constructor pname && if Procname.is_constructor pname &&
(Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then (Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then
list_drop_last 1 annotated_signature.Annotations.params list_drop_last 1 annotated_signature.Annotations.params
else else
annotated_signature.Annotations.params in annotated_signature.Annotations.params in
@ -417,7 +417,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| None -> | None ->
typestate' typestate'
| Some (node', id) -> | Some (node', id) ->
(* handle the case where pvar is a frontend-generated program variable *) (* handle the case where pvar is a frontend-generated program variable *)
let exp = Idenv.expand_expr idenv (Sil.Var id) in let exp = Idenv.expand_expr idenv (Sil.Var id) in
begin begin
match convert_complex_exp_to_pvar node' false exp typestate' loc with match convert_complex_exp_to_pvar node' false exp typestate' loc with
@ -452,7 +452,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc) (typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc)
typestate' typestate'
| Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> | Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar ->
(* skip assignment to return variable where it is an artifact of a throw instruction *) (* skip assignment to return variable where it is an artifact of a throw instruction *)
typestate typestate
| Sil.Set (e1, typ, e2, loc) -> | Sil.Set (e1, typ, e2, loc) ->
typecheck_expr_for_errors typestate e1 loc; typecheck_expr_for_errors typestate e1 loc;
@ -481,14 +481,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
check_field_assign (); check_field_assign ();
typestate2 typestate2
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(_, typ)], loc, _) | Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(_, typ)], loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__new || when Procname.equal pn SymExec.ModelBuiltins.__new ||
Procname.equal pn SymExec.ModelBuiltins.__new_array -> Procname.equal pn SymExec.ModelBuiltins.__new_array ->
TypeState.add_id TypeState.add_id
id id
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.New, [loc]) (typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.New, [loc])
typestate (* new never returns null *) typestate (* new never returns null *)
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), (e, typ):: _, loc, _) | Sil.Call ([id], Sil.Const (Sil.Cfun pn), (e, typ):: _, loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__cast -> when Procname.equal pn SymExec.ModelBuiltins.__cast ->
typecheck_expr_for_errors typestate e loc; typecheck_expr_for_errors typestate e loc;
let e', typestate' = let e', typestate' =
convert_complex_exp_to_pvar node false e typestate loc in convert_complex_exp_to_pvar node false e typestate loc in
@ -497,7 +497,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc) (typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc)
typestate' typestate'
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(array_exp, t)], loc, _) | Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(array_exp, t)], loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__get_array_size -> when Procname.equal pn SymExec.ModelBuiltins.__get_array_size ->
let (_, ta, _) = typecheck_expr let (_, ta, _) = typecheck_expr
find_canonical_duplicate find_canonical_duplicate
calls_this calls_this
@ -531,7 +531,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Sil.Call (_, Sil.Const (Sil.Cfun pn), _, _, _) when SymExec.function_is_builtin pn -> | Sil.Call (_, Sil.Const (Sil.Cfun pn), _, _, _) when SymExec.function_is_builtin pn ->
typestate (* skip othe builtins *) typestate (* skip othe builtins *)
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _etl, loc, cflags) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _etl, loc, cflags)
when get_proc_desc callee_pname <> None -> when get_proc_desc callee_pname <> None ->
let callee_pdesc = match get_proc_desc callee_pname with let callee_pdesc = match get_proc_desc callee_pname with
| Some callee_pdesc -> callee_pdesc | Some callee_pdesc -> callee_pdesc
| None -> assert false in | None -> assert false in
@ -589,7 +589,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
find_canonical_duplicate find_canonical_duplicate
node node
(TypeErr.Condition_redundant (TypeErr.Condition_redundant
(true, EradicateChecks.explain_expr node cond, false)) (true, EradicateChecks.explain_expr node cond, false))
(Some instr_ref) (Some instr_ref)
loc curr_pname loc curr_pname
end; end;
@ -640,7 +640,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let do_instr = function let do_instr = function
| Sil.Prune (Sil.BinOp (Sil.Eq, _cond_e, Sil.Const (Sil.Cint i)), _, _, _) | Sil.Prune (Sil.BinOp (Sil.Eq, _cond_e, Sil.Const (Sil.Cint i)), _, _, _)
| Sil.Prune (Sil.BinOp (Sil.Eq, Sil.Const (Sil.Cint i), _cond_e), _, _, _) | Sil.Prune (Sil.BinOp (Sil.Eq, Sil.Const (Sil.Cint i), _cond_e), _, _, _)
when Sil.Int.iszero i -> when Sil.Int.iszero i ->
let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in
begin begin
match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with
@ -657,13 +657,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> () in | _ -> () in
match call_params with match call_params with
| ((_, Sil.Lvar pvar), typ):: _ -> | ((_, Sil.Lvar pvar), typ):: _ ->
(* temporary variable for the value of the boolean condition *) (* temporary variable for the value of the boolean condition *)
begin begin
let curr_node = TypeErr.InstrRef.get_node instr_ref in let curr_node = TypeErr.InstrRef.get_node instr_ref in
let branch = false in let branch = false in
match Errdesc.find_boolean_assignment curr_node pvar branch with match Errdesc.find_boolean_assignment curr_node pvar branch with
(* In foo(cond1 && cond2), the node that sets the result to false (* In foo(cond1 && cond2), the node that sets the result to false
has all the negated conditions as parents. *) has all the negated conditions as parents. *)
| Some boolean_assignment_node -> | Some boolean_assignment_node ->
list_iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node); list_iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node);
!res_typestate !res_typestate
@ -675,7 +675,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Some (node', id) -> | Some (node', id) ->
let () = match Errdesc.find_normal_variable_funcall node' id with let () = match Errdesc.find_normal_variable_funcall node' id with
| Some (Sil.Const (Sil.Cfun pn), [e], loc, call_flags) | Some (Sil.Const (Sil.Cfun pn), [e], loc, call_flags)
when ComplexExpressions.procname_optional_isPresent pn -> when ComplexExpressions.procname_optional_isPresent pn ->
handle_optional_isPresent node' e handle_optional_isPresent node' e
| _ -> () in | _ -> () in
() ()
@ -740,7 +740,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
typestate2 typestate2
else else
if Procname.java_get_method callee_pname = "checkNotNull" if Procname.java_get_method callee_pname = "checkNotNull"
&& Procname.java_is_vararg callee_pname && Procname.java_is_vararg callee_pname
then then
let last_parameter = list_length call_params in let last_parameter = list_length call_params in
do_preconditions_check_not_null do_preconditions_check_not_null
@ -748,7 +748,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
true (* is_vararg *) true (* is_vararg *)
typestate2 typestate2
else if Models.is_check_state callee_pname || else if Models.is_check_state callee_pname ||
Models.is_check_argument callee_pname then Models.is_check_argument callee_pname then
do_preconditions_check_state typestate2 do_preconditions_check_state typestate2
else typestate2 else typestate2
end end
@ -765,7 +765,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
begin begin
match Errdesc.find_normal_variable_funcall node' id with match Errdesc.find_normal_variable_funcall node' id with
| Some (Sil.Const (Sil.Cfun pn), e1:: _, loc, call_flags) when | Some (Sil.Const (Sil.Cfun pn), e1:: _, loc, call_flags) when
filter_callee pn -> filter_callee pn ->
Some e1 Some e1
| _ -> None | _ -> None
end end
@ -889,14 +889,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> typestate in | _ -> typestate in
(** Handle assigment fron a temp pvar in a condition. (** Handle assigment fron a temp pvar in a condition.
This recognizes the handling of temp variables in ((x = ...) != null) *) This recognizes the handling of temp variables in ((x = ...) != null) *)
let handle_assignment_in_condition pvar = let handle_assignment_in_condition pvar =
match Cfg.Node.get_preds node with match Cfg.Node.get_preds node with
| [prev_node] -> | [prev_node] ->
let found = ref None in let found = ref None in
let do_instr i = match i with let do_instr i = match i with
| Sil.Set (e, _, e', _) | Sil.Set (e, _, e', _)
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') -> when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') ->
found := Some e found := Some e
| _ -> () in | _ -> () in
list_iter do_instr (Cfg.Node.get_instrs prev_node); list_iter do_instr (Cfg.Node.get_instrs prev_node);
@ -918,11 +918,11 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
else _node, c' else _node, c'
| Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar -> | Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar ->
(match handle_assignment_in_condition pvar with (match handle_assignment_in_condition pvar with
| None -> | None ->
(match Errdesc.find_program_variable_assignment _node pvar with (match Errdesc.find_program_variable_assignment _node pvar with
| Some (node', id) -> node', Sil.Var id | Some (node', id) -> node', Sil.Var id
| None -> _node, _cond) | None -> _node, _cond)
| Some e2 -> _node, e2) | Some e2 -> _node, e2)
| c -> _node, c in | c -> _node, c in
let node', ncond = normalize_cond node cond in let node', ncond = normalize_cond node cond in
@ -943,7 +943,7 @@ let typecheck_node
let typestates_exn = ref [] in let typestates_exn = ref [] in
let handle_exceptions typestate instr = match instr with let handle_exceptions typestate instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pname), _, _, _) -> | Sil.Call (_, Sil.Const (Sil.Cfun callee_pname), _, _, _) ->
(* check if the call might throw an exception *) (* check if the call might throw an exception *)
let exceptions = let exceptions =
match get_proc_desc callee_pname with match get_proc_desc callee_pname with
| Some callee_pdesc -> | Some callee_pdesc ->
@ -952,9 +952,9 @@ let typecheck_node
if exceptions <> [] then if exceptions <> [] then
typestates_exn := typestate :: !typestates_exn typestates_exn := typestate :: !typestates_exn
| Sil.Set (Sil.Lvar pv, _, _, _) when | Sil.Set (Sil.Lvar pv, _, _, _) when
Sil.pvar_is_return pv && Sil.pvar_is_return pv &&
Cfg.Node.get_kind node = Cfg.Node.throw_kind -> Cfg.Node.get_kind node = Cfg.Node.throw_kind ->
(* throw instruction *) (* throw instruction *)
typestates_exn := typestate :: !typestates_exn typestates_exn := typestate :: !typestates_exn
| _ -> () in | _ -> () in

42
infer/src/checkers/typeErr.ml
Unescape View File

@ -70,7 +70,7 @@ type err_instance =
| Field_over_annotated of Ident.fieldname * Procname.t | Field_over_annotated of Ident.fieldname * Procname.t
| Null_field_access of string option * Ident.fieldname * origin_descr * bool | Null_field_access of string option * Ident.fieldname * origin_descr * bool
| Call_receiver_annotation_inconsistent | Call_receiver_annotation_inconsistent
of Annotations.annotation * string option * Procname.t * origin_descr of Annotations.annotation * string option * Procname.t * origin_descr
| Parameter_annotation_inconsistent of parameter_not_nullable | Parameter_annotation_inconsistent of parameter_not_nullable
| Return_annotation_inconsistent of Annotations.annotation * Procname.t * origin_descr | Return_annotation_inconsistent of Annotations.annotation * Procname.t * origin_descr
| Return_over_annotated of Procname.t | Return_over_annotated of Procname.t
@ -110,14 +110,14 @@ module H = Hashtbl.Make(struct
| Null_field_access _, _ | Null_field_access _, _
| _, Null_field_access _ -> false | _, Null_field_access _ -> false
| Call_receiver_annotation_inconsistent (ann1, so1, pn1, od1), | Call_receiver_annotation_inconsistent (ann1, so1, pn1, od1),
Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) -> Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) ->
ann1 = ann2 && ann1 = ann2 &&
(opt_equal string_equal) so1 so2 && (opt_equal string_equal) so1 so2 &&
Procname.equal pn1 pn2 Procname.equal pn1 pn2
| Call_receiver_annotation_inconsistent _, _ | Call_receiver_annotation_inconsistent _, _
| _, Call_receiver_annotation_inconsistent _ -> false | _, Call_receiver_annotation_inconsistent _ -> false
| Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, od1), | Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, od1),
Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) -> Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) ->
ann1 = ann2 && ann1 = ann2 &&
string_equal s1 s2 && string_equal s1 s2 &&
int_equal n1 n2 && int_equal n1 n2 &&
@ -126,18 +126,18 @@ module H = Hashtbl.Make(struct
| Parameter_annotation_inconsistent _, _ | Parameter_annotation_inconsistent _, _
| _, Parameter_annotation_inconsistent _ -> false | _, Parameter_annotation_inconsistent _ -> false
| Return_annotation_inconsistent (ann1, pn1, od1), | Return_annotation_inconsistent (ann1, pn1, od1),
Return_annotation_inconsistent (ann2, pn2, od2) -> Return_annotation_inconsistent (ann2, pn2, od2) ->
ann1 = ann2 && Procname.equal pn1 pn2 ann1 = ann2 && Procname.equal pn1 pn2
| Return_annotation_inconsistent _, _ | Return_annotation_inconsistent _, _
| _, Return_annotation_inconsistent _ -> false | _, Return_annotation_inconsistent _ -> false
| Return_over_annotated pn1, Return_over_annotated pn2 -> | Return_over_annotated pn1, Return_over_annotated pn2 ->
Procname.equal pn1 pn2 Procname.equal pn1 pn2
| Inconsistent_subclass_return_annotation (pn1, spn1), | Inconsistent_subclass_return_annotation (pn1, spn1),
Inconsistent_subclass_return_annotation (pn2, spn2) -> Inconsistent_subclass_return_annotation (pn2, spn2) ->
if Procname.equal pn1 pn2 then true if Procname.equal pn1 pn2 then true
else Procname.equal spn1 spn2 else Procname.equal spn1 spn2
| Inconsistent_subclass_parameter_annotation (param_name_1, pos_1, pn_1, overriden_pn_1), | Inconsistent_subclass_parameter_annotation (param_name_1, pos_1, pn_1, overriden_pn_1),
Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) -> Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) ->
string_equal param_name_1 param_name_2 && string_equal param_name_1 param_name_2 &&
int_equal pos_1 pos_2 && int_equal pos_1 pos_2 &&
Procname.equal pn_1 pn_2 && Procname.equal pn_1 pn_2 &&
@ -201,8 +201,8 @@ let err_tbl : err_state H.t =
let reset () = H.reset err_tbl let reset () = H.reset err_tbl
(** Get the forall status of an err_instance. (** Get the forall status of an err_instance.
The forall status indicates that the error should be printed only if it The forall status indicates that the error should be printed only if it
occurs on every path. *) occurs on every path. *)
let get_forall = function let get_forall = function
| Condition_redundant _ -> true | Condition_redundant _ -> true
| Field_not_initialized _ -> false | Field_not_initialized _ -> false
@ -219,7 +219,7 @@ let get_forall = function
(** Reset the always field of the forall erros in the node, so if they are not set again (** Reset the always field of the forall erros in the node, so if they are not set again
we know that they don't fire on every path. *) we know that they don't fire on every path. *)
let node_reset_forall node = let node_reset_forall node =
let iter (err_instance, instr_ref_opt) err_state = let iter (err_instance, instr_ref_opt) err_state =
match instr_ref_opt, get_forall err_instance with match instr_ref_opt, get_forall err_instance with
@ -255,10 +255,10 @@ module Strict = struct
let this_type_get_strict signature = let this_type_get_strict signature =
match signature.Annotations.params with match signature.Annotations.params with
| ("this", _, this_type):: _ -> begin | ("this", _, this_type):: _ -> begin
match PatternMatch.type_get_annotation this_type with match PatternMatch.type_get_annotation this_type with
| Some ia -> Annotations.ia_get_strict ia | Some ia -> Annotations.ia_get_strict ia
| None -> None | None -> None
end end
| _ -> None | _ -> None
let signature_get_strict signature = let signature_get_strict signature =
@ -283,7 +283,7 @@ module Strict = struct
| Null_field_access (_, _, origin_descr, _) -> | Null_field_access (_, _, origin_descr, _) ->
origin_descr_get_strict origin_descr origin_descr_get_strict origin_descr
| Parameter_annotation_inconsistent (Annotations.Nullable, _, _, _, _, origin_descr) | Parameter_annotation_inconsistent (Annotations.Nullable, _, _, _, _, origin_descr)
when report_on_method_arguments -> when report_on_method_arguments ->
origin_descr_get_strict origin_descr origin_descr_get_strict origin_descr
| _ -> None | _ -> None
end (* Strict *) end (* Strict *)
@ -434,12 +434,12 @@ let report_error_now
s s
origin_desc origin_desc
| Annotations.Present -> "ERADICATE_PARAMETER_VALUE_ABSENT", | Annotations.Present -> "ERADICATE_PARAMETER_VALUE_ABSENT",
P.sprintf P.sprintf
"`%s` needs a present value in parameter %d but argument `%s` can be absent. %s" "`%s` needs a present value in parameter %d but argument `%s` can be absent. %s"
(Procname.to_simplified_string pn) (Procname.to_simplified_string pn)
n n
s s
origin_desc in origin_desc in
true, true,
kind_s, kind_s,
description, description,
@ -518,7 +518,7 @@ let report_error_now
(** Report an error unless is has been reported already, or unless it's a forall error (** Report an error unless is has been reported already, or unless it's a forall error
since it requires waiting until the end of the analysis and be printed by flush. *) since it requires waiting until the end of the analysis and be printed by flush. *)
let report_error st_report_error find_canonical_duplicate node let report_error st_report_error find_canonical_duplicate node
err_instance instr_ref_opt loc proc_name = err_instance instr_ref_opt loc proc_name =
let should_report_now = let should_report_now =

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

@ -83,8 +83,8 @@ let get_description origin =
| Some ann -> | Some ann ->
let str = "@Strict" in let str = "@Strict" in
(match ann.Sil.parameters with (match ann.Sil.parameters with
| par1 :: _ -> Printf.sprintf "%s(%s) " str par1 | par1 :: _ -> Printf.sprintf "%s(%s) " str par1
| [] -> Printf.sprintf "%s " str) | [] -> Printf.sprintf "%s " str)
| None -> "" in | None -> "" in
let description = Printf.sprintf let description = Printf.sprintf
"call to %s%s %s" "call to %s%s %s"

28
infer/src/checkers/typeState.ml
Unescape View File

@ -24,8 +24,8 @@ type 'a ext =
{ {
empty : 'a; (** empty extension *) empty : 'a; (** empty extension *)
check_instr : (** check the extension for an instruction *) check_instr : (** check the extension for an instruction *)
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t
-> 'a -> Sil.instr -> parameters -> 'a; -> 'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *) join : 'a -> 'a -> 'a; (** join two extensions *)
pp : Format.formatter -> 'a -> unit (** pretty print an extension *) pp : Format.formatter -> 'a -> unit (** pretty print an extension *)
} }
@ -99,23 +99,23 @@ let map_join m1 m2 =
try try
let range1 = M.find exp2 m1 in let range1 = M.find exp2 m1 in
(match range_join range1 range2 with (match range_join range1 range2 with
| None -> () | None -> ()
| Some range' -> tjoined := M.add exp2 range' !tjoined) | Some range' -> tjoined := M.add exp2 range' !tjoined)
with Not_found -> with Not_found ->
let (t2, ta2, locs2) = range2 in let (t2, ta2, locs2) = range2 in
let range2' = let range2' =
let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in
(t2, ta2', locs2) in (t2, ta2', locs2) in
tjoined := M.add exp2 range2' !tjoined in tjoined := M.add exp2 range2' !tjoined in
let missing_rhs exp1 range1 = (* handle elements missing in the rhs *) let missing_rhs exp1 range1 = (* handle elements missing in the rhs *)
try try
ignore (M.find exp1 m2) ignore (M.find exp1 m2)
with Not_found -> with Not_found ->
let (t1, ta1, locs1) = range1 in let (t1, ta1, locs1) = range1 in
let range1' = let range1' =
let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in
(t1, ta1', locs1) in (t1, ta1', locs1) in
tjoined := M.add exp1 range1' !tjoined in tjoined := M.add exp1 range1' !tjoined in
if m1 == m2 then m1 if m1 == m2 then m1
else else
try try

18
infer/src/clang/ast_expressions.ml
Unescape View File

@ -373,7 +373,7 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n =
let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in
let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in
let decl_info = { empty_decl_info let decl_info = { empty_decl_info
with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in
let var_decl_info = { empty_var_decl with vdi_init_expr = Some block_def } in let var_decl_info = { empty_var_decl with vdi_init_expr = Some block_def } in
let block_var_decl = VarDecl(decl_info, block_name_info, ei.ei_qual_type, var_decl_info) in let block_var_decl = VarDecl(decl_info, block_name_info, ei.ei_qual_type, var_decl_info) in
let decl_stmt = DeclStmt(stmt_info,[], [block_var_decl]) in let decl_stmt = DeclStmt(stmt_info,[], [block_var_decl]) in
@ -495,8 +495,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
| ParmVarDecl(di, name, qt, _) -> | ParmVarDecl(di, name, qt, _) ->
let qt_fun = create_void_unsigned_long_type () in let qt_fun = create_void_unsigned_long_type () in
let parameter = UnaryExprOrTypeTraitExpr((fresh_stmt_info stmt_info), [], let parameter = UnaryExprOrTypeTraitExpr((fresh_stmt_info stmt_info), [],
make_expr_info (create_unsigned_long_type ()), make_expr_info (create_unsigned_long_type ()),
{ Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in { Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in
let malloc = create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.malloc qt_fun [parameter] in let malloc = create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.malloc qt_fun [parameter] in
let init_exp = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in let init_exp = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in
make_DeclStmt (fresh_stmt_info stmt_info) di qt name (Some init_exp) make_DeclStmt (fresh_stmt_info stmt_info) di qt name (Some init_exp)
@ -551,8 +551,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let ei_idx = get_ei_from_cast decl_ref_expr_idx in let ei_idx = get_ei_from_cast decl_ref_expr_idx in
let ove_idx = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_idx ei_idx in let ove_idx = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_idx ei_idx in
let objc_sre = ObjCSubscriptRefExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], let objc_sre = ObjCSubscriptRefExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx],
make_expr_info (pseudo_object_qt ()), make_expr_info (pseudo_object_qt ()),
{ osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in { osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in
let obj_c_message_expr_info = { omei_selector = CFrontend_config.object_at_indexed_subscript_m; omei_receiver_kind =`Instance } in let obj_c_message_expr_info = { omei_selector = CFrontend_config.object_at_indexed_subscript_m; omei_receiver_kind =`Instance } in
let ome = ObjCMessageExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in let ome = ObjCMessageExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in
let pseudo_obj_expr = PseudoObjectExpr((fresh_stmt_info stmt_info), [objc_sre; ove_array; ove_idx; ome], poe_ei) in let pseudo_obj_expr = PseudoObjectExpr((fresh_stmt_info stmt_info), [objc_sre; ove_array; ove_idx; ome], poe_ei) in
@ -625,8 +625,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let if_stop = build_if_stop stop_cast in let if_stop = build_if_stop stop_cast in
let free_stop = free_stop pstop in let free_stop = free_stop pstop in
[ objects_decl; block_decl; decl_stop; assign_stop; [ objects_decl; block_decl; decl_stop; assign_stop;
ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr; ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr;
CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op
| _ -> assert false in | _ -> assert false in
match stmt_list with match stmt_list with
@ -636,8 +636,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let translated_stmt, op = translate bdi.Clang_ast_t.bdi_parameters s block_decl bei.Clang_ast_t.ei_qual_type in let translated_stmt, op = translate bdi.Clang_ast_t.bdi_parameters s block_decl bei.Clang_ast_t.ei_qual_type in
CompoundStmt(stmt_info, translated_stmt), vars_to_register@op@bv CompoundStmt(stmt_info, translated_stmt), vars_to_register@op@bv
| _ -> (* When it is not the method we expect with only one parameter, we don't translate *) | _ -> (* When it is not the method we expect with only one parameter, we don't translate *)
Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info); Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info);
CompoundStmt(stmt_info, stmt_list), [] CompoundStmt(stmt_info, stmt_list), []
(* We translate the logical negation of an integer with a conditional*) (* We translate the logical negation of an integer with a conditional*)
(* !x <=> x?0:1 *) (* !x <=> x?0:1 *)

14
infer/src/clang/cArithmetic_trans.ml
Unescape View File

@ -28,24 +28,24 @@ let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl =
Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in
match typ with match typ with
| Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && not is_e1_decl -> | Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && not is_e1_decl ->
(* for __strong e1 = e2 the semantics is*) (* for __strong e1 = e2 the semantics is*)
(* retain(e2); tmp=e1; e1=e2; release(tmp); *) (* retain(e2); tmp=e1; e1=e2; release(tmp); *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
let id = Ident.create_fresh Ident.knormal in let id = Ident.create_fresh Ident.knormal in
let tmp_assign = Sil.Letderef(id, e1, typ, loc) in let tmp_assign = Sil.Letderef(id, e1, typ, loc) in
let release = mk_call release_pname (Sil.Var id) typ in let release = mk_call release_pname (Sil.Var id) typ in
(e1,[retain; tmp_assign; assign; release ], [id]) (e1,[retain; tmp_assign; assign; release ], [id])
| Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && is_e1_decl -> | Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && is_e1_decl ->
(* for A __strong *e1 = e2 the semantics is*) (* for A __strong *e1 = e2 the semantics is*)
(* retain(e2); e1=e2; *) (* retain(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
(e1,[retain; assign ], []) (e1,[retain; assign ], [])
| Sil.Tptr (t, Sil.Pk_objc_weak) | Sil.Tptr (t, Sil.Pk_objc_weak)
| Sil.Tptr (t, Sil.Pk_objc_unsafe_unretained) -> | Sil.Tptr (t, Sil.Pk_objc_unsafe_unretained) ->
(e1, [assign],[]) (e1, [assign],[])
| Sil.Tptr (t, Sil.Pk_objc_autoreleasing) -> | Sil.Tptr (t, Sil.Pk_objc_autoreleasing) ->
(* for __autoreleasing e1 = e2 the semantics is*) (* for __autoreleasing e1 = e2 the semantics is*)
(* retain(e2); autorelease(e2); e1=e2; *) (* retain(e2); autorelease(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
let autorelease = mk_call autorelease_pname e2 typ in let autorelease = mk_call autorelease_pname e2 typ in
(e1, [retain; autorelease; assign], []) (e1, [retain; autorelease; assign], [])
@ -167,7 +167,7 @@ let unary_operation_instruction uoi e typ loc =
| `Plus -> ([], e, []) | `Plus -> ([], e, [])
| `LNot -> ([], un_exp (Sil.LNot), []) | `LNot -> ([], un_exp (Sil.LNot), [])
| `Deref -> | `Deref ->
(* Actual dereferencing is handled by implicit cast from rvalue to lvalue *) (* Actual dereferencing is handled by implicit cast from rvalue to lvalue *)
([], e, []) ([], e, [])
| `AddrOf -> ([], e, []) | `AddrOf -> ([], e, [])
| `Real | `Imag | `Extension -> | `Real | `Imag | `Extension ->

18
infer/src/clang/cAstProcessor.ml
Unescape View File

@ -8,8 +8,8 @@
*) *)
(** Module to preprocess location information in the AST. (** Module to preprocess location information in the AST.
The original location information is incremental, each location is a delta The original location information is incremental, each location is a delta
w.r.t. the previous one. This module processes the AST and makes locations explicit. *) w.r.t. the previous one. This module processes the AST and makes locations explicit. *)
open Utils open Utils
open Clang_ast_j open Clang_ast_j
@ -140,7 +140,7 @@ let pp_ast_decl fmt ast_decl =
(** Compose incremental location information and make locations explicit. *) (** Compose incremental location information and make locations explicit. *)
module LocComposer : sig module LocComposer : sig
(** Status of the composer. *) (** Status of the composer. *)
type status type status
(** Create a new composer with the initial status. *) (** Create a new composer with the initial status. *)
@ -150,9 +150,9 @@ module LocComposer : sig
val compose : status -> source_range -> source_range val compose : status -> source_range -> source_range
(** Set the current file if specified in the source_range. (** Set the current file if specified in the source_range.
The composer will not descend into file included from the current one. The composer will not descend into file included from the current one.
For locations in included files, it will return instead the last known For locations in included files, it will return instead the last known
location of the current file. *) location of the current file. *)
val set_current_file : status -> source_range -> unit val set_current_file : status -> source_range -> unit
end = struct end = struct
type status = type status =
@ -271,9 +271,9 @@ and decl_process_locs loc_composer decl =
(** Process locations in the AST by making them explicit. (** Process locations in the AST by making them explicit.
Each toplevel declaration determines the current file, Each toplevel declaration determines the current file,
and once diving into the details of the declaration, location and once diving into the details of the declaration, location
information about other (include) files is ignored. *) information about other (include) files is ignored. *)
let ast_decl_process_locs loc_composer ast_decl = let ast_decl_process_locs loc_composer ast_decl =
let toplevel_decl_process_locs decl = let toplevel_decl_process_locs decl =

66
infer/src/clang/cContext.ml
Unescape View File

@ -103,9 +103,9 @@ struct
let print_stack var_name stack = let print_stack var_name stack =
Stack.iter Stack.iter
(fun (var_name, typ, level) -> (fun (var_name, typ, level) ->
Printing.log_out "var item %s:" (Mangled.to_string var_name); Printing.log_out "var item %s:" (Mangled.to_string var_name);
Printing.log_out "%s" (Sil.typ_to_string typ); Printing.log_out "%s" (Sil.typ_to_string typ);
Printing.log_out "- %s @." (string_of_int level)) stack in Printing.log_out "- %s @." (string_of_int level)) stack in
Printing.log_out "LOCAL VARS:@\n"; Printing.log_out "LOCAL VARS:@\n";
StringMap.iter print_stack context.local_vars_stack StringMap.iter print_stack context.local_vars_stack
@ -125,9 +125,9 @@ struct
try try
StringMap.find pointer context.local_vars_pointer StringMap.find pointer context.local_vars_pointer
with Not_found -> with Not_found ->
(Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer); (Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer);
print_pointer_vars context; print_pointer_vars context;
assert false assert false
let lookup_var_locals context procname var_name = let lookup_var_locals context procname var_name =
let stack = lookup_var_map context var_name in let stack = lookup_var_map context var_name in
@ -141,37 +141,37 @@ struct
try try
Some (fst (lookup_var_locals context procname var_name)) Some (fst (lookup_var_locals context procname var_name))
with Stack.Empty -> with Stack.Empty ->
try try
Some (fst (lookup_var_globals context procname var_name)) Some (fst (lookup_var_globals context procname var_name))
with Not_found -> with Not_found ->
if is_captured_var context var_name then if is_captured_var context var_name then
try (* if it's a captured variable we need to look at the parameters list*) try (* if it's a captured variable we need to look at the parameters list*)
Some (fst (lookup_var_formals context procname var_name)) Some (fst (lookup_var_formals context procname var_name))
with Not_found -> with Not_found ->
Printing.log_err "Variable %s not found!!\n%!" var_name; Printing.log_err "Variable %s not found!!\n%!" var_name;
print_locals context; print_locals context;
None None
else None else None
else if (kind = `ParmVar) then else if (kind = `ParmVar) then
try try
Some (fst (lookup_var_formals context procname var_name)) Some (fst (lookup_var_formals context procname var_name))
with Not_found -> with Not_found ->
let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in
Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name; Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name;
Printing.log_err "Formals of procdesc %s" (Procname.to_string procname); Printing.log_err "Formals of procdesc %s" (Procname.to_string procname);
Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc)); Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc));
Printing.print_failure_info pointer; Printing.print_failure_info pointer;
assert false assert false
else if (kind = `Function || kind = `ImplicitParam) then ( else if (kind = `Function || kind = `ImplicitParam) then (
(* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *) (* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *)
Printing.log_err "Creating a variable for '%s' \n%!" var_name; Printing.log_err "Creating a variable for '%s' \n%!" var_name;
Some (Sil.mk_pvar (Mangled.from_string var_name) procname)) Some (Sil.mk_pvar (Mangled.from_string var_name) procname))
else if (kind = `EnumConstant) then else if (kind = `EnumConstant) then
(Printing.print_failure_info pointer; (Printing.print_failure_info pointer;
assert false) assert false)
else (Printing.log_err "WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind); else (Printing.log_err "WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind);
Printing.print_failure_info pointer; Printing.print_failure_info pointer;
assert false) assert false)
let get_variable_name name = let get_variable_name name =
Mangled.mangled name ((string_of_int(Block.depth ()))) Mangled.mangled name ((string_of_int(Block.depth ())))
@ -201,8 +201,8 @@ struct
let (top_var, top_typ, top_level) = Stack.top stack in let (top_var, top_typ, top_level) = Stack.top stack in
if top_level == (Block.depth ()) then if top_level == (Block.depth ()) then
(ignore (Stack.pop stack); (ignore (Stack.pop stack);
context.local_vars_stack <- context.local_vars_stack <-
StringMap.add var_name stack context.local_vars_stack) StringMap.add var_name stack context.local_vars_stack)
else () else ()
with Stack.Empty -> () in with Stack.Empty -> () in
StringMap.iter remove_top context.local_vars_stack StringMap.iter remove_top context.local_vars_stack
@ -256,7 +256,7 @@ let curr_class_to_string curr_class =
match curr_class with match curr_class with
| ContextCls (name, superclass, protocols) -> | ContextCls (name, superclass, protocols) ->
("class " ^ name ^ ", superclass: " ^ (Option.default "" superclass) ^ ("class " ^ name ^ ", superclass: " ^ (Option.default "" superclass) ^
", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols)) ", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols))
| ContextCategory (name, cls) -> ("category " ^ name ^ " of class " ^ cls) | ContextCategory (name, cls) -> ("category " ^ name ^ " of class " ^ cls)
| ContextProtocol name -> ("protocol " ^ name) | ContextProtocol name -> ("protocol " ^ name)
| ContextNoCls -> "no class" | ContextNoCls -> "no class"
@ -297,8 +297,8 @@ let create_curr_class tenv class_name =
match Sil.tenv_lookup tenv class_tn_name with match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) -> | Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) ->
(let superclasses_names = list_map (fun (_, name) -> Mangled.to_string name) superclasses in (let superclasses_names = list_map (fun (_, name) -> Mangled.to_string name) superclasses in
match superclasses_names with match superclasses_names with
| superclass:: protocols -> | superclass:: protocols ->
ContextCls (class_name, Some superclass, protocols) ContextCls (class_name, Some superclass, protocols)
| [] -> ContextCls (class_name, None, [])) | [] -> ContextCls (class_name, None, []))
| _ -> assert false | _ -> assert false

46
infer/src/clang/cEnum_decl.ml
Unescape View File

@ -30,16 +30,16 @@ let create_empty_procdesc () =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = Cfg.Node.create_cfg (); cfg = Cfg.Node.create_cfg ();
name = procname; name = procname;
is_defined = false; is_defined = false;
ret_type = Sil.Tvoid; ret_type = Sil.Tvoid;
formals = []; formals = [];
locals = []; locals = [];
captured = []; captured = [];
loc = Sil.loc_none; loc = Sil.loc_none;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} }
(* We will use global_procdesc for storing global variables. *) (* We will use global_procdesc for storing global variables. *)
(* Globals will be stored as locals in global_procdesc and they are added*) (* Globals will be stored as locals in global_procdesc and they are added*)
@ -52,19 +52,19 @@ let rec get_enum_constants context decl_list v =
| EnumConstantDecl(decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' -> | EnumConstantDecl(decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' ->
let name = name_info.Clang_ast_t.ni_name in let name = name_info.Clang_ast_t.ni_name in
(match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with (match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with
| None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v)); | None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v));
(Mangled.from_string name, Sil.Cint (Sil.Int.of_int v)) (Mangled.from_string name, Sil.Cint (Sil.Int.of_int v))
:: get_enum_constants context decl_list' (v + 1) :: get_enum_constants context decl_list' (v + 1)
| Some stmt -> | Some stmt ->
let e = CGen_trans.CTransImpl.expression_trans context stmt let e = CGen_trans.CTransImpl.expression_trans context stmt
"WARNING: Expression in Enumeration constant not found\n" in "WARNING: Expression in Enumeration constant not found\n" in
let const = (match Prop.exp_normalize_prop Prop.prop_emp e with let const = (match Prop.exp_normalize_prop Prop.prop_emp e with
| Sil.Const c -> c | Sil.Const c -> c
| _ -> (* This is a hack to avoid failing in some strange definition of Enum *) | _ -> (* This is a hack to avoid failing in some strange definition of Enum *)
Sil.Cint Sil.Int.zero) in Sil.Cint Sil.Int.zero) in
Printing.log_out " ...Defining Enum Constant ('%s', " name; Printing.log_out " ...Defining Enum Constant ('%s', " name;
Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const)); Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const));
(Mangled.from_string name, const) :: get_enum_constants context decl_list' v) (Mangled.from_string name, const) :: get_enum_constants context decl_list' v)
| _ -> assert false | _ -> assert false
let enum_decl name tenv cfg cg namespace decl_list opt_type = let enum_decl name tenv cfg cg namespace decl_list opt_type =

18
infer/src/clang/cField_decl.ml
Unescape View File

@ -32,8 +32,8 @@ let fields_superclass tenv interface_decl_info =
match interface_decl_info.Clang_ast_t.otdi_super with match interface_decl_info.Clang_ast_t.otdi_super with
| Some dr -> | Some dr ->
(match dr.Clang_ast_t.dr_name with (match dr.Clang_ast_t.dr_name with
| Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name) | Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name)
| _ -> []) | _ -> [])
| _ -> [] | _ -> []
let get_field_www name_field fl = let get_field_www name_field fl =
@ -70,12 +70,12 @@ let ivar_property curr_class ivar =
match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with
| Some pname' -> | Some pname' ->
(Printing.log_out "Found property name from ivar: '%s'" pname'; (Printing.log_out "Found property name from ivar: '%s'" pname';
try try
let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in
atts atts
with Not_found -> with Not_found ->
Printing.log_out "Didn't find property for pname '%s'" pname'; Printing.log_out "Didn't find property for pname '%s'" pname';
[]) [])
| None -> Printing.log_out "No property found for ivar '%s'@." ivar; | None -> Printing.log_out "No property found for ivar '%s'@." ivar;
[] []
@ -102,7 +102,7 @@ let rec get_fields tenv curr_class decl_list =
Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ)); Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ));
list_iter (fun (ia', _) -> list_iter (fun (ia', _) ->
list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia; list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia;
(fname, typ, ia):: fields (fname, typ, ia):: fields
| ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' -> | ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' ->

4
infer/src/clang/cFrontend.ml
Unescape View File

@ -76,7 +76,7 @@ let rec translate_one_declaration tenv cg cfg namespace dec =
CMethod_declImpl.process_methods tenv cg cfg curr_class namespace decl_list CMethod_declImpl.process_methods tenv cg cfg curr_class namespace decl_list
| EnumDecl(decl_info, name_info, opt_type, decl_list, decl_context_info, enum_decl_info) | EnumDecl(decl_info, name_info, opt_type, decl_list, decl_context_info, enum_decl_info)
when should_translate_enum -> when should_translate_enum ->
let name = name_info.Clang_ast_t.ni_name in let name = name_info.Clang_ast_t.ni_name in
CEnum_decl.enum_decl name tenv cfg cg namespace decl_list opt_type CEnum_decl.enum_decl name tenv cfg cg namespace decl_list opt_type
@ -155,5 +155,5 @@ let do_source_file source_file ast =
if !CFrontend_config.stats_mode then Cfg.check_cfg_connectedness cfg; if !CFrontend_config.stats_mode then Cfg.check_cfg_connectedness cfg;
if !CFrontend_config.stats_mode || !CFrontend_config.debug_mode || !CFrontend_config.testing_mode then if !CFrontend_config.stats_mode || !CFrontend_config.debug_mode || !CFrontend_config.testing_mode then
(Dotty.print_icfg_dotty cfg []; (Dotty.print_icfg_dotty cfg [];
Cg.save_call_graph_dotty None Specs.get_specs call_graph) Cg.save_call_graph_dotty None Specs.get_specs call_graph)

94
infer/src/clang/cFrontend_utils.ml
Unescape View File

@ -34,59 +34,59 @@ struct
let print_tenv tenv = let print_tenv tenv =
Sil.tenv_iter (fun typname typ -> Sil.tenv_iter (fun typname typ ->
match typname with match typname with
| Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) -> | Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) ->
(match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> (match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline ( (print_endline (
(Sil.typename_to_string typname)^"\n"^ (Sil.typename_to_string typname)^"\n"^
"---> superclass and protocols "^(list_to_string (fun (csu, x) -> "---> superclass and protocols "^(list_to_string (fun (csu, x) ->
let nsu = Sil.TN_csu (csu, x) in let nsu = Sil.TN_csu (csu, x) in
"\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^ "\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^
"---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^ "---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^
"\t---> static fields "^(list_to_string (fun (fieldname, typ, _) -> "\t---> static fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^ "\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") static_fields)^ (Sil.typ_to_string typ)^"\n") static_fields)^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> "\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^ "\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields (Sil.typ_to_string typ)^"\n") fields
) )
) )
) )
| _ -> ()) | _ -> ())
| _ -> () | _ -> ()
) tenv ) tenv
let print_tenv_struct_unions tenv = let print_tenv_struct_unions tenv =
Sil.tenv_iter (fun typname typ -> Sil.tenv_iter (fun typname typ ->
match typname with match typname with
| Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) -> | Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) ->
(match typ with (match typ with
| (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> | (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline ( (print_endline (
(Sil.typename_to_string typname)^"\n"^ (Sil.typename_to_string typname)^"\n"^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> "\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
match typ with match typ with
| Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname) | Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname)
| Sil.Tstruct (_, _, _, _, _, _, _) | _ -> | Sil.Tstruct (_, _, _, _, _, _, _) | _ ->
"\t struct "^(Ident.fieldname_to_string fieldname)^" "^ "\t struct "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields (Sil.typ_to_string typ)^"\n") fields
) )
) )
) )
| _ -> ()) | _ -> ())
| Sil.TN_typedef typname -> | Sil.TN_typedef typname ->
print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ)) print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ))
| _ -> () | _ -> ()
) tenv ) tenv
let print_procedures cfg = let print_procedures cfg =
let procs = Cfg.get_all_procs cfg in let procs = Cfg.get_all_procs cfg in
print_endline print_endline
(list_to_string (fun pdesc -> (list_to_string (fun pdesc ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
"name> "^ "name> "^
(Procname.to_string pname) ^ (Procname.to_string pname) ^
" defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n") " defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n")
procs) procs)
let print_failure_info pointer = let print_failure_info pointer =
@ -133,8 +133,8 @@ struct
match stmt with match stmt with
| OpaqueValueExpr(_, lstmt, _, opaque_value_expr_info) -> | OpaqueValueExpr(_, lstmt, _, opaque_value_expr_info) ->
(match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with
| Some stmt -> lstmt@[stmt] | Some stmt -> lstmt@[stmt]
| _ -> lstmt) | _ -> lstmt)
(* given that this has not been translated, looking up for variables *) (* given that this has not been translated, looking up for variables *)
(* inside leads to inconsistencies *) (* inside leads to inconsistencies *)
| ObjCAtCatchStmt (stmt_info, stmt_list, obj_c_message_expr_kind) -> | ObjCAtCatchStmt (stmt_info, stmt_list, obj_c_message_expr_kind) ->
@ -152,8 +152,8 @@ struct
match property_impl_decl_info.Clang_ast_t.opidi_property_decl with match property_impl_decl_info.Clang_ast_t.opidi_property_decl with
| Some decl_ref -> | Some decl_ref ->
(match decl_ref.Clang_ast_t.dr_name with (match decl_ref.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name | Some n -> n.Clang_ast_t.ni_name
| _ -> no_property_name) | _ -> no_property_name)
| None -> no_property_name | None -> no_property_name
let generated_ivar_name property_name = let generated_ivar_name property_name =

2
infer/src/clang/cGlobal_vars.ml
Unescape View File

@ -54,4 +54,4 @@ let print_map () =
(Sil.pp_typ_full Utils.pe_text) value._type in (Sil.pp_typ_full Utils.pe_text) value._type in
if !CFrontend_config.debug_mode then if !CFrontend_config.debug_mode then
(L.out "GLOBAL VARS:@."; (L.out "GLOBAL VARS:@.";
MangledMap.iter print_item !varMap) MangledMap.iter print_item !varMap)

50
infer/src/clang/cLocation.ml
Unescape View File

@ -26,15 +26,15 @@ let init_curr_source_file source_file =
let source_file_from_path path = let source_file_from_path path =
if Filename.is_relative path then if Filename.is_relative path then
(Logging.out (Logging.out
"ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@." "ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@."
path; path;
exit 1); exit 1);
match !Config.project_root with match !Config.project_root with
| Some root -> | Some root ->
(try (try
DB.rel_source_file_from_abs_path root path DB.rel_source_file_from_abs_path root path
with DB.Path_not_prefix_root -> with DB.Path_not_prefix_root ->
DB.source_file_from_string path) DB.source_file_from_string path)
| None -> DB.source_file_from_string path | None -> DB.source_file_from_string path
let choose_sloc sloc1 sloc2 prefer_first = let choose_sloc sloc1 sloc2 prefer_first =
@ -57,10 +57,10 @@ let choose_sloc_to_update_curr_file sloc1 sloc2 =
let update_curr_file di = let update_curr_file di =
match di.Clang_ast_t.di_source_range with (loc_start, loc_end) -> match di.Clang_ast_t.di_source_range with (loc_start, loc_end) ->
let loc = choose_sloc_to_update_curr_file loc_start loc_end in let loc = choose_sloc_to_update_curr_file loc_start loc_end in
(match loc.Clang_ast_t.sl_file with (match loc.Clang_ast_t.sl_file with
| Some f -> curr_file := source_file_from_path f | Some f -> curr_file := source_file_from_path f
| None -> ()) | None -> ())
let clang_to_sil_location clang_loc parent_line_number procdesc_opt = let clang_to_sil_location clang_loc parent_line_number procdesc_opt =
let line = match clang_loc.Clang_ast_t.sl_line with let line = match clang_loc.Clang_ast_t.sl_line with
@ -91,42 +91,42 @@ let clang_to_sil_location clang_loc parent_line_number procdesc_opt =
let should_translate_lib source_range = let should_translate_lib source_range =
if !CFrontend_config.no_translate_libs then if !CFrontend_config.no_translate_libs then
match source_range with (loc_start, loc_end) -> match source_range with (loc_start, loc_end) ->
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source DB.source_file_equal loc.Sil.file !DB.current_source
else true else true
let should_translate_enum source_range = let should_translate_enum source_range =
if !CFrontend_config.testing_mode then if !CFrontend_config.testing_mode then
match source_range with (loc_start, loc_end) -> match source_range with (loc_start, loc_end) ->
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source DB.source_file_equal loc.Sil.file !DB.current_source
else true else true
let get_sil_location_from_range source_range prefer_first = let get_sil_location_from_range source_range prefer_first =
match source_range with (sloc1, sloc2) -> match source_range with (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 prefer_first in let sloc = choose_sloc sloc1 sloc2 prefer_first in
clang_to_sil_location sloc (-1) None clang_to_sil_location sloc (-1) None
let get_sil_location stmt_info parent_line_number context = let get_sil_location stmt_info parent_line_number context =
match stmt_info.Clang_ast_t.si_source_range with (sloc1, sloc2) -> match stmt_info.Clang_ast_t.si_source_range with (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 true in let sloc = choose_sloc sloc1 sloc2 true in
clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context)) clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context))
let get_line stmt_info line_number = let get_line stmt_info line_number =
match stmt_info.Clang_ast_t.si_source_range with match stmt_info.Clang_ast_t.si_source_range with
| (sloc1, sloc2) -> | (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 true in let sloc = choose_sloc sloc1 sloc2 true in
(match sloc.Clang_ast_t.sl_line with (match sloc.Clang_ast_t.sl_line with
| Some l -> l | Some l -> l
| None -> line_number) | None -> line_number)
let check_source_file source_file = let check_source_file source_file =
let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in
let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in
if not allowed then if not allowed then
(Printing.log_stats "%s" (Printing.log_stats "%s"
("\nThe source file "^source_file^ ("\nThe source file "^source_file^
" should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n"); " should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n");
assert false) assert false)

102
infer/src/clang/cMain.ml
Unescape View File

@ -8,8 +8,8 @@
*) *)
(* Take as input an ast file and a C or ObjectiveC file such that the ast file (* Take as input an ast file and a C or ObjectiveC file such that the ast file
corresponds to the compilation of the C file with clang. corresponds to the compilation of the C file with clang.
Parse the ast file into a data structure and translates it into a cfg. *) Parse the ast file into a data structure and translates it into a cfg. *)
module L = Logging module L = Logging
@ -26,55 +26,55 @@ let arg_desc =
let desc = let desc =
(filter Utils.base_arg_desc) @ (filter Utils.base_arg_desc) @
[ [
"-c", "-c",
Arg.String (fun cfile -> source_file := Some cfile), Arg.String (fun cfile -> source_file := Some cfile),
Some "cfile", Some "cfile",
"C File to translate"; "C File to translate";
"-x", "-x",
Arg.String (fun lang -> CFrontend_config.lang_from_string lang), Arg.String (fun lang -> CFrontend_config.lang_from_string lang),
Some "cfile", Some "cfile",
"Language (c, objective-c, c++, objc-++)"; "Language (c, objective-c, c++, objc-++)";
"-ast", "-ast",
Arg.String (fun file -> ast_file := Some file), Arg.String (fun file -> ast_file := Some file),
Some "file", Some "file",
"AST file for the translation"; "AST file for the translation";
"-dotty_cfg_libs", "-dotty_cfg_libs",
Arg.Unit (fun _ -> Config.dotty_cfg_libs := true), Arg.Unit (fun _ -> Config.dotty_cfg_libs := true),
None, None,
"Prints the cfg of the code coming from the libraries"; "Prints the cfg of the code coming from the libraries";
"-no_headers", "-no_headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true), Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true),
None, None,
"Do not translate code in header files (default)"; "Do not translate code in header files (default)";
"-headers", "-headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false), Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false),
None, None,
"Translate code in header files"; "Translate code in header files";
"-testing_mode", "-testing_mode",
Arg.Unit (fun _ -> CFrontend_config.testing_mode := true), Arg.Unit (fun _ -> CFrontend_config.testing_mode := true),
None, None,
"Mode for testing, where no libraries are translated, including enums defined in the libraries"; "Mode for testing, where no libraries are translated, including enums defined in the libraries";
"-debug", "-debug",
Arg.Unit (fun _ -> CFrontend_config.debug_mode := true), Arg.Unit (fun _ -> CFrontend_config.debug_mode := true),
None, None,
"Enables debug mode"; "Enables debug mode";
"-stats", "-stats",
Arg.Unit (fun _ -> CFrontend_config.stats_mode := true), Arg.Unit (fun _ -> CFrontend_config.stats_mode := true),
None, None,
"Enables stats mode"; "Enables stats mode";
"-project_root", "-project_root",
Arg.String (fun s -> Arg.String (fun s ->
Config.project_root := Some (Utils.filename_to_absolute s)), Config.project_root := Some (Utils.filename_to_absolute s)),
Some "dir", Some "dir",
"Toot directory of the project"; "Toot directory of the project";
"-fobjc-arc", "-fobjc-arc",
Arg.Unit (fun s -> Config.arc_mode := true), Arg.Unit (fun s -> Config.arc_mode := true),
None, None,
"Translate with Objective-C Automatic Reference Counting (ARC)"; "Translate with Objective-C Automatic Reference Counting (ARC)";
"-models_mode", "-models_mode",
Arg.Unit (fun _ -> CFrontend_config.models_mode := true), Arg.Unit (fun _ -> CFrontend_config.models_mode := true),
None, None,
"Mode for computing the models"; "Mode for computing the models";
] in ] in
Utils.Arg2.create_options_desc false "Parsing Options" desc in Utils.Arg2.create_options_desc false "Parsing Options" desc in
base_arg base_arg
@ -123,7 +123,7 @@ let _ =
Config.print_types:= true; Config.print_types:= true;
if Option.is_none !source_file then if Option.is_none !source_file then
(Printing.log_err "Incorrect command line arguments\n"; (Printing.log_err "Incorrect command line arguments\n";
print_usage_exit ()) print_usage_exit ())
else else
match !source_file with match !source_file with
| Some path -> do_run path !ast_file | Some path -> do_run path !ast_file

102
infer/src/clang/cMethod_decl.ml
Unescape View File

@ -18,13 +18,13 @@ module L = Logging
module type CMethod_decl = sig module type CMethod_decl = sig
val process_methods : Sil.tenv -> Cg.t -> Cfg.cfg -> CContext.curr_class -> string option -> val process_methods : Sil.tenv -> Cg.t -> Cfg.cfg -> CContext.curr_class -> string option ->
Clang_ast_t.decl list -> unit Clang_ast_t.decl list -> unit
val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info -> val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info ->
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
val create_function_signature : Clang_ast_t.decl_info -> Clang_ast_t.function_decl_info -> string -> val create_function_signature : Clang_ast_t.decl_info -> Clang_ast_t.function_decl_info -> string ->
Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature
val process_getter_setter : CContext.t -> Procname.t -> bool val process_getter_setter : CContext.t -> Procname.t -> bool
end end
@ -92,8 +92,8 @@ struct
let ms = build_method_signature di procname let ms = build_method_signature di procname
(Func_decl_info (fdecl_info, CTypes.get_type qt)) is_instance is_anonym_block false in (Func_decl_info (fdecl_info, CTypes.get_type qt)) is_instance is_anonym_block false in
(match method_body_to_translate di ms fdecl_info.Clang_ast_t.fdi_body with (match method_body_to_translate di ms fdecl_info.Clang_ast_t.fdi_body with
| Some body -> Some body, ms | Some body -> Some body, ms
| None -> None, ms) | None -> None, ms)
let model_exists procname = let model_exists procname =
Specs.summary_exists_in_models procname && not !CFrontend_config.models_mode Specs.summary_exists_in_models procname && not !CFrontend_config.models_mode
@ -104,12 +104,12 @@ struct
| decl:: rest -> | decl:: rest ->
let rest_assume_calls = add_assume_not_null_calls rest attributes in let rest_assume_calls = add_assume_not_null_calls rest attributes in
(match decl with (match decl with
| ParmVarDecl(decl_info, name_info, qtype, var_decl_info) | ParmVarDecl(decl_info, name_info, qtype, var_decl_info)
when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes -> when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes ->
let name = name_info.Clang_ast_t.ni_name in let name = name_info.Clang_ast_t.ni_name in
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in
assume_call:: rest_assume_calls assume_call:: rest_assume_calls
| _ -> rest_assume_calls) | _ -> rest_assume_calls)
(* Translates the method/function's body into nodes of the cfg. *) (* Translates the method/function's body into nodes of the cfg. *)
let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance
@ -118,34 +118,34 @@ struct
"\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname); "\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname);
try try
(match Cfg.Procdesc.find_from_name cfg procname with (match Cfg.Procdesc.find_from_name cfg procname with
| Some procdesc -> | Some procdesc ->
if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then
(let context = (let context =
CContext.create_context tenv cg cfg procdesc namespace class_decl_opt CContext.create_context tenv cg cfg procdesc namespace class_decl_opt
is_objc_method captured_vars is_instance in is_objc_method captured_vars is_instance in
CVar_decl.get_fun_locals context instrs; CVar_decl.get_fun_locals context instrs;
let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in
let start_node = Cfg.Procdesc.get_start_node procdesc in let start_node = Cfg.Procdesc.get_start_node procdesc in
let exit_node = Cfg.Procdesc.get_exit_node procdesc in let exit_node = Cfg.Procdesc.get_exit_node procdesc in
Cfg.Procdesc.append_locals procdesc local_vars; Cfg.Procdesc.append_locals procdesc local_vars;
Cfg.Node.add_locals_ret_declaration start_node local_vars; Cfg.Node.add_locals_ret_declaration start_node local_vars;
Printing.log_out Printing.log_out
"\n\n>>---------- Start translating body of function: '%s' ---------<<\n@." "\n\n>>---------- Start translating body of function: '%s' ---------<<\n@."
(Procname.to_string procname); (Procname.to_string procname);
let nonnull_assume_calls = add_assume_not_null_calls param_decls in let nonnull_assume_calls = add_assume_not_null_calls param_decls in
let instrs' = instrs@nonnull_assume_calls attributes in let instrs' = instrs@nonnull_assume_calls attributes in
let meth_body_nodes = T.instructions_trans context instrs' exit_node in let meth_body_nodes = T.instructions_trans context instrs' exit_node in
if (not is_anonym_block) then CContext.LocalVars.reset_block (); if (not is_anonym_block) then CContext.LocalVars.reset_block ();
Cfg.Node.set_succs_exn start_node meth_body_nodes []; Cfg.Node.set_succs_exn start_node meth_body_nodes [];
Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc)) Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc))
| None -> ()) | None -> ())
with with
| Not_found -> () | Not_found -> ()
| CTrans_utils.Self.SelfClassException _ -> | CTrans_utils.Self.SelfClassException _ ->
assert false (* this shouldn't happen, because self or [a class] should always be arguments of functions. This is to make sure I'm not wrong. *) assert false (* this shouldn't happen, because self or [a class] should always be arguments of functions. This is to make sure I'm not wrong. *)
| Assert_failure (file, line, column) -> | Assert_failure (file, line, column) ->
print_endline ("Fatal error: exception Assert_failure("^ print_endline ("Fatal error: exception Assert_failure("^
file^", "^(string_of_int line)^", "^(string_of_int column)^")"); file^", "^(string_of_int line)^", "^(string_of_int column)^")");
Cfg.Procdesc.remove cfg procname true; Cfg.Procdesc.remove cfg procname true;
CMethod_trans.create_external_procdesc cfg procname is_objc_method None; CMethod_trans.create_external_procdesc cfg procname is_objc_method None;
() ()
@ -178,13 +178,13 @@ struct
Printing.log_out " ....Processing implementation for method '%s'\n" (Procname.to_string procname); Printing.log_out " ....Processing implementation for method '%s'\n" (Procname.to_string procname);
CMethod_signature.add ms; CMethod_signature.add ms;
(match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with (match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with
| Some body -> | Some body ->
let is_instance = CMethod_signature.ms_is_instance ms in let is_instance = CMethod_signature.ms_is_instance ms in
let attributes = CMethod_signature.ms_get_attributes ms in let attributes = CMethod_signature.ms_get_attributes ms in
if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then
add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false
method_decl_info.Clang_ast_t.omdi_parameters attributes method_decl_info.Clang_ast_t.omdi_parameters attributes
| None -> ()) | None -> ())
let rec process_one_method_decl tenv cg cfg curr_class namespace dec = let rec process_one_method_decl tenv cg cfg curr_class namespace dec =
match dec with match dec with
@ -199,7 +199,7 @@ struct
| EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> () | EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> ()
| d -> Printing.log_err | d -> Printing.log_err
"\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d); "\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d);
() ()
let process_methods tenv cg cfg curr_class namespace decl_list = let process_methods tenv cg cfg curr_class namespace decl_list =
@ -211,17 +211,17 @@ struct
let method_name = Procname.c_get_method procname in let method_name = Procname.c_get_method procname in
match ObjcProperty_decl.method_is_property_accesor cls method_name with match ObjcProperty_decl.method_is_property_accesor cls method_name with
| Some (property_name, property_type, is_getter) when | Some (property_name, property_type, is_getter) when
CMethod_trans.should_create_procdesc context.cfg procname true true -> CMethod_trans.should_create_procdesc context.cfg procname true true ->
(match property_type with qt, atts, decl_info, _, _, ivar_opt -> (match property_type with qt, atts, decl_info, _, _, ivar_opt ->
let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in
let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in
ignore (CField_decl.add_missing_fields context.tenv class_name [field]); ignore (CField_decl.add_missing_fields context.tenv class_name [field]);
let accessor = let accessor =
if is_getter then if is_getter then
ObjcProperty_decl.make_getter cls property_name property_type ObjcProperty_decl.make_getter cls property_name property_type
else ObjcProperty_decl.make_setter cls property_name property_type in else ObjcProperty_decl.make_setter cls property_name property_type in
list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor; list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor;
true) true)
| _ -> false | _ -> false
end end

104
infer/src/clang/cMethod_trans.ml
Unescape View File

@ -46,8 +46,8 @@ let resolve_method tenv class_name method_name =
| Some (Sil.TN_csu (Sil.Class, class_name)) -> | Some (Sil.TN_csu (Sil.Class, class_name)) ->
let class_method_name = mk_procname_from_method (Mangled.to_string class_name) method_name in let class_method_name = mk_procname_from_method (Mangled.to_string class_name) method_name in
(try let ms = CMethod_signature.find class_method_name in (try let ms = CMethod_signature.find class_method_name in
Some ms Some ms
with Not_found -> None) with Not_found -> None)
| _ -> None | _ -> None
let get_superclass_curr_class context = let get_superclass_curr_class context =
@ -60,8 +60,8 @@ let get_superclass_curr_class context =
| _ -> | _ ->
Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname); Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname);
(match super_opt with (match super_opt with
| Some super -> super | Some super -> super
| _ -> assert false) in | _ -> assert false) in
match CContext.get_curr_class context with match CContext.get_curr_class context with
| CContext.ContextCls (cname, super_opt, _) -> | CContext.ContextCls (cname, super_opt, _) ->
retrive_super cname super_opt retrive_super cname super_opt
@ -76,10 +76,10 @@ let get_class_selector_instance context obj_c_message_expr_info act_params =
| `Class qt -> (CTypes.get_type qt, selector, MCStatic) | `Class qt -> (CTypes.get_type qt, selector, MCStatic)
| `Instance -> | `Instance ->
(match act_params with (match act_params with
| (instance_obj, Sil.Tptr(t, _)):: _ | (instance_obj, Sil.Tptr(t, _)):: _
| (instance_obj, t):: _ -> | (instance_obj, t):: _ ->
(CTypes.classname_of_type t, selector, MCVirtual) (CTypes.classname_of_type t, selector, MCVirtual)
| _ -> assert false) | _ -> assert false)
| `SuperInstance -> | `SuperInstance ->
let superclass = get_superclass_curr_class context in let superclass = get_superclass_curr_class context in
(superclass, selector, MCNoVirtual) (superclass, selector, MCNoVirtual)
@ -115,18 +115,18 @@ let captured_vars_from_block_info context cvl =
| [] -> [] | [] -> []
| cv:: cvl'' -> | cv:: cvl'' ->
(match cv.Clang_ast_t.bcv_variable with (match cv.Clang_ast_t.bcv_variable with
| Some dr -> | Some dr ->
(match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with (match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with
| Some name_info, _ -> | Some name_info, _ ->
let n = name_info.Clang_ast_t.ni_name in let n = name_info.Clang_ast_t.ni_name in
if n = CFrontend_config.self && not context.is_instance then [] if n = CFrontend_config.self && not context.is_instance then []
else else
(let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in (let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in
(Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals)); (Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals));
let formals = list_map formal2captured procdesc_formals in let formals = list_map formal2captured procdesc_formals in
[find (context.local_vars @ formals) n]) [find (context.local_vars @ formals) n])
| _ -> assert false) | _ -> assert false)
| None -> []) :: f cvl'' in | None -> []) :: f cvl'' in
list_flatten (f cvl) list_flatten (f cvl)
let get_return_type tenv ms = let get_return_type tenv ms =
@ -153,9 +153,9 @@ let should_create_procdesc cfg procname defined generated =
let is_generated_previous = let is_generated_previous =
(Cfg.Procdesc.get_attributes prevoius_procdesc).Sil.is_generated in (Cfg.Procdesc.get_attributes prevoius_procdesc).Sil.is_generated in
if defined && if defined &&
((not is_defined_previous) || (generated && is_generated_previous)) then ((not is_defined_previous) || (generated && is_generated_previous)) then
(Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true; (Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true;
true) true)
else false else false
| None -> true | None -> true
@ -195,25 +195,25 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
Sil.is_generated = is_generated; Sil.is_generated = is_generated;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = defined; is_defined = defined;
ret_type = ret_type; ret_type = ret_type;
formals = formals; formals = formals;
locals = []; locals = [];
captured = captured'; captured = captured';
loc = loc_start; loc = loc_start;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
if defined then if defined then
(if !Config.arc_mode then (if !Config.arc_mode then
Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true"; Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true";
let start_kind = Cfg.Node.Start_node procdesc in let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in
let exit_kind = Cfg.Node.Exit_node procdesc in let exit_kind = Cfg.Node.Exit_node procdesc in
let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in
Cfg.Procdesc.set_start_node procdesc start_node; Cfg.Procdesc.set_start_node procdesc start_node;
Cfg.Procdesc.set_exit_node procdesc exit_node) in Cfg.Procdesc.set_exit_node procdesc exit_node) in
let generated = CMethod_signature.ms_is_generated ms in let generated = CMethod_signature.ms_is_generated ms in
if should_create_procdesc cfg procname defined generated then if should_create_procdesc cfg procname defined generated then
(create_new_procdesc (); true) (create_new_procdesc (); true)
@ -226,9 +226,9 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt =
| None -> | None ->
let ret_type, formals = let ret_type, formals =
(match type_opt with (match type_opt with
| Some (ret_type, arg_types) -> | Some (ret_type, arg_types) ->
ret_type, list_map (fun typ -> ("x", typ)) arg_types ret_type, list_map (fun typ -> ("x", typ)) arg_types
| None -> Sil.Tvoid, []) in | None -> Sil.Tvoid, []) in
let loc = Sil.loc_none in let loc = Sil.loc_none in
let _ = let _ =
let open Cfg.Procdesc in let open Cfg.Procdesc in
@ -246,16 +246,16 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = false; is_defined = false;
ret_type = ret_type; ret_type = ret_type;
formals = formals; formals = formals;
locals = []; locals = [];
captured = []; captured = [];
loc = loc; loc = loc;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
() ()
let instance_to_method_call_type instance = let instance_to_method_call_type instance =

2
infer/src/clang/cModule_type.ml
Unescape View File

@ -15,7 +15,7 @@ end
module type CMethod_declaration = module type CMethod_declaration =
sig sig
val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info -> val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info ->
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
val process_getter_setter : CContext.t -> Procname.t -> bool val process_getter_setter : CContext.t -> Procname.t -> bool
end end

1004
infer/src/clang/cTrans.ml
View File

File diff suppressed because it is too large Load Diff

18
infer/src/clang/cTrans_models.ml
Unescape View File

@ -32,7 +32,7 @@ let is_alloc_model typ funct =
else else
let funct = Procname.to_string procname in let funct = Procname.to_string procname in
(* if (Core_foundation_model.is_core_lib_create typ funct) then (* if (Core_foundation_model.is_core_lib_create typ funct) then
print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*) print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*)
Core_foundation_model.is_core_lib_create typ funct Core_foundation_model.is_core_lib_create typ funct
| None -> false | None -> false
@ -104,12 +104,12 @@ let builtin_predefined_model fun_stmt sil_fe =
| Some exp -> | Some exp ->
let typ = CTypes.get_type exp in let typ = CTypes.get_type exp in
(match sil_fe with (match sil_fe with
| Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false | Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false
| Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) -> | Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true
| Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) -> | Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true
| _ -> sil_fe, false) | _ -> sil_fe, false)
| _ -> sil_fe, false | _ -> sil_fe, false
(** If the function is a builtin model, return the model, otherwise return the function *) (** If the function is a builtin model, return the model, otherwise return the function *)
@ -153,7 +153,7 @@ let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname =
let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname = let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname =
let condition = (method_name = release || method_name = drain) && let condition = (method_name = release || method_name = drain) &&
(class_name = nsautorelease_pool_cl) in (class_name = nsautorelease_pool_cl) in
get_predefined_ms_method condition class_name method_name mk_procname [(self, class_name, None)] get_predefined_ms_method condition class_name method_name mk_procname [(self, class_name, None)]
void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool) void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool)
@ -177,7 +177,7 @@ let dispatch_functions = [
("dispatch_group_notify", 2); ("dispatch_group_notify", 2);
("dispatch_group_wait", 2); ("dispatch_group_wait", 2);
("dispatch_barrier_async", 1); ("dispatch_barrier_async", 1);
] ]
let is_dispatch_function_name function_name = let is_dispatch_function_name function_name =
let rec is_dispatch functions = let rec is_dispatch functions =

118
infer/src/clang/cTrans_utils.ml
Unescape View File

@ -99,10 +99,10 @@ struct
try try
Hashtbl.find goto_label_node_map label Hashtbl.find goto_label_node_map label
with Not_found -> with Not_found ->
let node_name = Format.sprintf "GotoLabel_%s" label in let node_name = Format.sprintf "GotoLabel_%s" label in
let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in
Hashtbl.add goto_label_node_map label new_node; Hashtbl.add goto_label_node_map label new_node;
new_node new_node
end end
type continuation = { type continuation = {
@ -233,8 +233,8 @@ struct
instrs =[]; instrs =[];
exps = []} exps = []}
| _, true -> | _, true ->
(* We need to create a node but params also created some,*) (* We need to create a node but params also created some,*)
(* so we need to pass back the nodes/leafs params*) (* so we need to pass back the nodes/leafs params*)
let node' = mk_node () in let node' = mk_node () in
Cfg.Node.set_succs_exn node' trans_state.succ_nodes []; Cfg.Node.set_succs_exn node' trans_state.succ_nodes [];
let ids_parent = ids_to_parent trans_state.continuation res_state_param.ids in let ids_parent = ids_to_parent trans_state.continuation res_state_param.ids in
@ -342,7 +342,7 @@ let cast_trans context exps sil_loc callee_pname_opt function_type =
let builtin_trans trans_state loc stmt_info function_type callee_pname_opt = let builtin_trans trans_state loc stmt_info function_type callee_pname_opt =
if CTrans_models.is_cf_non_null_alloc callee_pname_opt || if CTrans_models.is_cf_non_null_alloc callee_pname_opt ||
CTrans_models.is_alloc_model function_type callee_pname_opt then CTrans_models.is_alloc_model function_type callee_pname_opt then
Some (alloc_trans trans_state loc stmt_info function_type true) Some (alloc_trans trans_state loc stmt_info function_type true)
else if CTrans_models.is_alloc callee_pname_opt then else if CTrans_models.is_alloc callee_pname_opt then
Some (alloc_trans trans_state loc stmt_info function_type false) Some (alloc_trans trans_state loc stmt_info function_type false)
@ -361,8 +361,8 @@ let cast_operation context cast_kind exps cast_typ sil_loc is_objc_bridged =
| `IntegralToBoolean -> (* This is treated as a nop by returning the same expressions exps*) | `IntegralToBoolean -> (* This is treated as a nop by returning the same expressions exps*)
([],[], exp) ([],[], exp)
| `LValueToRValue -> | `LValueToRValue ->
(* Takes an LValue and allow it to use it as RValue. *) (* Takes an LValue and allow it to use it as RValue. *)
(* So we assign the LValue to a temp and we pass it to the parent.*) (* So we assign the LValue to a temp and we pass it to the parent.*)
let id = Ident.create_fresh Ident.knormal in let id = Ident.create_fresh Ident.knormal in
let sil_instr = [Sil.Letderef (id, exp, typ, sil_loc)] in let sil_instr = [Sil.Letderef (id, exp, typ, sil_loc)] in
([id], sil_instr, Sil.Var id) ([id], sil_instr, Sil.Var id)
@ -435,11 +435,11 @@ let fix_param_exps_mismatch params_stmt exps_param =
let get_name_decl_ref_exp_info decl_ref_expr_info si = let get_name_decl_ref_exp_info decl_ref_expr_info si =
match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_name with | Some d -> (match d.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name | Some n -> n.Clang_ast_t.ni_name
| _ -> assert false) | _ -> assert false)
| _ -> L.err "FAILING WITH %s pointer=%s@.@." | _ -> L.err "FAILING WITH %s pointer=%s@.@."
(Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info ) (Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info )
(Clang_ast_j.string_of_stmt_info si); assert false (Clang_ast_j.string_of_stmt_info si); assert false
let is_superinstance mei = let is_superinstance mei =
match mei.Clang_ast_t.omei_receiver_kind with match mei.Clang_ast_t.omei_receiver_kind with
@ -463,10 +463,10 @@ let get_value_enum_constant tenv enum_type stmt =
let _, v = try let _, v = try
list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants
with _ -> (Printing.log_err with _ -> (Printing.log_err
"Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in "Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in
v v
| _ -> Printing.log_err | _ -> Printing.log_err
"Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename); "Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename);
assert false assert false
let get_selector_receiver obj_c_message_expr_info = let get_selector_receiver obj_c_message_expr_info =
@ -487,10 +487,10 @@ let is_enumeration_constant stmt =
match stmt with match stmt with
| DeclRefExpr(_, _, _, drei) -> | DeclRefExpr(_, _, _, drei) ->
(match drei.Clang_ast_t.drti_decl_ref with (match drei.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_kind with | Some d -> (match d.Clang_ast_t.dr_kind with
| `EnumConstant -> true | `EnumConstant -> true
| _ -> false) | _ -> false)
| _ -> false) | _ -> false)
| _ -> false | _ -> false
let is_null_stmt s = let is_null_stmt s =
@ -511,8 +511,8 @@ let rec get_type_from_exp_stmt stmt =
let do_decl_ref_exp i = let do_decl_ref_exp i =
match i.Clang_ast_t.drti_decl_ref with match i.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_qual_type with | Some d -> (match d.Clang_ast_t.dr_qual_type with
| Some n -> n | Some n -> n
| _ -> assert false ) | _ -> assert false )
| _ -> assert false in | _ -> assert false in
match stmt with match stmt with
| CXXOperatorCallExpr(_, _, ei) | CXXOperatorCallExpr(_, _, ei)
@ -578,14 +578,14 @@ let is_owning_name n =
match Str.split (Str.regexp_string ":") n with match Str.split (Str.regexp_string ":") n with
| fst:: _ -> | fst:: _ ->
(match Str.split (Str.regexp "['_']+") fst with (match Str.split (Str.regexp "['_']+") fst with
| [no_und] | [no_und]
| _:: no_und:: _ -> | _:: no_und:: _ ->
is_family CFrontend_config.alloc no_und || is_family CFrontend_config.alloc no_und ||
is_family CFrontend_config.copy no_und || is_family CFrontend_config.copy no_und ||
is_family CFrontend_config.new_str no_und || is_family CFrontend_config.new_str no_und ||
is_family CFrontend_config.mutableCopy no_und || is_family CFrontend_config.mutableCopy no_und ||
is_family CFrontend_config.init no_und is_family CFrontend_config.init no_und
| _ -> assert false) | _ -> assert false)
| _ -> assert false | _ -> assert false
let rec is_owning_method s = let rec is_owning_method s =
@ -593,15 +593,15 @@ let rec is_owning_method s =
| ObjCMessageExpr(_, _ , _, mei) -> | ObjCMessageExpr(_, _ , _, mei) ->
is_owning_name mei.Clang_ast_t.omei_selector is_owning_name mei.Clang_ast_t.omei_selector
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false | [] -> false
| s'':: _ -> is_owning_method s'') | s'':: _ -> is_owning_method s'')
let rec is_method_call s = let rec is_method_call s =
match s with match s with
| ObjCMessageExpr(_, _ , _, mei) -> true | ObjCMessageExpr(_, _ , _, mei) -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false | [] -> false
| s'':: _ -> is_method_call s'') | s'':: _ -> is_method_call s'')
let rec get_decl_ref_info s parent_line_number = let rec get_decl_ref_info s parent_line_number =
match s with match s with
@ -609,17 +609,17 @@ let rec get_decl_ref_info s parent_line_number =
let line_number = CLocation.get_line stmt_info parent_line_number in let line_number = CLocation.get_line stmt_info parent_line_number in
stmt_info.Clang_ast_t.si_pointer, line_number stmt_info.Clang_ast_t.si_pointer, line_number
| _ -> (match Clang_ast_proj.get_stmt_tuple s with | _ -> (match Clang_ast_proj.get_stmt_tuple s with
| stmt_info, [] -> assert false | stmt_info, [] -> assert false
| stmt_info, s'':: _ -> | stmt_info, s'':: _ ->
let line_number = CLocation.get_line stmt_info parent_line_number in let line_number = CLocation.get_line stmt_info parent_line_number in
get_decl_ref_info s'' line_number) get_decl_ref_info s'' line_number)
let rec contains_opaque_value_expr s = let rec contains_opaque_value_expr s =
match s with match s with
| OpaqueValueExpr (_, _, _, _) -> true | OpaqueValueExpr (_, _, _, _) -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false | [] -> false
| s'':: _ -> contains_opaque_value_expr s'') | s'':: _ -> contains_opaque_value_expr s'')
let rec compute_autorelease_pool_vars context stmts = let rec compute_autorelease_pool_vars context stmts =
match stmts with match stmts with
@ -632,10 +632,10 @@ let rec compute_autorelease_pool_vars context stmts =
list_filter (fun (m, t) -> Mangled.to_string m = name) local_vars list_filter (fun (m, t) -> Mangled.to_string m = name) local_vars
with _ -> [] in with _ -> [] in
(match mname with (match mname with
| [(m, t)] -> | [(m, t)] ->
CFrontend_utils.General_utils.append_no_duplicated_pvars CFrontend_utils.General_utils.append_no_duplicated_pvars
[(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts') [(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts')
| _ -> compute_autorelease_pool_vars context stmts') | _ -> compute_autorelease_pool_vars context stmts')
| s:: stmts' -> | s:: stmts' ->
let sl = snd(Clang_ast_proj.get_stmt_tuple s) in let sl = snd(Clang_ast_proj.get_stmt_tuple s) in
compute_autorelease_pool_vars context (sl@stmts') compute_autorelease_pool_vars context (sl@stmts')
@ -651,21 +651,21 @@ let is_dispatch_function stmt_list =
match stmt_list with match stmt_list with
| ImplicitCastExpr(_,[DeclRefExpr(_, _, _, di)], _, _):: stmts -> | ImplicitCastExpr(_,[DeclRefExpr(_, _, _, di)], _, _):: stmts ->
(match di.Clang_ast_t.drti_decl_ref with (match di.Clang_ast_t.drti_decl_ref with
| None -> None | None -> None
| Some d -> | Some d ->
(match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with (match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with
| `Function, Some name_info -> | `Function, Some name_info ->
let s = name_info.Clang_ast_t.ni_name in let s = name_info.Clang_ast_t.ni_name in
(match (CTrans_models.is_dispatch_function_name s) with (match (CTrans_models.is_dispatch_function_name s) with
| None -> None | None -> None
| Some (dispatch_function, block_arg_pos) -> | Some (dispatch_function, block_arg_pos) ->
try try
(match list_nth stmts block_arg_pos with (match list_nth stmts block_arg_pos with
| BlockExpr _ -> Some block_arg_pos | BlockExpr _ -> Some block_arg_pos
| _ -> None) | _ -> None)
with Not_found -> None with Not_found -> None
) )
| _ -> None)) | _ -> None))
| _ -> None | _ -> None
let assign_default_params params_stmt callee_pname_opt = let assign_default_params params_stmt callee_pname_opt =
@ -683,7 +683,7 @@ let assign_default_params params_stmt callee_pname_opt =
list_map replace_default_arg params_args list_map replace_default_arg params_args
with with
| Invalid_argument _ -> | Invalid_argument _ ->
(* list_combine failed because of different list lengths *) (* list_combine failed because of different list lengths *)
Printing.log_err "Param count doesn't match %s\n" (Procname.to_string callee_pname); Printing.log_err "Param count doesn't match %s\n" (Procname.to_string callee_pname);
params_stmt params_stmt
| Not_found -> params_stmt | Not_found -> params_stmt

32
infer/src/clang/cTypes.ml
Unescape View File

@ -46,22 +46,22 @@ let lookup_var_type context pvar =
Printing.log_out "found '%s' in formals.@." (Sil.typ_to_string t); Printing.log_out "found '%s' in formals.@." (Sil.typ_to_string t);
t t
with Not_found -> with Not_found ->
try
let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in
Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar);
Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t);
t
with Not_found ->
try try
let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in
Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar); Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar);
Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t); Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ);
t typ
with Not_found -> with Not_found ->
try Printing.log_err
let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in "WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!"
Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar); (Sil.pvar_to_string pvar);
Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ); Sil.Tvoid
typ
with Not_found ->
Printing.log_err
"WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!"
(Sil.pvar_to_string pvar);
Sil.Tvoid
(* Extract the type out of a statement. This is useful when the statement *) (* Extract the type out of a statement. This is useful when the statement *)
(* denotes actually an expression *) (* denotes actually an expression *)
@ -176,8 +176,8 @@ let get_raw_qual_type_decl_ref_exp_info decl_ref_expr_info =
match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
| Some d -> | Some d ->
(match d.Clang_ast_t.dr_qual_type with (match d.Clang_ast_t.dr_qual_type with
| Some qt -> Some qt.Clang_ast_t.qt_raw | Some qt -> Some qt.Clang_ast_t.qt_raw
| None -> None) | None -> None)
| None -> None | None -> None
(* Iterates over the tenv to find the value of the enumeration constant *) (* Iterates over the tenv to find the value of the enumeration constant *)

162
infer/src/clang/cTypes_decl.ml
Unescape View File

@ -24,12 +24,12 @@ let add_predefined_types tenv =
let objc_class_name = Sil.TN_csu (Sil.Class, objc_class_mangled) in let objc_class_name = Sil.TN_csu (Sil.Class, objc_class_mangled) in
let objc_class_type_info = let objc_class_type_info =
Sil.Tstruct ([], [], Sil.Struct, Sil.Tstruct ([], [], Sil.Struct,
Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in
Sil.tenv_add tenv objc_class_name objc_class_type_info; Sil.tenv_add tenv objc_class_name objc_class_type_info;
let mn = Mangled.from_string CFrontend_config.class_type in let mn = Mangled.from_string CFrontend_config.class_type in
let class_typename = Sil.TN_typedef(mn) in let class_typename = Sil.TN_typedef(mn) in
let class_typ = Sil.Tptr ((Sil.Tvar let class_typ = Sil.Tptr ((Sil.Tvar
(Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in (Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in
Sil.tenv_add tenv class_typename class_typ; Sil.tenv_add tenv class_typename class_typ;
let typename_objc_object = let typename_objc_object =
Sil.TN_csu (Sil.Struct, Mangled.from_string CFrontend_config.objc_object) in Sil.TN_csu (Sil.Struct, Mangled.from_string CFrontend_config.objc_object) in
@ -42,24 +42,24 @@ let rec search_for_named_type tenv typ =
match typename with match typename with
| Sil.TN_typedef name -> | Sil.TN_typedef name ->
(match Sil.tenv_lookup tenv typename with (match Sil.tenv_lookup tenv typename with
| Some _ -> typename | Some _ -> typename
| None -> | None ->
let pot_class_type = Sil.TN_csu (Sil.Class, name) in let pot_class_type = Sil.TN_csu (Sil.Class, name) in
match Sil.tenv_lookup tenv pot_class_type with match Sil.tenv_lookup tenv pot_class_type with
| Some _ -> pot_class_type | Some _ -> pot_class_type
| None -> | None ->
let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in
match Sil.tenv_lookup tenv pot_protocol_type with match Sil.tenv_lookup tenv pot_protocol_type with
| Some _ -> pot_protocol_type | Some _ -> pot_protocol_type
| None -> | None ->
let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in
match Sil.tenv_lookup tenv pot_struct_type with match Sil.tenv_lookup tenv pot_struct_type with
| Some _ -> pot_struct_type | Some _ -> pot_struct_type
| None -> | None ->
let pot_union_type = Sil.TN_csu (Sil.Union, name) in let pot_union_type = Sil.TN_csu (Sil.Union, name) in
match Sil.tenv_lookup tenv pot_union_type with match Sil.tenv_lookup tenv pot_union_type with
| Some _ -> pot_union_type | Some _ -> pot_union_type
| None -> raise Typename_not_found) | None -> raise Typename_not_found)
| _ -> typename in | _ -> typename in
match typ with match typ with
| Sil.Tvar typename -> Sil.Tvar (search typename) | Sil.Tvar typename -> Sil.Tvar (search typename)
@ -85,10 +85,10 @@ let string_type_to_sil_type tenv s =
(* 'union <anonymous at union.c:4:1>'*) (* 'union <anonymous at union.c:4:1>'*)
let s = (match Str.split (Str.regexp "[ \t]+") s with let s = (match Str.split (Str.regexp "[ \t]+") s with
| "struct"::"(anonymous":: "struct":: s' -> | "struct"::"(anonymous":: "struct":: s' ->
(*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *) (*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *)
string_from_list ("struct"::"(anonymous":: s') string_from_list ("struct"::"(anonymous":: s')
| "union"::"(anonymous":: "union":: s' -> | "union"::"(anonymous":: "union":: s' ->
(*Printing.log_out " ...Getting rid of the extra 'union' word@."; *) (*Printing.log_out " ...Getting rid of the extra 'union' word@."; *)
string_from_list ("union"::"(anonymous":: s') string_from_list ("union"::"(anonymous":: s')
| _ -> s) in | _ -> s) in
let lexbuf = Lexing.from_string s in let lexbuf = Lexing.from_string s in
@ -99,14 +99,14 @@ let string_type_to_sil_type tenv s =
" ...Parsed. Translated with sil TYPE '%a'@." (Sil.pp_typ_full pe_text) t; " ...Parsed. Translated with sil TYPE '%a'@." (Sil.pp_typ_full pe_text) t;
t t
with Parsing.Parse_error -> ( with Parsing.Parse_error -> (
Printing.log_stats Printing.log_stats
"\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s; "\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s;
Sil.Tvoid) in Sil.Tvoid) in
try try
search_for_named_type tenv t search_for_named_type tenv t
with Typename_not_found -> Printing.log_stats with Typename_not_found -> Printing.log_stats
"\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s; "\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s;
t) t)
let qual_type_to_sil_type_no_expansions tenv qt = let qual_type_to_sil_type_no_expansions tenv qt =
string_type_to_sil_type tenv (CTypes.get_type qt) string_type_to_sil_type tenv (CTypes.get_type qt)
@ -129,8 +129,8 @@ let parse_func_type name func_type =
((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types)); ((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types));
Some (return_type, arg_types) Some (return_type, arg_types)
with Parsing.Parse_error -> ( with Parsing.Parse_error -> (
Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type; Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type;
None) None)
(*In case of typedef like *) (*In case of typedef like *)
(* typedef struct { f1; f2; ... } s; *) (* typedef struct { f1; f2; ... } s; *)
@ -147,18 +147,18 @@ let rec disambiguate_typedef tenv namespace t mn =
(* Eg. TN_typdef(mn) --> TN_typedef(mn). We need to break it*) (* Eg. TN_typdef(mn) --> TN_typedef(mn). We need to break it*)
let tn = Sil.TN_csu(Sil.Struct, mn) in let tn = Sil.TN_csu(Sil.Struct, mn) in
(match Sil.tenv_lookup tenv tn with (match Sil.tenv_lookup tenv tn with
| Some _ -> | Some _ ->
(* There is a struct in tenv, so we make the typedef mn pointing to the struct*) (* There is a struct in tenv, so we make the typedef mn pointing to the struct*)
Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn); Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn);
Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn); Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn);
Printing.log_out Printing.log_out
"Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@." "Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@."
(Mangled.to_string mn); (Mangled.to_string mn);
Sil.Tvar(tn) Sil.Tvar(tn)
| None -> | None ->
if add_late_defined_record tenv namespace tn then if add_late_defined_record tenv namespace tn then
disambiguate_typedef tenv namespace t mn disambiguate_typedef tenv namespace t mn
else t) else t)
else t else t
| _ -> t | _ -> t
@ -189,10 +189,10 @@ and get_struct_fields tenv record_name namespace decl_list =
let annotation_items = [] in (* For the moment we don't use them*) let annotation_items = [] in (* For the moment we don't use them*)
(id, typ, annotation_items):: get_struct_fields tenv record_name namespace decl_list' (id, typ, annotation_items):: get_struct_fields tenv record_name namespace decl_list'
| CXXRecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info) | CXXRecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decl_list' :: decl_list'
(* C++/C Records treated in the same way*) (* C++/C Records treated in the same way*)
| RecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info) | RecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decl_list'-> :: decl_list'->
do_record_declaration tenv namespace decl_info name.Clang_ast_t.ni_name opt_type decl_list decl_context_info record_decl_info; do_record_declaration tenv namespace decl_info name.Clang_ast_t.ni_name opt_type decl_list decl_context_info record_decl_info;
get_struct_fields tenv record_name namespace decl_list' get_struct_fields tenv record_name namespace decl_list'
| _ :: decl_list' -> get_struct_fields tenv record_name namespace decl_list' | _ :: decl_list' -> get_struct_fields tenv record_name namespace decl_list'
@ -234,7 +234,7 @@ and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_cont
let methods_list = [] in (* No methods list for structs *) let methods_list = [] in (* No methods list for structs *)
let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *) let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *)
Sil.Tstruct Sil.Tstruct
(non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation) (non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation)
(* Look for a record definition that is defined after it is dereferenced. *) (* Look for a record definition that is defined after it is dereferenced. *)
(* It returns true if a new record definition has been added to tenv.*) (* It returns true if a new record definition has been added to tenv.*)
@ -246,26 +246,26 @@ and add_late_defined_record tenv namespace typename =
match decls with match decls with
| [] -> false | [] -> false
| CXXRecordDecl | CXXRecordDecl
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls' :: decls'
| RecordDecl | RecordDecl
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls' -> :: decls' ->
(match opt_type with (match opt_type with
| `Type t -> | `Type t ->
(* the string t contains the name of the type preceded by the word struct. *) (* the string t contains the name of the type preceded by the word struct. *)
let t_no_struct = CTypes.cut_struct_union t in let t_no_struct = CTypes.cut_struct_union t in
let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in
let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in
if (Sil.typename_equal typename pot_struct_type || if (Sil.typename_equal typename pot_struct_type ||
Sil.typename_equal typename pot_union_type) && Sil.typename_equal typename pot_union_type) &&
record_decl_info.Clang_ast_t.rdi_is_complete_definition then ( record_decl_info.Clang_ast_t.rdi_is_complete_definition then (
Printing.log_out "!!!! Adding late-defined record '%s'\n" t; Printing.log_out "!!!! Adding late-defined record '%s'\n" t;
do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list
decl_context_info record_decl_info; decl_context_info record_decl_info;
true) true)
else scan decls' else scan decls'
| _ -> scan decls') | _ -> scan decls')
| LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls') | LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls')
| _:: decls' -> scan decls' in | _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls scan !CFrontend_config.global_translation_unit_decls
@ -283,13 +283,13 @@ and add_late_defined_typedef tenv namespace typename =
| TypedefDecl (decl_info, name_info, opt_type, tdi) :: decls' -> | TypedefDecl (decl_info, name_info, opt_type, tdi) :: decls' ->
let name' = name_info.Clang_ast_t.ni_name in let name' = name_info.Clang_ast_t.ni_name in
(match opt_type with (match opt_type with
| `Type t -> | `Type t ->
if (Mangled.to_string name) = name' then ( if (Mangled.to_string name) = name' then (
Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t; Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t;
do_typedef_declaration tenv namespace decl_info name' opt_type tdi; do_typedef_declaration tenv namespace decl_info name' opt_type tdi;
true) true)
else scan decls' else scan decls'
| _ -> scan decls') | _ -> scan decls')
| LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls') | LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls')
| _:: decls' -> scan decls' in | _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls scan !CFrontend_config.global_translation_unit_decls
@ -300,16 +300,16 @@ and expand_structured_type tenv typ =
match typ with match typ with
| Sil.Tvar tn -> | Sil.Tvar tn ->
(match Sil.tenv_lookup tenv tn with (match Sil.tenv_lookup tenv tn with
| Some t -> | Some t ->
Printing.log_out Printing.log_out
" Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t); " Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t);
if Sil.typ_equal t typ then if Sil.typ_equal t typ then
typ typ
else expand_structured_type tenv t else expand_structured_type tenv t
| None -> if (add_late_defined_record tenv None tn || | None -> if (add_late_defined_record tenv None tn ||
add_late_defined_typedef tenv None tn) then add_late_defined_typedef tenv None tn) then
expand_structured_type tenv typ expand_structured_type tenv typ
else typ) else typ)
| Sil.Tptr(t, _) -> typ (*do not expand types under pointers *) | Sil.Tptr(t, _) -> typ (*do not expand types under pointers *)
| _ -> typ | _ -> typ
@ -329,8 +329,8 @@ and add_struct_to_tenv tenv typ =
Printing.log_out " >>>Verifying that Typename TN_csu('%s') is in tenv\n" Printing.log_out " >>>Verifying that Typename TN_csu('%s') is in tenv\n"
(Sil.typename_to_string typename); (Sil.typename_to_string typename);
(match Sil.tenv_lookup tenv typename with (match Sil.tenv_lookup tenv typename with
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n") | None -> Printing.log_out " >>>NOT Found!!\n")
and qual_type_to_sil_type_general tenv qt no_pointer = and qual_type_to_sil_type_general tenv qt no_pointer =
let typ = string_type_to_sil_type tenv (CTypes.get_type qt) in let typ = string_type_to_sil_type tenv (CTypes.get_type qt) in

42
infer/src/clang/cVar_decl.ml
Unescape View File

@ -56,7 +56,7 @@ let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list =
let global_var = CGlobal_vars.find mangled_var_name in let global_var = CGlobal_vars.find mangled_var_name in
CGlobal_vars.var_get_name global_var) CGlobal_vars.var_get_name global_var)
else (Printing.log_out "SKIPPING VarDecl for '%s'\n" var_name; else (Printing.log_out "SKIPPING VarDecl for '%s'\n" var_name;
lookup_ahead_for_vardecl context pointer var_name kind rest) lookup_ahead_for_vardecl context pointer var_name kind rest)
| _ :: rest -> | _ :: rest ->
lookup_ahead_for_vardecl context pointer var_name kind rest lookup_ahead_for_vardecl context pointer var_name kind rest
@ -94,9 +94,9 @@ let lookup_var stmt_info context pointer var_name kind =
try try
lookup_var_static_globals context var_name lookup_var_static_globals context var_name
with Not_found -> with Not_found ->
(Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer; (Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer;
let decl_list = !CFrontend_config.global_translation_unit_decls in let decl_list = !CFrontend_config.global_translation_unit_decls in
lookup_ahead_for_vardecl context pointer var_name kind decl_list ) lookup_ahead_for_vardecl context pointer var_name kind decl_list )
(* Traverses the body of the method top down and collects the *) (* Traverses the body of the method top down and collects the *)
(* variable definitions in a map in the context. To be able to find the right variable name *) (* variable definitions in a map in the context. To be able to find the right variable name *)
@ -108,17 +108,17 @@ let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit =
get_variables_decls context decl_list; get_variables_decls context decl_list;
get_fun_locals context lstmt; get_fun_locals context lstmt;
| DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> | DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) ->
(* Notice that DeclRefExpr is the reference to a declared var/function/enum... *) (* Notice that DeclRefExpr is the reference to a declared var/function/enum... *)
(* so no declaration here *) (* so no declaration here *)
Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n" Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n"
stmt_info.Clang_ast_t.si_pointer; stmt_info.Clang_ast_t.si_pointer;
let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in
let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in
(match kind with (match kind with
| `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> () | `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> ()
| _ -> | _ ->
let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in
CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context) CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context)
| CompoundStmt(stmt_info, lstmt) -> | CompoundStmt(stmt_info, lstmt) ->
Printing.log_out "Collecting variables, passing from CompoundStmt '%s'\n" Printing.log_out "Collecting variables, passing from CompoundStmt '%s'\n"
stmt_info.Clang_ast_t.si_pointer; stmt_info.Clang_ast_t.si_pointer;
@ -147,15 +147,15 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
let name = name_info.Clang_ast_t.ni_name in let name = name_info.Clang_ast_t.ni_name in
let typ = get_var_type context.CContext.tenv name qual_type in let typ = get_var_type context.CContext.tenv name qual_type in
(match var_decl_info.Clang_ast_t.vdi_storage_class with (match var_decl_info.Clang_ast_t.vdi_storage_class with
| Some "static" -> | Some "static" ->
let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
let static_name = (Procname.to_string pname)^"_"^name in let static_name = (Procname.to_string pname)^"_"^name in
CGlobal_vars.add static_name typ; CGlobal_vars.add static_name typ;
let var = Sil.mk_pvar_global (Mangled.from_string static_name) in let var = Sil.mk_pvar_global (Mangled.from_string static_name) in
CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context
| _ -> | _ ->
CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer
(CFrontend_utils.General_utils.is_static_var var_decl_info)) (CFrontend_utils.General_utils.is_static_var var_decl_info))
| CXXRecordDecl(di, n_info, ot, dl, dci, rdi) | CXXRecordDecl(di, n_info, ot, dl, dci, rdi)
| RecordDecl(di, n_info, ot, dl, dci, rdi) -> | RecordDecl(di, n_info, ot, dl, dci, rdi) ->
let typ = CTypes_decl.get_declaration_type context.CContext.tenv context.CContext.namespace let typ = CTypes_decl.get_declaration_type context.CContext.tenv context.CContext.namespace
@ -169,7 +169,7 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
"WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n" "WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n"
decl_info.Clang_ast_t.di_pointer decl_info.Clang_ast_t.di_pointer
| _ -> Printing.log_out | _ -> Printing.log_out
"!!! When collecting locals of a function found '%s'. Cannot continue\n\n" "!!! When collecting locals of a function found '%s'. Cannot continue\n\n"
(Clang_ast_j.string_of_decl decl); (Clang_ast_j.string_of_decl decl);
assert false in assert false in
list_iter do_one_decl decl_list list_iter do_one_decl decl_list

98
infer/src/clang/objcInterface_decl.ml
Unescape View File

@ -35,10 +35,10 @@ let is_pointer_to_objc_class tenv typ =
match typ with match typ with
| Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cname)), _) -> | Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cname)), _) ->
(match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with (match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with
| Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true | Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true
| _ -> false) | _ -> false)
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when
is_objc_class_annotation a -> true is_objc_class_annotation a -> true
| _ -> false | _ -> false
let get_super_interface_decl otdi_super = let get_super_interface_decl otdi_super =
@ -48,10 +48,10 @@ let get_super_interface_decl otdi_super =
let get_protocols protocols = let get_protocols protocols =
let protocol_names = list_map ( let protocol_names = list_map (
fun decl -> match decl.Clang_ast_t.dr_name with fun decl -> match decl.Clang_ast_t.dr_name with
| Some name -> name.Clang_ast_t.ni_name | Some name -> name.Clang_ast_t.ni_name
| None -> assert false | None -> assert false
) protocols in ) protocols in
protocol_names protocol_names
(*The superclass is the first element in the list of super classes of structs in the tenv, *) (*The superclass is the first element in the list of super classes of structs in the tenv, *)
@ -62,8 +62,8 @@ let get_interface_superclasses super_opt protocols =
| None -> [] | None -> []
| Some super -> [(Sil.Class, Mangled.from_string super)] in | Some super -> [(Sil.Class, Mangled.from_string super)] in
let protocol_names = list_map ( let protocol_names = list_map (
fun name -> (Sil.Protocol, Mangled.from_string name) fun name -> (Sil.Protocol, Mangled.from_string name)
) protocols in ) protocols in
let super_classes = super_class@protocol_names in let super_classes = super_class@protocol_names in
super_classes super_classes
@ -77,11 +77,11 @@ let create_curr_class_and_superclasses_fields tenv decl_list class_name otdi_sup
let update_curr_class curr_class superclasses = let update_curr_class curr_class superclasses =
let get_protocols protocols = list_fold_right ( let get_protocols protocols = list_fold_right (
fun protocol converted_protocols -> fun protocol converted_protocols ->
match protocol with match protocol with
| (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols | (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols
| _ -> converted_protocols | _ -> converted_protocols
) protocols [] in ) protocols [] in
match curr_class with match curr_class with
| CContext.ContextCls (class_name, _, _) -> | CContext.ContextCls (class_name, _, _) ->
let super, protocols = let super, protocols =
@ -102,8 +102,8 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in
list_iter (fun (fn, ft, _) -> list_iter (fun (fn, ft, _) ->
Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn); Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc; Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc;
(*In case we found categories, or partial definition of this class earlier and they are already in the tenv *) (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *)
let fields, superclasses, methods = let fields, superclasses, methods =
match Sil.tenv_lookup tenv interface_name with match Sil.tenv_lookup tenv interface_name with
@ -118,16 +118,16 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let fields = CFrontend_utils.General_utils.sort_fields fields in let fields = CFrontend_utils.General_utils.sort_fields fields in
Printing.log_out "Class %s field:\n" class_name; Printing.log_out "Class %s field:\n" class_name;
list_iter (fun (fn, ft, _) -> list_iter (fun (fn, ft, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let interface_type_info = let interface_type_info =
Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name), Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name),
superclasses, methods, objc_class_annotation) in superclasses, methods, objc_class_annotation) in
Sil.tenv_add tenv interface_name interface_type_info; Sil.tenv_add tenv interface_name interface_type_info;
Printing.log_out Printing.log_out
" >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name); " >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name);
(match Sil.tenv_lookup tenv interface_name with (match Sil.tenv_lookup tenv interface_name with
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n"); | None -> Printing.log_out " >>>NOT Found!!\n");
curr_class curr_class
let add_missing_methods tenv class_name decl_list curr_class = let add_missing_methods tenv class_name decl_list curr_class =
@ -165,14 +165,14 @@ let lookup_late_defined_interface tenv cname =
match decls with match decls with
| [] -> () | [] -> ()
| ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info)
:: decls' :: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
scan decls' scan decls'
| ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info)
:: decls' :: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
(* Assumption: here we assume that the first interface declaration with non empty set of fields is the *) (* Assumption: here we assume that the first interface declaration with non empty set of fields is the *)
(* correct one. So we stop. *) (* correct one. So we stop. *)
ignore (interface_declaration tenv name_info.Clang_ast_t.ni_name decl_list obj_c_interface_decl_info) ignore (interface_declaration tenv name_info.Clang_ast_t.ni_name decl_list obj_c_interface_decl_info)
| _:: decls' -> scan decls' in | _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls scan !CFrontend_config.global_translation_unit_decls
@ -181,9 +181,9 @@ let lookup_late_defined_interface tenv cname =
(* the search is extended in a recursive way to the hierarchy of superclasses. *) (* the search is extended in a recursive way to the hierarchy of superclasses. *)
let rec find_field tenv nfield str searched_late_defined = let rec find_field tenv nfield str searched_late_defined =
(* let add_namespace_to_namefield cname = (* let add_namespace_to_namefield cname =
match namespace with match namespace with
| Some _ -> nfield | Some _ -> nfield
| None -> (Mangled.to_string cname)^"_"^nfield in *) | None -> (Mangled.to_string cname)^"_"^nfield in *)
let print_error name_field fields = let print_error name_field fields =
Printing.log_err "\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ; Printing.log_err "\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ;
Printing.log_err "In the following list of fields\n"; Printing.log_err "In the following list of fields\n";
@ -196,8 +196,8 @@ let rec find_field tenv nfield str searched_late_defined =
Printing.log_err "@. ....Searching field in superclass (Class, '%s')@." (Mangled.to_string sname); Printing.log_err "@. ....Searching field in superclass (Class, '%s')@." (Mangled.to_string sname);
let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, sname)) in let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, sname)) in
(match find_field tenv nfield str' searched_late_defined with (match find_field tenv nfield str' searched_late_defined with
| Some field -> Some field | Some field -> Some field
| None -> search_super s') | None -> search_super s')
| (Sil.Protocol, sname):: s' -> | (Sil.Protocol, sname):: s' ->
Printing.log_err "@. ... Searching field in protocol (Protocol, '%s')@." (Mangled.to_string sname); Printing.log_err "@. ... Searching field in protocol (Protocol, '%s')@." (Mangled.to_string sname);
search_super s' search_super s'
@ -211,24 +211,24 @@ let rec find_field tenv nfield str searched_late_defined =
| Some Sil.Tstruct (sf, nsf, Sil.Struct, Some cname, _, _, _) | Some Sil.Tstruct (sf, nsf, Sil.Struct, Some cname, _, _, _)
| Some Sil.Tstruct (sf, nsf, Sil.Union, Some cname, _, _, _) -> | Some Sil.Tstruct (sf, nsf, Sil.Union, Some cname, _, _, _) ->
(let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in (let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in
try try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found -> with Not_found ->
print_error name_field (sf@nsf); None) print_error name_field (sf@nsf); None)
| Some Sil.Tstruct (sf, nsf, Sil.Class, Some cname, super, _, _) -> | Some Sil.Tstruct (sf, nsf, Sil.Class, Some cname, super, _, _) ->
(let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in (let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in
try try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found -> with Not_found ->
(* if we have already searched for late defined interfaces we check recursively *) (* if we have already searched for late defined interfaces we check recursively *)
(* whether the field is defined in the hiearchy of superclasses.*) (* whether the field is defined in the hiearchy of superclasses.*)
(* If we don't find it we stop, giving error. *) (* If we don't find it we stop, giving error. *)
print_error name_field (sf@nsf); print_error name_field (sf@nsf);
if searched_late_defined then search_super super if searched_late_defined then search_super super
else ( else (
Printing.log_err "@. Search late defined...@.@."; Printing.log_err "@. Search late defined...@.@.";
(* if we don't find the field the first thing we do is scanning later definitions of interfaces. *) (* if we don't find the field the first thing we do is scanning later definitions of interfaces. *)
lookup_late_defined_interface tenv cname; lookup_late_defined_interface tenv cname;
let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in
find_field tenv nfield str' true)) find_field tenv nfield str' true))
| _ -> None | _ -> None

108
infer/src/clang/objcProperty_decl.ml
Unescape View File

@ -29,7 +29,7 @@ type prop_getter_setter = string * (Clang_ast_t.decl * bool) option
(** A property type is a tuple: *) (** A property type is a tuple: *)
(** (qual_type, property attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar name) *) (** (qual_type, property attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar name) *)
type property_type = Clang_ast_t.qual_type * Clang_ast_t.property_attribute list * type property_type = Clang_ast_t.qual_type * Clang_ast_t.property_attribute list *
Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option
(** A table that record the property defined in the interface and its getter/setter. *) (** A table that record the property defined in the interface and its getter/setter. *)
(** This info used later on in the implementation if the getter/setter need to automatically *) (** This info used later on in the implementation if the getter/setter need to automatically *)
@ -54,7 +54,7 @@ sig
val replace_property : property_key -> property_type -> unit val replace_property : property_key -> property_type -> unit
val add_property : property_key -> Clang_ast_t.qual_type -> val add_property : property_key -> Clang_ast_t.qual_type ->
Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit
val print_property_table : unit -> unit val print_property_table : unit -> unit
@ -91,25 +91,25 @@ struct
let rec find_property curr_class property_name = let rec find_property curr_class property_name =
try PropertyTableHash.find property_table (curr_class, property_name) try PropertyTableHash.find property_table (curr_class, property_name)
with Not_found -> with Not_found ->
match curr_class with match curr_class with
| ContextCls (name, _, protocols) -> | ContextCls (name, _, protocols) ->
let res_opt = list_fold_right let res_opt = list_fold_right
(fun protocol found_procname_opt -> (fun protocol found_procname_opt ->
match found_procname_opt with match found_procname_opt with
| Some found_procname -> Some found_procname | Some found_procname -> Some found_procname
| None -> | None ->
Some (find_property (ContextProtocol protocol) property_name)) protocols None in Some (find_property (ContextProtocol protocol) property_name)) protocols None in
(match res_opt with (match res_opt with
| Some res -> res | Some res -> res
| None -> raise Not_found) | None -> raise Not_found)
| _ -> raise Not_found | _ -> raise Not_found
let find_property_name_from_ivar curr_class ivar = let find_property_name_from_ivar curr_class ivar =
let res = ref None in let res = ref None in
PropertyTableHash.iter (fun (cl, pname) (_, _, _, _, _, ivar') -> PropertyTableHash.iter (fun (cl, pname) (_, _, _, _, _, ivar') ->
match ivar' with match ivar' with
| Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname | Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname
| _ -> ()) property_table; | _ -> ()) property_table;
!res !res
let is_mem_property property = let is_mem_property property =
@ -168,8 +168,8 @@ let find_properties_class = Property.find_properties_class
let get_ivarname_property pidi = let get_ivarname_property pidi =
match pidi.Clang_ast_t.opidi_ivar_decl with match pidi.Clang_ast_t.opidi_ivar_decl with
| Some dr -> (match dr.Clang_ast_t.dr_name with | Some dr -> (match dr.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name | Some n -> n.Clang_ast_t.ni_name
| _ -> assert false) | _ -> assert false)
| _ -> (* If ivar is not defined than we need to take the name of the property to define ivar*) | _ -> (* If ivar is not defined than we need to take the name of the property to define ivar*)
Ast_utils.property_name pidi Ast_utils.property_name pidi
@ -194,14 +194,14 @@ let check_for_property curr_class method_name meth_decl body =
let check_property_accessor curr_class method_name is_getter = let check_property_accessor curr_class method_name is_getter =
let method_is_getter (property_name, property_type) = let method_is_getter (property_name, property_type) =
match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) -> match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) ->
let found = let found =
if is_getter then (method_name = getter_name) if is_getter then (method_name = getter_name)
else (method_name = setter_name) in else (method_name = setter_name) in
if found then if found then
(Printing.log_out " Found property '%s' defined in property table\n" (Printing.log_out " Found property '%s' defined in property table\n"
(Property.property_key_to_string (curr_class, property_name)); (Property.property_key_to_string (curr_class, property_name));
upgrade_property_accessor upgrade_property_accessor
(curr_class, property_name) property_type meth_decl defined is_getter) in (curr_class, property_name) property_type meth_decl defined is_getter) in
list_iter method_is_getter properties_class in list_iter method_is_getter properties_class in
check_property_accessor curr_class method_name true; check_property_accessor curr_class method_name true;
check_property_accessor curr_class method_name false check_property_accessor curr_class method_name false
@ -213,34 +213,34 @@ let method_is_property_accesor cls method_name =
| Some res -> res_opt | Some res -> res_opt
| None -> | None ->
match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) -> match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) ->
if method_name = getter_name then Some (property_name, property_type, true) if method_name = getter_name then Some (property_name, property_type, true)
else if method_name = setter_name then Some (property_name, property_type, false) else if method_name = setter_name then Some (property_name, property_type, false)
else None in else None in
list_fold_right method_is_getter properties_class None list_fold_right method_is_getter properties_class None
let prepare_dynamic_property curr_class decl_info property_impl_decl_info = let prepare_dynamic_property curr_class decl_info property_impl_decl_info =
let pname = Ast_utils.property_name property_impl_decl_info in let pname = Ast_utils.property_name property_impl_decl_info in
let res = (try let res = (try
let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in
let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with
| Some dr -> (match dr.Clang_ast_t.dr_name with | Some dr -> (match dr.Clang_ast_t.dr_name with
| Some name_info -> name_info.Clang_ast_t.ni_name | Some name_info -> name_info.Clang_ast_t.ni_name
| None -> assert false) | None -> assert false)
| None -> Ast_utils.generated_ivar_name pname) in | None -> Ast_utils.generated_ivar_name pname) in
(* update property info with proper ivar name *) (* update property info with proper ivar name *)
Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar); Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar);
Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname; Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname;
Some (qt', ivar) Some (qt', ivar)
with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname; with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname;
None) in None) in
match property_impl_decl_info.Clang_ast_t.opidi_implementation, res with match property_impl_decl_info.Clang_ast_t.opidi_implementation, res with
| `Dynamic, Some (qt, ivar) -> | `Dynamic, Some (qt, ivar) ->
(* For Dynamic property we need to create the ObjCIvarDecl which specifies*) (* For Dynamic property we need to create the ObjCIvarDecl which specifies*)
(* the field of the property. In case of Dynamic this is not in the AST.*) (* the field of the property. In case of Dynamic this is not in the AST.*)
(* Once created the ObjCIvarDecl then we treat the property as synthesized *) (* Once created the ObjCIvarDecl then we treat the property as synthesized *)
[Ast_expressions.make_objc_ivar_decl decl_info qt property_impl_decl_info ivar] [Ast_expressions.make_objc_ivar_decl decl_info qt property_impl_decl_info ivar]
| _ -> | _ ->
(* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *) (* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *)
[] []
(*NOTE: Assumption: if there is a getter or a setter defined manually, *) (*NOTE: Assumption: if there is a getter or a setter defined manually, *)
@ -258,8 +258,8 @@ let is_property_read_only attributes =
let get_memory_management_attribute attributes = let get_memory_management_attribute attributes =
let memory_management_attributes = Ast_utils.get_memory_management_attributes () in let memory_management_attributes = Ast_utils.get_memory_management_attributes () in
try Some (list_find ( try Some (list_find (
fun att -> list_mem (Ast_utils.property_attribute_eq) fun att -> list_mem (Ast_utils.property_attribute_eq)
att memory_management_attributes) attributes) att memory_management_attributes) attributes)
with Not_found -> None with Not_found -> None
let create_generated_method_name name_info = let create_generated_method_name name_info =
@ -287,7 +287,7 @@ let make_getter curr_class prop_name prop_type =
Property.replace_property Property.replace_property
(curr_class, prop_name) (curr_class, prop_name)
(qt, attributes, decl_info, (qt, attributes, decl_info,
(getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name); (getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name);
[ObjCMethodDecl(dummy_info, generated_name_info, mdi')] [ObjCMethodDecl(dummy_info, generated_name_info, mdi')]
| _ -> [] | _ -> []
@ -332,8 +332,8 @@ let make_setter curr_class prop_name prop_type =
Property.replace_property Property.replace_property
(curr_class, prop_name) (curr_class, prop_name)
(qt, attributes, decl_info, (qt, attributes, decl_info,
(getter_name, getter), (getter_name, getter),
(setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name); (setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name);
[ObjCMethodDecl(dummy_info, name_generated, mdi')] [ObjCMethodDecl(dummy_info, name_generated, mdi')]
| _ -> [] | _ -> []
@ -351,15 +351,15 @@ let make_getter_setter curr_class decl_info prop_name =
try try
Property.find_property curr_class prop_name Property.find_property curr_class prop_name
with _ -> with _ ->
Printing.log_out "Property %s not found@." prop_name; Printing.log_out "Property %s not found@." prop_name;
assert false in assert false in
(make_getter curr_class prop_name prop_type)@ (make_setter curr_class prop_name prop_type) (make_getter curr_class prop_name prop_type)@ (make_setter curr_class prop_name prop_type)
let add_properties_to_table curr_class decl_list = let add_properties_to_table curr_class decl_list =
let add_property_to_table dec = let add_property_to_table dec =
match dec with match dec with
| ObjCPropertyDecl(decl_info, name_info, pdi) -> | ObjCPropertyDecl(decl_info, name_info, pdi) ->
(* Property declaration register the property on the property table to be *) (* Property declaration register the property on the property table to be *)
let pname = name_info.Clang_ast_t.ni_name in let pname = name_info.Clang_ast_t.ni_name in
Printing.log_out "ADDING: ObjCPropertyDecl for property '%s' " pname; Printing.log_out "ADDING: ObjCPropertyDecl for property '%s' " pname;
Printing.log_out " pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer; Printing.log_out " pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer;

74
infer/src/harness/androidFramework.ml
Unescape View File

@ -37,28 +37,28 @@ let android_lifecycles =
let android_app = "android.app" in let android_app = "android.app" in
let fragment_lifecycle = let fragment_lifecycle =
["onInflate"; "onAttach"; "onCreate"; "onCreateView"; "onViewCreated"; "onActivityCreated"; ["onInflate"; "onAttach"; "onCreate"; "onCreateView"; "onViewCreated"; "onActivityCreated";
"onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop"; "onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop";
on_destroy_view; on_destroy; "onDetach"] in on_destroy_view; on_destroy; "onDetach"] in
[ (android_content, [ (android_content,
"ContentProvider", "ContentProvider",
["onCreate"]); ["onCreate"]);
(android_app, (android_app,
"Activity", "Activity",
["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume"; ["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume";
"onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]); "onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]);
(android_app, (android_app,
"Service", "Service",
["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]); ["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]);
(android_content, (android_content,
"BroadcastReceiever", "BroadcastReceiever",
["onReceive"]); ["onReceive"]);
(android_app, (android_app,
"Fragment", "Fragment",
fragment_lifecycle); fragment_lifecycle);
(* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *) (* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *)
("android.support.v4.app", ("android.support.v4.app",
"Fragment", "Fragment",
fragment_lifecycle); fragment_lifecycle);
] ]
let android_callbacks = let android_callbacks =
@ -244,10 +244,10 @@ let android_callbacks =
("android.widget", "TextView$OnEditorActionListener"); ("android.widget", "TextView$OnEditorActionListener");
("android.widget", "TimePicker$OnTimeChangedListener"); ("android.widget", "TimePicker$OnTimeChangedListener");
("android.widget", "ZoomButtonsController$OnZoomListener"); ("android.widget", "ZoomButtonsController$OnZoomListener");
] in ] in
list_fold_left (fun cbSet (pkg, clazz) -> list_fold_left (fun cbSet (pkg, clazz) ->
let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in
Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs
(** return the complete set of superclasses of [typ *) (** return the complete set of superclasses of [typ *)
(* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *) (* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *)
@ -274,9 +274,9 @@ let is_callback_class_name class_name = Mangled.MangledSet.mem class_name androi
let is_callback_class typ tenv = let is_callback_class typ tenv =
let supertyps = get_all_supertypes typ tenv in let supertyps = get_all_supertypes typ tenv in
TypSet.exists (fun typ -> match typ with TypSet.exists (fun typ -> match typ with
| Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) -> | Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) ->
is_callback_class_name classname is_callback_class_name classname
| _ -> false) supertyps | _ -> false) supertyps
(** return true if [typ] is a subclass of [lifecycle_typ] *) (** return true if [typ] is a subclass of [lifecycle_typ] *)
let typ_is_lifecycle_typ typ lifecycle_typ tenv = let typ_is_lifecycle_typ typ lifecycle_typ tenv =
@ -289,24 +289,24 @@ let is_android_lib_class class_name =
string_is_prefix "android" class_str || string_is_prefix "com.android" class_str string_is_prefix "android" class_str || string_is_prefix "com.android" class_str
(** returns an option containing the var name and type of a callback registered by [procname], None (** returns an option containing the var name and type of a callback registered by [procname], None
if no callback is registered *) if no callback is registered *)
let get_callback_registered_by procname args tenv = let get_callback_registered_by procname args tenv =
(* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of (* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of
* Android callback registration methods *) * Android callback registration methods *)
(* for now, we assume a method is a callback registration method if it is a setter and has a (* for now, we assume a method is a callback registration method if it is a setter and has a
* callback class as a non - receiver argument *) * callback class as a non - receiver argument *)
let is_callback_register_like = let is_callback_register_like =
let has_non_this_callback_arg args = list_length args > 1 in let has_non_this_callback_arg args = list_length args > 1 in
let has_registery_name procname = let has_registery_name procname =
Procname.is_java procname && (PatternMatch.is_setter procname || Procname.is_java procname && (PatternMatch.is_setter procname ||
is_known_callback_register_method (Procname.java_get_method procname)) in is_known_callback_register_method (Procname.java_get_method procname)) in
has_registery_name procname && has_non_this_callback_arg args in has_registery_name procname && has_non_this_callback_arg args in
let is_ptr_to_callback_class typ tenv = match typ with let is_ptr_to_callback_class typ tenv = match typ with
| Sil.Tptr (typ, Sil.Pk_pointer) -> is_callback_class typ tenv | Sil.Tptr (typ, Sil.Pk_pointer) -> is_callback_class typ tenv
| _ -> false in | _ -> false in
if is_callback_register_like then if is_callback_register_like then
(* we don't want to check if the receiver is a callback class; it's one of the method arguments (* we don't want to check if the receiver is a callback class; it's one of the method arguments
* that's being registered as a callback *) * that's being registered as a callback *)
let get_non_this_args args = list_tl args in let get_non_this_args args = list_tl args in
try try
Some (list_find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args)) Some (list_find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args))
@ -332,20 +332,20 @@ let is_callback_register_method procname args tenv =
| None -> false | None -> false
(** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and (** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and
a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *) a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv = let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv =
match Sil.get_typ lifecycle_typ None tenv with match Sil.get_typ lifecycle_typ None tenv with
| Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) -> | Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) ->
(* TODO (t4645631): collect the procedures for which is_java is returning false *) (* TODO (t4645631): collect the procedures for which is_java is returning false *)
let lookup_proc lifecycle_proc = let lookup_proc lifecycle_proc =
list_find (fun decl_proc -> list_find (fun decl_proc ->
Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc
) decl_procs in ) decl_procs in
(* convert each of the framework lifecycle proc strings to a lifecycle method procname *) (* convert each of the framework lifecycle proc strings to a lifecycle method procname *)
let lifecycle_procs = let lifecycle_procs =
list_fold_left (fun lifecycle_procs lifecycle_proc_str -> list_fold_left (fun lifecycle_procs lifecycle_proc_str ->
try (lookup_proc lifecycle_proc_str) :: lifecycle_procs try (lookup_proc lifecycle_proc_str) :: lifecycle_procs
with Not_found -> lifecycle_procs) with Not_found -> lifecycle_procs)
[] lifecycle_proc_strs in [] lifecycle_proc_strs in
Some (lifecycle_typ, lifecycle_procs) Some (lifecycle_typ, lifecycle_procs)
| _ -> None | _ -> None

124
infer/src/harness/harness.ml
Unescape View File

@ -15,8 +15,8 @@ open Utils
(** Automatically create a harness method to exercise code under test *) (** Automatically create a harness method to exercise code under test *)
(** given a list [lst] = fst @ (e :: rest), a test predicate [test], and a list [to_insert], returns (** given a list [lst] = fst @ (e :: rest), a test predicate [test], and a list [to_insert], returns
the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates
to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *) to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *)
let insert_after lst test to_insert = let insert_after lst test to_insert =
let rec insert_rec to_process processed = match to_process with let rec insert_rec to_process processed = match to_process with
| instr :: to_process -> | instr :: to_process ->
@ -29,10 +29,10 @@ let insert_after lst test to_insert =
insert_rec lst [] insert_rec lst []
(** find callees that register callbacks and add instrumentation to extract the callback. (** find callees that register callbacks and add instrumentation to extract the callback.
return the set of new global static fields created to extract callbacks and their types *) return the set of new global static fields created to extract callbacks and their types *)
let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callback_fields = let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callback_fields =
(* try to turn a nasty callback name like MyActivity$1 into a nice callback name like (* try to turn a nasty callback name like MyActivity$1 into a nice callback name like
* Button.OnClickListener[line 7]*) * Button.OnClickListener[line 7]*)
let create_descriptive_callback_name callback_typ loc = let create_descriptive_callback_name callback_typ loc =
let typ_str = match PatternMatch.type_get_class_name callback_typ with let typ_str = match PatternMatch.type_get_class_name callback_typ with
| Some mangled -> Mangled.get_mangled mangled | Some mangled -> Mangled.get_mangled mangled
@ -41,11 +41,11 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
if Procname.is_anonymous_inner_class_name typ_str then if Procname.is_anonymous_inner_class_name typ_str then
match PatternMatch.type_get_direct_supertypes callback_typ with match PatternMatch.type_get_direct_supertypes callback_typ with
| [] -> | [] ->
(* this should never happen since an inner class always has a supertype *) (* this should never happen since an inner class always has a supertype *)
assert false assert false
| l -> | l ->
(* choose to describe this anonymous inner class with one of the interfaces that it (* choose to describe this anonymous inner class with one of the interfaces that it
* implements. translation always places interfaces at the end of the supertypes list *) * implements. translation always places interfaces at the end of the supertypes list *)
Mangled.get_mangled (list_hd (list_rev l)) Mangled.get_mangled (list_hd (list_rev l))
else typ_str in else typ_str in
Mangled.from_string (pretty_typ_str ^ "[line " ^ Sil.loc_to_string loc ^ "]") in Mangled.from_string (pretty_typ_str ^ "[line " ^ Sil.loc_to_string loc ^ "]") in
@ -57,13 +57,13 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
let callback_fld_name = create_descriptive_callback_name ptr_to_cb_typ loc in let callback_fld_name = create_descriptive_callback_name ptr_to_cb_typ loc in
let created_fld = Ident.create_fieldname callback_fld_name 0 in let created_fld = Ident.create_fieldname callback_fld_name 0 in
(* create a function that takes the type of the harness class as an argument and modifies (* create a function that takes the type of the harness class as an argument and modifies
* the instruction set with callback extraction code. we do this because we need to know * the instruction set with callback extraction code. we do this because we need to know
* the typ of the harness class before we can write to any of its fields, but we cannot * the typ of the harness class before we can write to any of its fields, but we cannot
* actually create this typ until we know how many fields we are going to create in order * actually create this typ until we know how many fields we are going to create in order
* to extract callbacks *) * to extract callbacks *)
let mk_field_write harness_class_typ = let mk_field_write harness_class_typ =
(* create an instruction that writes the registered callback object to a global static (* create an instruction that writes the registered callback object to a global static
* field in the harness class *) * field in the harness class *)
let fld_write_lhs = Sil.Lfield (harness_lvar, created_fld, harness_class_typ) in let fld_write_lhs = Sil.Lfield (harness_lvar, created_fld, harness_class_typ) in
let extract_cb_instr = Sil.Set (fld_write_lhs, cb_typ, cb_obj, loc) in let extract_cb_instr = Sil.Set (fld_write_lhs, cb_typ, cb_obj, loc) in
let instrumented_instrs = let instrumented_instrs =
@ -80,52 +80,52 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
(** find all of the callbacks registered by methods in [lifecycle_trace *) (** find all of the callbacks registered by methods in [lifecycle_trace *)
let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv = let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
(* what would be ideal to do here is to go through every method (transitively) called by a (* what would be ideal to do here is to go through every method (transitively) called by a
* lifecycle method and look for registered callbacks, however, this would need to be a complex * lifecycle method and look for registered callbacks, however, this would need to be a complex
* iterative process, as detecting callbacks can lead to more methods being called, which in * iterative process, as detecting callbacks can lead to more methods being called, which in
* turn can lead to more callbacks being registered. so what we do here is iterate through each * turn can lead to more callbacks being registered. so what we do here is iterate through each
* file that a lifecycle proc is defined in and collect all callbacks possibly registered in * file that a lifecycle proc is defined in and collect all callbacks possibly registered in
* methods in that file. this can err on the side of including too many callbacks (for example, if * methods in that file. this can err on the side of including too many callbacks (for example, if
* a callback is registered in a superclass method that is overridden, this scheme would * a callback is registered in a superclass method that is overridden, this scheme would
* wrongly include it). on the other hand, this will miss callbacks registered in * wrongly include it). on the other hand, this will miss callbacks registered in
* callees of lifecycle methods that aren't in our list of "lifecycle methods files" *) * callees of lifecycle methods that aren't in our list of "lifecycle methods files" *)
(* TODO (t4793988): do something more principled here *) (* TODO (t4793988): do something more principled here *)
let harness_lvar = Sil.Lvar (Sil.mk_pvar_global harness_name) in let harness_lvar = Sil.Lvar (Sil.mk_pvar_global harness_name) in
let lifecycle_cfg_files = let lifecycle_cfg_files =
list_fold_left (fun lifecycle_files (lifecycle_proc, _) -> list_fold_left (fun lifecycle_files (lifecycle_proc, _) ->
try try
let cfg_fname = let cfg_fname =
let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in
DB.source_dir_get_internal_file source_dir ".cfg" in DB.source_dir_get_internal_file source_dir ".cfg" in
DB.FilenameSet.add cfg_fname lifecycle_files DB.FilenameSet.add cfg_fname lifecycle_files
with Not_found -> lifecycle_files with Not_found -> lifecycle_files
) DB.FilenameSet.empty lifecycle_trace in ) DB.FilenameSet.empty lifecycle_trace in
DB.FilenameSet.fold (fun cfg_file registered_callbacks -> DB.FilenameSet.fold (fun cfg_file registered_callbacks ->
match Cfg.load_cfg_from_file cfg_file with match Cfg.load_cfg_from_file cfg_file with
| Some cfg -> | Some cfg ->
list_fold_left (fun registered_callbacks procdesc -> list_fold_left (fun registered_callbacks procdesc ->
extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks
) registered_callbacks (Cfg.get_all_procs cfg) ) registered_callbacks (Cfg.get_all_procs cfg)
| None -> registered_callbacks | None -> registered_callbacks
) lifecycle_cfg_files [] ) lifecycle_cfg_files []
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a (** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a
lifecycle trace *) lifecycle trace *)
let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with
| Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _) | Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _)
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
not (AndroidFramework.is_android_lib_class class_name) -> not (AndroidFramework.is_android_lib_class class_name) ->
let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in
list_fold_left (fun trace lifecycle_proc -> list_fold_left (fun trace lifecycle_proc ->
(* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname (* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname
* that will actually be called at runtime *) * that will actually be called at runtime *)
let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in
(resolved_proc, ptr_to_typ) :: trace (resolved_proc, ptr_to_typ) :: trace
) [] lifecycle_procs ) [] lifecycle_procs
| _ -> [] | _ -> []
(** get all the callbacks registered in [lifecycle_trace], transform the SIL to "extract" them into (** get all the callbacks registered in [lifecycle_trace], transform the SIL to "extract" them into
global static fields belong to the harness so that they are easily callable, and return a list global static fields belong to the harness so that they are easily callable, and return a list
of the (field, typ) pairs that we have created for this purpose *) of the (field, typ) pairs that we have created for this purpose *)
let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv = let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_name = Mangled.from_string (Procname.to_string harness_procname) in let harness_name = Mangled.from_string (Procname.to_string harness_procname) in
let registered_cbs = let registered_cbs =
@ -135,14 +135,14 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_typ = let harness_typ =
Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in
(* update the tenv with our created harness typ. we don't have to save the tenv to disk here (* update the tenv with our created harness typ. we don't have to save the tenv to disk here
* because this is done immediately after harness generation runs in jMain.ml *) * because this is done immediately after harness generation runs in jMain.ml *)
let harness_class = Sil.TN_csu (Sil.Class, harness_name) in let harness_class = Sil.TN_csu (Sil.Class, harness_name) in
Sil.tenv_add tenv harness_class harness_typ; Sil.tenv_add tenv harness_class harness_typ;
let cfgs_to_save = let cfgs_to_save =
list_fold_left (fun cfgs_to_save (_, _, instrument_sil_f) -> list_fold_left (fun cfgs_to_save (_, _, instrument_sil_f) ->
(* instrument the cfg's with callback extraction code *) (* instrument the cfg's with callback extraction code *)
let (cfg_file, cfg) = instrument_sil_f harness_typ in let (cfg_file, cfg) = instrument_sil_f harness_typ in
DB.FilenameMap.add cfg_file cfg cfgs_to_save DB.FilenameMap.add cfg_file cfg cfgs_to_save
) DB.FilenameMap.empty registered_cbs in ) DB.FilenameMap.empty registered_cbs in
(* re-save the cfgs that we've modified by extracting callbacks *) (* re-save the cfgs that we've modified by extracting callbacks *)
DB.FilenameMap.iter DB.FilenameMap.iter
@ -154,26 +154,26 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
(** generate a harness for each lifecycle type in an Android application *) (** generate a harness for each lifecycle type in an Android application *)
let create_android_harness proc_file_map tenv = let create_android_harness proc_file_map tenv =
list_iter (fun (pkg, clazz, lifecycle_methods) -> list_iter (fun (pkg, clazz, lifecycle_methods) ->
let typ_name = Mangled.from_package_class pkg clazz in let typ_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with
| Some (framework_typ, framework_procs) -> | Some (framework_typ, framework_procs) ->
(* iterate through the type environment and generate a lifecycle harness for each subclass of (* iterate through the type environment and generate a lifecycle harness for each subclass of
* [lifecycle_typ] *) * [lifecycle_typ] *)
Sil.tenv_iter (fun _ typ -> Sil.tenv_iter (fun _ typ ->
match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with
| [] -> () | [] -> ()
| lifecycle_trace -> | lifecycle_trace ->
(* we have identified an application lifecycle type and created a trace for it. now, (* we have identified an application lifecycle type and created a trace for it. now,
* identify the callbacks registered by methods belonging to this type and get the * identify the callbacks registered by methods belonging to this type and get the
* inhabitation module to create a harness for us *) * inhabitation module to create a harness for us *)
let harness_procname = let harness_procname =
let harness_cls_name = PatternMatch.get_type_name typ in let harness_cls_name = PatternMatch.get_type_name typ in
Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in
let callback_fields = let callback_fields =
extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in
Inhabit.inhabit_trace lifecycle_trace callback_fields harness_procname proc_file_map tenv Inhabit.inhabit_trace lifecycle_trace callback_fields harness_procname proc_file_map tenv
) tenv ) tenv
| None -> () | None -> ()
) AndroidFramework.get_lifecycles ) AndroidFramework.get_lifecycles
let parse_trace trace = Stacktrace.parse_stack_trace trace let parse_trace trace = Stacktrace.parse_stack_trace trace

210
infer/src/harness/inhabit.ml
Unescape View File

@ -8,7 +8,7 @@
*) *)
(** Generate a procedure that calls a given sequence of methods. Useful for harness/test (** Generate a procedure that calls a given sequence of methods. Useful for harness/test
* generation. *) * generation. *)
module L = Logging module L = Logging
module F = Format module F = Format
@ -22,14 +22,14 @@ type lifecycle_trace = (Procname.t * Sil.typ option) list
type callback_trace = (Sil.exp * Sil.typ) list type callback_trace = (Sil.exp * Sil.typ) list
(** list of instrs and temporary variables created during inhabitation and a cache of types that (** list of instrs and temporary variables created during inhabitation and a cache of types that
* have already been inhabited *) * have already been inhabited *)
type env = { instrs : Sil.instr list; type env = { instrs : Sil.instr list;
tmp_vars : Ident.t list; tmp_vars : Ident.t list;
cache : Sil.exp TypMap.t; cache : Sil.exp TypMap.t;
(* set of types currently being inhabited. consult to prevent infinite recursion *) (* set of types currently being inhabited. consult to prevent infinite recursion *)
cur_inhabiting : TypSet.t; cur_inhabiting : TypSet.t;
pc : Sil.location; pc : Sil.location;
harness_name : Procname.t } harness_name : Procname.t }
(** add an instruction to the env, update tmp_vars, and bump the pc *) (** add an instruction to the env, update tmp_vars, and bump the pc *)
let env_add_instr instr tmp_vars env = let env_add_instr instr tmp_vars env =
@ -84,8 +84,8 @@ let tl_or_empty l = if l = [] then l else list_tl l
let get_non_receiver_formals formals = tl_or_empty formals let get_non_receiver_formals formals = tl_or_empty formals
(** create Sil corresponding to x = new typ() or x = new typ[]. For ordinary allocation, sizeof_typ (** create Sil corresponding to x = new typ() or x = new typ[]. For ordinary allocation, sizeof_typ
* and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size * and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size
* component but the size component of ret_typ is always -1. *) * component but the size component of ret_typ is always -1. *)
let inhabit_alloc sizeof_typ ret_typ alloc_kind env = let inhabit_alloc sizeof_typ ret_typ alloc_kind env =
let retval = Ident.create_fresh Ident.knormal in let retval = Ident.create_fresh Ident.knormal in
let inhabited_exp = Sil.Var retval in let inhabited_exp = Sil.Var retval in
@ -100,59 +100,59 @@ let inhabit_alloc sizeof_typ ret_typ alloc_kind env =
let rec inhabit_typ typ proc_file_map env = let rec inhabit_typ typ proc_file_map env =
try (TypMap.find typ env.cache, env) try (TypMap.find typ env.cache, env)
with Not_found -> with Not_found ->
let inhabit_internal typ env = match typ with let inhabit_internal typ env = match typ with
| Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), Sil.Pk_pointer) -> | Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), Sil.Pk_pointer) ->
let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in
let arr_typ = Sil.Tarray (inner_typ, arr_size) in let arr_typ = Sil.Tarray (inner_typ, arr_size) in
inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env
| Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ -> | Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ ->
(* TODO (t4575417): this case does not work correctly for enums, but they are currently (* TODO (t4575417): this case does not work correctly for enums, but they are currently
* broken in Infer anyway (see t4592290) *) * broken in Infer anyway (see t4592290) *)
let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in
(* select methods that are constructors and won't force us into infinite recursion because (* select methods that are constructors and won't force us into infinite recursion because
* we are already inhabiting one of their argument types *) * we are already inhabiting one of their argument types *)
let get_all_suitable_constructors typ = match typ with let get_all_suitable_constructors typ = match typ with
| Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) -> | Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) ->
let is_suitable_constructor p = let is_suitable_constructor p =
let try_get_non_receiver_formals p = let try_get_non_receiver_formals p =
try get_non_receiver_formals (formals_from_name p proc_file_map) try get_non_receiver_formals (formals_from_name p proc_file_map)
with Not_found -> [] in with Not_found -> [] in
Procname.is_constructor p && list_for_all (fun (_, typ) -> Procname.is_constructor p && list_for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in
list_filter (fun p -> is_suitable_constructor p) methods list_filter (fun p -> is_suitable_constructor p) methods
| _ -> [] in | _ -> [] in
let (env, typ_class_name) = match get_all_suitable_constructors typ with let (env, typ_class_name) = match get_all_suitable_constructors typ with
| constructor :: _ -> | constructor :: _ ->
(* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to
* nondeterministically call all possible constructors instead *) * nondeterministically call all possible constructors instead *)
let env = let env =
inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in
(* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we (* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we
* we can use it as a descriptive local variable name in the harness *) * we can use it as a descriptive local variable name in the harness *)
let typ_class_name = let typ_class_name =
if Procname.is_java constructor then Procname.java_get_simple_class constructor if Procname.is_java constructor then Procname.java_get_simple_class constructor
else create_fresh_local_name () in else create_fresh_local_name () in
(env, Mangled.from_string typ_class_name) (env, Mangled.from_string typ_class_name)
| [] -> (env, Mangled.from_string (create_fresh_local_name ())) in | [] -> (env, Mangled.from_string (create_fresh_local_name ())) in
(* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are (* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are
* both fresh. the only point of this is to add a descriptive local name that makes error * both fresh. the only point of this is to add a descriptive local name that makes error
* reports from the harness look nicer -- it's not necessary to make symbolic execution work *) * reports from the harness look nicer -- it's not necessary to make symbolic execution work *)
let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in
let write_to_local_instr = let write_to_local_instr =
Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in
let env' = env_add_instr write_to_local_instr [] env in let env' = env_add_instr write_to_local_instr [] env in
let fresh_id = Ident.create_fresh Ident.knormal in let fresh_id = Ident.create_fresh Ident.knormal in
let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in
(Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env') (Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env')
| Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env) | Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env)
| Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env) | Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env)
| typ -> | typ ->
L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ; L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ;
assert false in assert false in
let (inhabited_exp, env') = let (inhabited_exp, env') =
inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in
(inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache; (inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache;
cur_inhabiting = env.cur_inhabiting }) cur_inhabiting = env.cur_inhabiting })
(** inhabit each of the types in the formals list *) (** inhabit each of the types in the formals list *)
and inhabit_args formals proc_file_map env = and inhabit_args formals proc_file_map env =
@ -162,11 +162,11 @@ and inhabit_args formals proc_file_map env =
list_fold_right inhabit_arg formals ([], env) list_fold_right inhabit_arg formals ([], env)
(** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the (** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the
* remaining arguments *) * remaining arguments *)
and inhabit_constructor constr_name (allocated_obj, obj_type) proc_file_map env = and inhabit_constructor constr_name (allocated_obj, obj_type) proc_file_map env =
try try
(* this lookup can fail when we try to get the procdesc of a procedure from a different (* this lookup can fail when we try to get the procdesc of a procedure from a different
* module. this could be solved with a whole - program class hierarchy analysis *) * module. this could be solved with a whole - program class hierarchy analysis *)
let (args, env) = let (args, env) =
let non_receiver_formals = tl_or_empty (formals_from_name constr_name proc_file_map) in let non_receiver_formals = tl_or_empty (formals_from_name constr_name proc_file_map) in
inhabit_args non_receiver_formals proc_file_map env in inhabit_args non_receiver_formals proc_file_map env in
@ -219,12 +219,12 @@ let inhabit_fld_trace flds proc_file_map env =
inhabit_args (tl_or_empty formals) proc_file_map env in inhabit_args (tl_or_empty formals) proc_file_map env in
inhabit_call_with_args procname procdesc ((Sil.Var lhs, fld_typ) :: args) env inhabit_call_with_args procname procdesc ((Sil.Var lhs, fld_typ) :: args) env
with Not_found -> with Not_found ->
(* TODO (t4645631): investigate why this failure occurs *) (* TODO (t4645631): investigate why this failure occurs *)
env in env in
list_fold_left (fun env procname -> list_fold_left (fun env procname ->
if not (Procname.is_constructor procname) && if not (Procname.is_constructor procname) &&
not (Procname.java_is_access_method procname) then inhabit_cb_call procname env not (Procname.java_is_access_method procname) then inhabit_cb_call procname env
else env) env procs else env) env procs
| _ -> assert false in | _ -> assert false in
list_fold_left (fun env fld -> invoke_cb fld env) env flds list_fold_left (fun env fld -> invoke_cb fld env) env flds
@ -247,10 +247,10 @@ let write_harness_to_file harness_instrs harness_file =
let harness_file_name = DB.source_file_to_string harness_file in let harness_file_name = DB.source_file_to_string harness_file in
ref (create_outfile harness_file_name) in ref (create_outfile harness_file_name) in
let pp_harness fmt = list_iter (fun instr -> let pp_harness fmt = list_iter (fun instr ->
Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in
do_outf harness_file (fun outf -> do_outf harness_file (fun outf ->
pp_harness outf.fmt; pp_harness outf.fmt;
close_outf outf) close_outf outf)
(** add the harness proc to the cg and make sure its callees can be looked up by sym execution *) (** add the harness proc to the cg and make sure its callees can be looked up by sym execution *)
let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv = let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
@ -272,7 +272,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
let array_typ_size = Sil.exp_get_undefined false in let array_typ_size = Sil.exp_get_undefined false in
Sil.Tptr (Sil.Tarray (lookup_typ stripped_typ, array_typ_size), Sil.Pk_pointer) Sil.Tptr (Sil.Tarray (lookup_typ stripped_typ, array_typ_size), Sil.Pk_pointer)
| _ -> | _ ->
(* non-primitive/non-array type--resolve it in the tenv *) (* non-primitive/non-array type--resolve it in the tenv *)
match Sil.get_typ (Mangled.from_string typ_str) None tenv with match Sil.get_typ (Mangled.from_string typ_str) None tenv with
| Some typ -> typ | Some typ -> typ
| None -> failwith ("Failed to look up typ " ^ typ_str) in | None -> failwith ("Failed to look up typ " ^ typ_str) in
@ -295,30 +295,30 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = harness_cfg; cfg = harness_cfg;
name = procname; name = procname;
is_defined = false; is_defined = false;
ret_type = return_typ; ret_type = return_typ;
formals = params; formals = params;
locals = []; locals = [];
captured = []; captured = [];
loc = loc; loc = loc;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
list_iter (fun p -> list_iter (fun p ->
(* add harness -> callee edge to the call graph *) (* add harness -> callee edge to the call graph *)
Cg.add_edge cg harness_name p; Cg.add_edge cg harness_name p;
(* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the (* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the
* need to do this in the future *) * need to do this in the future *)
if not (SymExec.function_is_builtin p) then if not (SymExec.function_is_builtin p) then
(* simulate symbolic execution's lookup of a procedure *) (* simulate symbolic execution's lookup of a procedure *)
match Cfg.Procdesc.find_from_name harness_cfg p with match Cfg.Procdesc.find_from_name harness_cfg p with
| Some _ -> () | Some _ -> ()
| None -> ignore (create_dummy_procdesc p) | None -> ignore (create_dummy_procdesc p)
) (Cfg.Node.get_callees harness_node) ) (Cfg.Node.get_callees harness_node)
(** create and fill the appropriate nodes and add them to the harness cfg. also add the harness (** create and fill the appropriate nodes and add them to the harness cfg. also add the harness
* proc to the cg *) * proc to the cg *)
let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv = let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
(* TMP: pick an arbitrary cg and cfg to piggyback the harness code onto *) (* TMP: pick an arbitrary cg and cfg to piggyback the harness code onto *)
(* TODO (t4707171): create our own fresh cfg / cg instead *) (* TODO (t4707171): create our own fresh cfg / cg instead *)
@ -347,16 +347,16 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = harness_cfg; cfg = harness_cfg;
name = harness_name; name = harness_name;
is_defined = true; is_defined = true;
ret_type = Sil.Tvoid; ret_type = Sil.Tvoid;
formals = []; formals = [];
locals = []; locals = [];
captured = []; captured = [];
loc = env.pc; loc = env.pc;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
let harness_node = let harness_node =
(* important to reverse the list or there will be scoping issues! *) (* important to reverse the list or there will be scoping issues! *)
let instrs = (list_rev env.instrs) in let instrs = (list_rev env.instrs) in
@ -380,7 +380,7 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
Cfg.store_cfg_to_file cfg_file false harness_cfg Cfg.store_cfg_to_file cfg_file false harness_cfg
(** create a procedure named harness_name that calls each of the methods in trace in the specified (** create a procedure named harness_name that calls each of the methods in trace in the specified
* order with the specified receiver and add it to the execution environment *) * order with the specified receiver and add it to the execution environment *)
let inhabit_trace trace cb_flds harness_name proc_file_map tenv = if list_length trace > 0 then let inhabit_trace trace cb_flds harness_name proc_file_map tenv = if list_length trace > 0 then
let harness_cfg = Cfg.Node.create_cfg () in let harness_cfg = Cfg.Node.create_cfg () in
let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in

10
infer/src/harness/stacktrace.ml
Unescape View File

@ -32,7 +32,7 @@ type stack_frame =
| Unresolved of str_frame | Unresolved of str_frame
(** list representation of a stack trace. head of the list is the top of the stack (line/proc where (** list representation of a stack trace. head of the list is the top of the stack (line/proc where
exception occurs *) exception occurs *)
type stack_trace = stack_frame list type stack_trace = stack_frame list
(** given [str_frame], try to resolve its components in [exe_env] *) (** given [str_frame], try to resolve its components in [exe_env] *)
@ -40,8 +40,8 @@ let try_resolve_frame str_frame exe_env tenv =
try try
let class_name = Mangled.from_string str_frame.class_str in let class_name = Mangled.from_string str_frame.class_str in
(* find the class name in the tenv and get the procedure(s) whose names match the procedure name (* find the class name in the tenv and get the procedure(s) whose names match the procedure name
* in the stack trace. Note that the stack trace does not have any type or argument information; * in the stack trace. Note that the stack trace does not have any type or argument information;
* the name is all that we have to go on *) * the name is all that we have to go on *)
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with
| Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) -> | Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) ->
let possible_calls = let possible_calls =
@ -53,13 +53,13 @@ let try_resolve_frame str_frame exe_env tenv =
* same file, which will be true in Java but not necessarily in other languages *) * same file, which will be true in Java but not necessarily in other languages *)
let file_name = Exe_env.get_source exe_env (list_hd possible_calls) in let file_name = Exe_env.get_source exe_env (list_hd possible_calls) in
Resolved Resolved
{ possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; } { possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; }
else Unresolved str_frame else Unresolved str_frame
| _ -> Unresolved str_frame | _ -> Unresolved str_frame
with Not_found -> Unresolved str_frame with Not_found -> Unresolved str_frame
(** given a stack trace line like "at com.foo.Class.method(Class.java:42)" extract the class name, (** given a stack trace line like "at com.foo.Class.method(Class.java:42)" extract the class name,
method name, file name, and line number *) method name, file name, and line number *)
let parse_frame frame_str exe_env tenv = let parse_frame frame_str exe_env tenv =
(* separate the qualified method name and the parenthesized text/line number*) (* separate the qualified method name and the parenthesized text/line number*)
ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0); ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0);

16
infer/src/java/jClasspath.ml
Unescape View File

@ -149,14 +149,14 @@ let lookup_node cn (program: program) =
try try
Some (JBasics.ClassMap.find cn (get_classmap program)) Some (JBasics.ClassMap.find cn (get_classmap program))
with Not_found -> with Not_found ->
try try
let jclass = Javalib.get_class (get_classpath program) cn in let jclass = Javalib.get_class (get_classpath program) cn in
add_class cn jclass program; add_class cn jclass program;
Some jclass Some jclass
with with
| JBasics.No_class_found _ | JBasics.No_class_found _
| JBasics.Class_structure_error _ | JBasics.Class_structure_error _
| Invalid_argument _ -> None | Invalid_argument _ -> None
let classname_of_class_filename class_filename = let classname_of_class_filename class_filename =

12
infer/src/java/jContext.ml
Unescape View File

@ -81,11 +81,11 @@ let get_or_set_pvar_type context var typ =
else set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map); else set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
(pvar, typ) (pvar, typ)
with Not_found -> with Not_found ->
let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in
let varname = Mangled.from_string (JBir.var_name_g var) in let varname = Mangled.from_string (JBir.var_name_g var) in
let pvar = Sil.mk_pvar varname procname in let pvar = Sil.mk_pvar varname procname in
set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map); set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
(pvar, typ) (pvar, typ)
let lookup_pvar_type context var typ = (get_or_set_pvar_type context var typ) let lookup_pvar_type context var typ = (get_or_set_pvar_type context var typ)
@ -95,7 +95,7 @@ let reset_pvar_type context =
let var_map = get_var_map context in let var_map = get_var_map context in
let aux var item = let aux var item =
match item with (pvar, otyp, typ) -> match item with (pvar, otyp, typ) ->
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in
JBir.VarMap.iter aux var_map JBir.VarMap.iter aux var_map
let get_var_type context var = let get_var_type context var =

32
infer/src/java/jFrontend.ml
Unescape View File

@ -73,13 +73,13 @@ let add_cmethod never_null_matcher program icfg node cm is_static =
let cn, ms = JBasics.cms_split cm.Javalib.cm_class_method_signature in let cn, ms = JBasics.cms_split cm.Javalib.cm_class_method_signature in
let is_clinit = JBasics.ms_equal ms JBasics.clinit_signature in let is_clinit = JBasics.ms_equal ms JBasics.clinit_signature in
if !JTrans.no_static_final = false if !JTrans.no_static_final = false
&& is_clinit && is_clinit
&& not (JTransStaticField.has_static_final_fields node) then && not (JTransStaticField.has_static_final_fields node) then
JUtils.log "\t\tskipping class initializer: %s@." (JBasics.ms_name ms) JUtils.log "\t\tskipping class initializer: %s@." (JBasics.ms_name ms)
else else
match JTrans.get_method_procdesc program cfg tenv cn ms is_static with match JTrans.get_method_procdesc program cfg tenv cn ms is_static with
| JTrans.Defined procdesc when JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc) -> | JTrans.Defined procdesc when JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc) ->
(* do not capture the method if there is a model for it *) (* do not capture the method if there is a model for it *)
JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc)); JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc));
| JTrans.Defined procdesc -> | JTrans.Defined procdesc ->
let start_node = Cfg.Procdesc.get_start_node procdesc in let start_node = Cfg.Procdesc.get_start_node procdesc in
@ -112,7 +112,7 @@ let add_amethod program icfg node am is_static =
let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in
match JTrans.get_method_procdesc program cfg tenv cn ms is_static with match JTrans.get_method_procdesc program cfg tenv cn ms is_static with
| JTrans.Defined procdesc when (JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc)) -> | JTrans.Defined procdesc when (JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc)) ->
(* do not capture the method if there is a model for it *) (* do not capture the method if there is a model for it *)
JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc)); JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc));
| JTrans.Defined procdesc -> | JTrans.Defined procdesc ->
Cg.add_node icfg.JContext.cg (Cfg.Procdesc.get_proc_name procdesc) Cg.add_node icfg.JContext.cg (Cfg.Procdesc.get_proc_name procdesc)
@ -150,8 +150,8 @@ let is_classname_cached cn =
Sys.file_exists (path_of_cached_classname cn) Sys.file_exists (path_of_cached_classname cn)
(* Given a source file and a class, translates the code of this class. (* Given a source file and a class, translates the code of this class.
In init - mode, finds out whether this class contains initializers at all, In init - mode, finds out whether this class contains initializers at all,
in this case translates it. In standard mode, all methods are translated *) in this case translates it. In standard mode, all methods are translated *)
let create_icfg never_null_matcher linereader program icfg source_file cn node = let create_icfg never_null_matcher linereader program icfg source_file cn node =
JUtils.log "\tclassname: %s@." (JBasics.cn_name cn); JUtils.log "\tclassname: %s@." (JBasics.cn_name cn);
cache_classname cn; cache_classname cn;
@ -160,12 +160,12 @@ let create_icfg never_null_matcher linereader program icfg source_file cn node =
begin begin
Javalib.m_iter (JTrans.create_local_procdesc program linereader cfg tenv node) node; Javalib.m_iter (JTrans.create_local_procdesc program linereader cfg tenv node) node;
Javalib.m_iter (fun m -> Javalib.m_iter (fun m ->
let method_kind = JTransType.get_method_kind m in let method_kind = JTransType.get_method_kind m in
match m with match m with
| Javalib.ConcreteMethod cm -> | Javalib.ConcreteMethod cm ->
add_cmethod never_null_matcher program icfg node cm method_kind add_cmethod never_null_matcher program icfg node cm method_kind
| Javalib.AbstractMethod am -> | Javalib.AbstractMethod am ->
add_amethod program icfg node am method_kind add_amethod program icfg node am method_kind
) node ) node
end end
@ -196,8 +196,8 @@ let should_capture classes source_basename node =
(* Computes the control - flow graph and call - graph of a given source file. (* Computes the control - flow graph and call - graph of a given source file.
In the standard - mode, it translated all the classes that correspond to this In the standard - mode, it translated all the classes that correspond to this
source file. *) source file. *)
let compute_source_icfg let compute_source_icfg
never_null_matcher linereader classes program tenv source_basename source_file = never_null_matcher linereader classes program tenv source_basename source_file =
let icfg = let icfg =
@ -215,8 +215,8 @@ let compute_source_icfg
let () = let () =
JBasics.ClassMap.iter JBasics.ClassMap.iter
(select (select
(should_capture classes source_basename) (should_capture classes source_basename)
(create_icfg never_null_matcher linereader program icfg source_file)) (create_icfg never_null_matcher linereader program icfg source_file))
(JClasspath.get_classmap program) in (JClasspath.get_classmap program) in
(icfg.JContext.cg, icfg.JContext.cfg) (icfg.JContext.cg, icfg.JContext.cfg)

18
infer/src/java/jMain.ml
Unescape View File

@ -21,14 +21,14 @@ let arg_desc =
let desc = let desc =
(filter base_arg_desc) @ (filter base_arg_desc) @
[ [
"-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models"; "-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models";
"-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information"; "-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information";
"-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture"; "-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture";
"-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields"; "-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields";
"-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None, "-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None,
"Translate JVM checks"; "Translate JVM checks";
"-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None, "-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None,
"Set the path to the javac verbose output" "Set the path to the javac verbose output"
] in ] in
Arg2.create_options_desc false "Parsing Options" desc in Arg2.create_options_desc false "Parsing Options" desc in
base_arg base_arg
@ -93,7 +93,7 @@ let do_source_file
if JConfig.create_harness then if JConfig.create_harness then
list_fold_left list_fold_left
(fun proc_file_map pdesc -> (fun proc_file_map pdesc ->
Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map) Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map)
proc_file_map (Cfg.get_all_procs cfg) proc_file_map (Cfg.get_all_procs cfg)
else proc_file_map else proc_file_map

198
infer/src/java/jTrans.ml
Unescape View File

@ -28,8 +28,8 @@ let constr_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.
let init_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.empty let init_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.empty
(** Fix the line associated to a method definition. (** Fix the line associated to a method definition.
Since Sawja often reports a method off by a few lines, we search Since Sawja often reports a method off by a few lines, we search
backwards for a line where the method name is. *) backwards for a line where the method name is. *)
let fix_method_definition_line linereader proc_name loc = let fix_method_definition_line linereader proc_name loc =
let method_name = let method_name =
if Procname.is_constructor proc_name then if Procname.is_constructor proc_name then
@ -42,7 +42,7 @@ let fix_method_definition_line linereader proc_name loc =
| None -> raise Not_found | None -> raise Not_found
| Some line -> | Some line ->
(try ignore (Str.search_forward regex line 0); true (try ignore (Str.search_forward regex line 0); true
with Not_found -> false) in with Not_found -> false) in
let line = ref loc.Sil.line in let line = ref loc.Sil.line in
try try
while not (method_is_defined_here !line) do while not (method_is_defined_here !line) do
@ -111,9 +111,9 @@ let get_field_name program static tenv cn fs context =
(fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs) (fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs)
(if static then sfields else fields) (if static then sfields else fields)
with Not_found -> with Not_found ->
(* TODO: understand why fields cannot be found here *) (* TODO: understand why fields cannot be found here *)
JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs); JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs);
raise (Frontend_error "Cannot find fieldname") in raise (Frontend_error "Cannot find fieldname") in
fieldname fieldname
| _ -> assert false | _ -> assert false
@ -142,8 +142,8 @@ let formals program tenv cn impl =
list_rev (list_fold_left collect [] (JBir.params impl)) list_rev (list_fold_left collect [] (JBir.params impl))
(** Creates the local and formal variables from a procedure based on the (** Creates the local and formal variables from a procedure based on the
impl argument. If the meth_kind is Init, we add a parameter field to impl argument. If the meth_kind is Init, we add a parameter field to
the initialiser method. *) the initialiser method. *)
let locals_formals program tenv cn impl meth_kind = let locals_formals program tenv cn impl meth_kind =
let form_list = let form_list =
if meth_kind = JContext.Init then if meth_kind = JContext.Init then
@ -298,16 +298,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = true; is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind; ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals; formals = formals;
locals = []; locals = [];
captured = []; captured = [];
loc = Sil.dummy_location; loc = Sil.dummy_location;
proc_attributes = proc_attributes proc_attributes = proc_attributes
} in } in
let start_kind = Cfg.Node.Start_node procdesc in let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg Sil.dummy_location start_kind [] procdesc [] in let start_node = Cfg.Node.create cfg Sil.dummy_location start_kind [] procdesc [] in
let exit_kind = (Cfg.Node.Exit_node procdesc) in let exit_kind = (Cfg.Node.Exit_node procdesc) in
@ -334,16 +334,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = false; is_defined = false;
ret_type = JTransType.return_type program tenv ms meth_kind; ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals; formals = formals;
locals = []; locals = [];
captured = []; captured = [];
loc = Sil.dummy_location; loc = Sil.dummy_location;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
() ()
| Javalib.ConcreteMethod cm -> | Javalib.ConcreteMethod cm ->
let impl = get_implementation cm in let impl = get_implementation cm in
@ -371,16 +371,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = true; is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind; ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals; formals = formals;
locals = locals; locals = locals;
captured = []; captured = [];
loc = loc_start; loc = loc_start;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
} in } in
let start_kind = Cfg.Node.Start_node procdesc in let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in
let exit_kind = (Cfg.Node.Exit_node procdesc) in let exit_kind = (Cfg.Node.Exit_node procdesc) in
@ -392,7 +392,7 @@ let create_local_procdesc program linereader cfg tenv node m =
Cfg.Procdesc.set_exit_node procdesc exit_node; Cfg.Procdesc.set_exit_node procdesc exit_node;
Cfg.Node.add_locals_ret_declaration start_node locals; Cfg.Node.add_locals_ret_declaration start_node locals;
with JBir.Subroutine -> with JBir.Subroutine ->
L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in
match lookup_procdesc cfg procname with match lookup_procdesc cfg procname with
| Unknown -> create_new_procdesc () | Unknown -> create_new_procdesc ()
| Created defined_status -> | Created defined_status ->
@ -412,31 +412,31 @@ let create_external_procdesc program cfg tenv cn ms method_annotation kind =
let formals = formals_from_signature program tenv cn ms kind in let formals = formals_from_signature program tenv cn ms kind in
let procname = JTransType.get_method_procname cn ms kind in let procname = JTransType.get_method_procname cn ms kind in
ignore ( ignore (
let open Cfg.Procdesc in let open Cfg.Procdesc in
let proc_attributes = let proc_attributes =
{ {
Sil.access = Sil.Default; Sil.access = Sil.Default;
Sil.exceptions = []; Sil.exceptions = [];
Sil.is_abstract = false; Sil.is_abstract = false;
Sil.is_bridge_method = false; Sil.is_bridge_method = false;
Sil.is_objc_instance_method = false; Sil.is_objc_instance_method = false;
Sil.is_synthetic_method = false; Sil.is_synthetic_method = false;
Sil.language = Sil.Java; Sil.language = Sil.Java;
Sil.func_attributes = []; Sil.func_attributes = [];
Sil.method_annotation = method_annotation; Sil.method_annotation = method_annotation;
Sil.is_generated = false; Sil.is_generated = false;
} in } in
create { create {
cfg = cfg; cfg = cfg;
name = procname; name = procname;
is_defined = false; is_defined = false;
ret_type = return_type; ret_type = return_type;
formals = formals; formals = formals;
locals = []; locals = [];
captured = []; captured = [];
loc = Sil.dummy_location; loc = Sil.dummy_location;
proc_attributes = proc_attributes; proc_attributes = proc_attributes;
}) })
(** returns the procedure description of the given method and creates it if it hasn't been created before *) (** returns the procedure description of the given method and creates it if it hasn't been created before *)
let rec get_method_procdesc program cfg tenv cn ms kind = let rec get_method_procdesc program cfg tenv cn ms kind =
@ -510,16 +510,16 @@ let rec expression context pc expr =
| JBir.InstanceOf ot | JBir.Cast ot -> | JBir.InstanceOf ot | JBir.Cast ot ->
let subtypes = let subtypes =
(match unop with (match unop with
| JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof | JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof
| JBir.Cast _ -> Sil.Subtype.subtypes_cast | JBir.Cast _ -> Sil.Subtype.subtypes_cast
| _ -> assert false) in | _ -> assert false) in
let sizeof_expr = let sizeof_expr =
JTransType.sizeof_of_object_type program tenv ot subtypes in JTransType.sizeof_of_object_type program tenv ot subtypes in
let builtin = let builtin =
(match unop with (match unop with
| JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) | JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof)
| JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast) | JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast)
| _ -> assert false) in | _ -> assert false) in
let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] in let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] in
let ret_id = Ident.create_fresh Ident.knormal in let ret_id = Ident.create_fresh Ident.knormal in
let call = Sil.Call([ret_id], builtin, args, loc, Sil.cf_default) in let call = Sil.Call([ret_id], builtin, args, loc, Sil.cf_default) in
@ -532,7 +532,7 @@ let rec expression context pc expr =
begin begin
match binop with match binop with
| JBir.ArrayLoad vt -> | JBir.ArrayLoad vt ->
(* add an instruction that dereferences the array *) (* add an instruction that dereferences the array *)
let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in
let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in
let id = Ident.create_fresh Ident.knormal in let id = Ident.create_fresh Ident.knormal in
@ -609,7 +609,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
match sil_obj_opt with match sil_obj_opt with
| None -> ([], [], []) | None -> ([], [], [])
| Some (sil_obj_expr, sil_obj_type) -> | Some (sil_obj_expr, sil_obj_type) ->
(* for non-constructors, add an instruction that dereferences the receiver *) (* for non-constructors, add an instruction that dereferences the receiver *)
let ids, instrs = let ids, instrs =
let is_non_constructor_call = let is_non_constructor_call =
match invoke_code with match invoke_code with
@ -628,9 +628,9 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
let (idl, instrs, call_args) = let (idl, instrs, call_args) =
list_fold_left list_fold_left
(fun (idl_accu, instrs_accu, args_accu) expr -> (fun (idl_accu, instrs_accu, args_accu) expr ->
let (idl, instrs, sil_expr) = expression context pc expr in let (idl, instrs, sil_expr) = expression context pc expr in
let sil_expr_type = JTransType.expr_type context expr in let sil_expr_type = JTransType.expr_type context expr in
(idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)])) (idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)]))
init init
expr_list in expr_list in
let callee_procname = let callee_procname =
@ -659,22 +659,22 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
(* add a file attribute when calling the constructor of a subtype of Closeable *) (* add a file attribute when calling the constructor of a subtype of Closeable *)
| (var, typ) as exp :: _ | (var, typ) as exp :: _
when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ -> when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ ->
let set_file_attr = let set_file_attr =
let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the constructor should prevent adding the resource attribute *) (* Exceptions thrown in the constructor should prevent adding the resource attribute *)
call_instrs @ [set_file_attr] call_instrs @ [set_file_attr]
(* remove file attribute when calling the close method of a subtype of Closeable *) (* remove file attribute when calling the close method of a subtype of Closeable *)
| (var, typ) as exp :: [] | (var, typ) as exp :: []
when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ -> when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ ->
let set_mem_attr = let set_mem_attr =
let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the close method should not prevent the resource from being *) (* Exceptions thrown in the close method should not prevent the resource from being *)
(* considered as closed *) (* considered as closed *)
[set_mem_attr] @ call_instrs [set_mem_attr] @ call_instrs
| _ -> call_instrs in | _ -> call_instrs in
@ -791,15 +791,15 @@ let rec extends context node1 node2 =
let instruction_array_call ms obj_type obj args var_opt vt = let instruction_array_call ms obj_type obj args var_opt vt =
if is_clone ms then if is_clone ms then
(let cn = JBasics.make_cn JConfig.infer_array_cl in (let cn = JBasics.make_cn JConfig.infer_array_cl in
let vt = (JBasics.TObject obj_type) in let vt = (JBasics.TObject obj_type) in
let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in
JBir.InvokeStatic (var_opt, cn, ms, obj:: args)) JBir.InvokeStatic (var_opt, cn, ms, obj:: args))
else else
(let undef_cn, undef_ms = get_undefined_method_call (JBasics.ms_rtype ms) in (let undef_cn, undef_ms = get_undefined_method_call (JBasics.ms_rtype ms) in
JBir.InvokeStatic (var_opt, undef_cn, undef_ms, [])) JBir.InvokeStatic (var_opt, undef_cn, undef_ms, []))
(* special translation of the method start() of a Thread or a Runnable object. (* special translation of the method start() of a Thread or a Runnable object.
We translate it directly as the run() method *) We translate it directly as the run() method *)
let instruction_thread_start context cn ms obj args var_opt = let instruction_thread_start context cn ms obj args var_opt =
match JClasspath.lookup_node cn (JContext.get_program context) with match JClasspath.lookup_node cn (JContext.get_program context) with
| None -> | None ->
@ -849,7 +849,7 @@ let rec instruction context pc instr : translation =
cfg (get_location (JContext.get_impl context) pc meth_kind cn) node_kind sil_instrs (JContext.get_procdesc context) temps in cfg (get_location (JContext.get_impl context) pc meth_kind cn) node_kind sil_instrs (JContext.get_procdesc context) temps in
let return_not_null () = let return_not_null () =
(match_never_null loc.Sil.file proc_name (match_never_null loc.Sil.file proc_name
|| list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in || list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in
try try
match instr with match instr with
| JBir.AffectVar (var, expr) -> | JBir.AffectVar (var, expr) ->
@ -990,8 +990,8 @@ let rec instruction context pc instr : translation =
let sil_obj_opt, args, ids, instrs = let sil_obj_opt, args, ids, instrs =
match args with match args with
| [arg] when is_clone ms -> | [arg] when is_clone ms ->
(* hack to null check the receiver of clone when clone is an array. in the array.clone() (* hack to null check the receiver of clone when clone is an array. in the array.clone()
case, clone is a virtual call that we translate as a static call *) case, clone is a virtual call that we translate as a static call *)
let (ids, instrs, sil_arg_expr) = expression context pc arg in let (ids, instrs, sil_arg_expr) = expression context pc arg in
let arg_typ = JTransType.expr_type context arg in let arg_typ = JTransType.expr_type context arg in
Some (sil_arg_expr, arg_typ), [], ids, instrs Some (sil_arg_expr, arg_typ), [], ids, instrs
@ -1051,7 +1051,7 @@ let rec instruction context pc instr : translation =
Instr call_node Instr call_node
| JBir.Check (JBir.CheckNullPointer expr) when !JConfig.translate_checks && is_this expr -> | JBir.Check (JBir.CheckNullPointer expr) when !JConfig.translate_checks && is_this expr ->
(* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *) (* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *)
let (ids, instrs, sil_expr) = expression context pc expr in let (ids, instrs, sil_expr) = expression context pc expr in
let this_not_null_node = let this_not_null_node =
create_node create_node
@ -1183,5 +1183,5 @@ let rec instruction context pc instr : translation =
| _ -> Skip | _ -> Skip
with Frontend_error s -> with Frontend_error s ->
JUtils.log "Skipping because of: %s@." s; JUtils.log "Skipping because of: %s@." s;
Skip Skip

120
infer/src/java/jTransExn.ml
Unescape View File

@ -20,7 +20,7 @@ let create_handler_table impl =
let handlers = Hashtbl.find handler_tb pc in let handlers = Hashtbl.find handler_tb pc in
Hashtbl.replace handler_tb pc (exn_handler:: handlers) Hashtbl.replace handler_tb pc (exn_handler:: handlers)
with Not_found -> with Not_found ->
Hashtbl.add handler_tb pc [exn_handler] in Hashtbl.add handler_tb pc [exn_handler] in
List.iter collect (JBir.exception_edges impl); List.iter collect (JBir.exception_edges impl);
handler_tb handler_tb
@ -46,62 +46,62 @@ let translate_exceptions context exit_nodes get_body_nodes handler_table =
try try
ignore (Hashtbl.find catch_block_table handler_list) ignore (Hashtbl.find catch_block_table handler_list)
with Not_found -> with Not_found ->
let collect succ_nodes last_handler rethrow_exception handler = let collect succ_nodes last_handler rethrow_exception handler =
let catch_nodes = get_body_nodes handler.JBir.e_handler in let catch_nodes = get_body_nodes handler.JBir.e_handler in
let loc = match catch_nodes with let loc = match catch_nodes with
| n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in
let exn_type =
let class_name =
match handler.JBir.e_catch_type with
| None -> JBasics.make_cn "java.lang.Exception"
| Some cn -> cn in
match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with
| Sil.Tptr (typ, _) -> typ
| _ -> assert false in
let id_instanceof = Ident.create_fresh Ident.knormal in
let instr_call_instanceof =
let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in
let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in
Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in
let if_kind = Sil.Ik_switch in
let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in
let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in
let instr_set_catch_var =
let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in
Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in
let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in
let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in
let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in
let node_true =
let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in
let ids_true = [id_exn_val; id_instanceof] in
create_node loc node_kind_true instrs_true ids_true in
let node_false =
let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in
let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in
create_node loc node_kind_false instrs_false ids_false in
Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes;
Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes;
let is_finally = handler.JBir.e_catch_type = None in
if is_finally
then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *)
else [node_true; node_false] in
let is_last_handler = ref true in
let process_handler succ_nodes handler = (* process handlers starting from the last one *)
let is_finally_handler = handler.JBir.e_catch_type = None in
let remove_temps = !is_last_handler in (* remove temporary variables on last handler *)
let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *)
is_last_handler := false;
collect succ_nodes remove_temps rethrow_exception handler in
let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in
let loc = match nodes_first_handler with
| n:: _ -> Cfg.Node.get_loc n | n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in | [] -> Sil.dummy_location in
let entry_node = create_entry_node loc in let exn_type =
Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes; let class_name =
Hashtbl.add catch_block_table handler_list [entry_node] in match handler.JBir.e_catch_type with
| None -> JBasics.make_cn "java.lang.Exception"
| Some cn -> cn in
match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with
| Sil.Tptr (typ, _) -> typ
| _ -> assert false in
let id_instanceof = Ident.create_fresh Ident.knormal in
let instr_call_instanceof =
let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in
let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in
Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in
let if_kind = Sil.Ik_switch in
let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in
let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in
let instr_set_catch_var =
let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in
Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in
let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in
let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in
let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in
let node_true =
let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in
let ids_true = [id_exn_val; id_instanceof] in
create_node loc node_kind_true instrs_true ids_true in
let node_false =
let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in
let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in
create_node loc node_kind_false instrs_false ids_false in
Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes;
Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes;
let is_finally = handler.JBir.e_catch_type = None in
if is_finally
then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *)
else [node_true; node_false] in
let is_last_handler = ref true in
let process_handler succ_nodes handler = (* process handlers starting from the last one *)
let is_finally_handler = handler.JBir.e_catch_type = None in
let remove_temps = !is_last_handler in (* remove temporary variables on last handler *)
let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *)
is_last_handler := false;
collect succ_nodes remove_temps rethrow_exception handler in
let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in
let loc = match nodes_first_handler with
| n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in
let entry_node = create_entry_node loc in
Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes;
Hashtbl.add catch_block_table handler_list [entry_node] in
Hashtbl.iter (fun pc handler_list -> create_entry_block pc handler_list) handler_table; Hashtbl.iter (fun pc handler_list -> create_entry_block pc handler_list) handler_table;
catch_block_table catch_block_table
@ -112,8 +112,8 @@ let create_exception_handlers context exit_nodes get_body_nodes impl =
let handler_table = create_handler_table impl in let handler_table = create_handler_table impl in
let catch_block_table = translate_exceptions context exit_nodes get_body_nodes handler_table in let catch_block_table = translate_exceptions context exit_nodes get_body_nodes handler_table in
fun pc -> fun pc ->
try try
let handler_list = Hashtbl.find handler_table pc in let handler_list = Hashtbl.find handler_table pc in
Hashtbl.find catch_block_table handler_list Hashtbl.find catch_block_table handler_list
with Not_found -> with Not_found ->
exit_nodes exit_nodes

46
infer/src/java/jTransStaticField.ml
Unescape View File

@ -33,7 +33,7 @@ let is_basic_type fs =
| JBasics.TObject ot -> false | JBasics.TObject ot -> false
(** Returns whether the node contains static final fields (** Returns whether the node contains static final fields
that are not of a primitive type or String. *) that are not of a primitive type or String. *)
let rec has_static_final_fields node = let rec has_static_final_fields node =
let detect fs f test = let detect fs f test =
test || (Javalib.is_static_field f && Javalib.is_final_field f) in test || (Javalib.is_static_field f && Javalib.is_final_field f) in
@ -42,7 +42,7 @@ let rec has_static_final_fields node =
(* Patricia trees *) (* Patricia trees *)
(** collects the code line where the fields are initialised. The list is (** collects the code line where the fields are initialised. The list is
reversed in order to access the previous element in the list easier (as the successor.) *) reversed in order to access the previous element in the list easier (as the successor.) *)
let collect_field_pc instrs field_pc_list = let collect_field_pc instrs field_pc_list =
let aux pc instr = let aux pc instr =
match instr with match instr with
@ -53,7 +53,7 @@ let collect_field_pc instrs field_pc_list =
(List.rev !field_pc_list) (List.rev !field_pc_list)
(** Changes every position in the code where a static field is set to a value, (** Changes every position in the code where a static field is set to a value,
to returning that value *) to returning that value *)
let add_return_field instrs = let add_return_field instrs =
let aux instr = let aux instr =
match instr with match instr with
@ -63,8 +63,8 @@ let add_return_field instrs =
(Array.map aux instrs) (Array.map aux instrs)
(** Given a list with the lines where the fields are initialised, (** Given a list with the lines where the fields are initialised,
finds the line where the code for the initialisation of the given field starts, finds the line where the code for the initialisation of the given field starts,
which is the line after the previous field has been initialised. *) which is the line after the previous field has been initialised. *)
let rec find_pc field list = let rec find_pc field list =
match list with match list with
| (fs, pc):: rest -> | (fs, pc):: rest ->
@ -107,9 +107,9 @@ let has_unclear_control_flow code =
(** In the initialiser of static fields, we add instructions (** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter. *) for returning the field selected by the parameter. *)
(* The constant s means the parameter field of the function. (* The constant s means the parameter field of the function.
Note that we remove the initialisation of non - final static fields. *) Note that we remove the initialisation of non - final static fields. *)
let rec static_field_init_complex cn code fields length = let rec static_field_init_complex cn code fields length =
let code = Array.append [| (JBir.Goto length ) |] code in let code = Array.append [| (JBir.Goto length ) |] code in
let s = JConfig.field_cst in let s = JConfig.field_cst in
@ -130,7 +130,7 @@ let rec static_field_init_complex cn code fields length =
else else
let _ = let _ =
if Javalib.is_static_field field && pc <> -1 then if Javalib.is_static_field field && pc <> -1 then
field_nonfinal_pcs := pc::!field_nonfinal_pcs in field_nonfinal_pcs := pc::!field_nonfinal_pcs in
aux s rest aux s rest
| [] -> [| JBir.Nop |] in | [] -> [| JBir.Nop |] in
let new_instrs = aux s fields in let new_instrs = aux s fields in
@ -140,8 +140,8 @@ let rec static_field_init_complex cn code fields length =
code code
(** In the initialiser of static fields, we add instructions (** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter without changing for returning the field selected by the parameter without changing
the control flow of the original code. *) the control flow of the original code. *)
let rec static_field_init_simple cn code fields length = let rec static_field_init_simple cn code fields length =
let s = JConfig.field_cst in let s = JConfig.field_cst in
let rec aux s pc fields = let rec aux s pc fields =
@ -161,13 +161,13 @@ let rec static_field_init_simple cn code fields length =
code code
(** In the initialiser of static fields, we add instructions (** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter. In normal for returning the field selected by the parameter. In normal
cases the code for the initialisation of each field is clearly separated cases the code for the initialisation of each field is clearly separated
from the code for the initialisation of the next field. However, in some cases from the code for the initialisation of the next field. However, in some cases
the fields are initialised in static blocks in which they may use try and catch. the fields are initialised in static blocks in which they may use try and catch.
In these cases it is not possible to separate the code for the initialisation In these cases it is not possible to separate the code for the initialisation
of each field, so we do not change the original code, but append intructions of each field, so we do not change the original code, but append intructions
for returning the selected field. *) for returning the selected field. *)
let rec static_field_init node cn code = let rec static_field_init node cn code =
try try
let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in
@ -200,9 +200,9 @@ let is_static_final_field context cn fs =
match JClasspath.lookup_node cn (JContext.get_program context) with match JClasspath.lookup_node cn (JContext.get_program context) with
| None -> false | None -> false
| Some node -> | Some node ->
try try
let f = Javalib.get_field node fs in let f = Javalib.get_field node fs in
let is_static = Javalib.is_static_field f in let is_static = Javalib.is_static_field f in
let is_final = Javalib.is_final_field f in let is_final = Javalib.is_final_field f in
(is_static && is_final) (is_static && is_final)
with Not_found -> false with Not_found -> false

38
infer/src/java/jTransType.ml
Unescape View File

@ -105,14 +105,14 @@ let rec array_type_to_string vt =
match vt with match vt with
| JBasics.TBasic bt -> | JBasics.TBasic bt ->
(match bt with (match bt with
| `Bool -> JConfig.boolean_code | `Bool -> JConfig.boolean_code
| `Byte -> JConfig.byte_code | `Byte -> JConfig.byte_code
| `Char -> JConfig.char_code | `Char -> JConfig.char_code
| `Double -> JConfig.double_code | `Double -> JConfig.double_code
| `Float -> JConfig.float_code | `Float -> JConfig.float_code
| `Int -> JConfig.int_code | `Int -> JConfig.int_code
| `Long -> JConfig.long_code | `Long -> JConfig.long_code
| `Short -> JConfig.short_code) | `Short -> JConfig.short_code)
| JBasics.TObject ot -> object_type_to_string' ot in | JBasics.TObject ot -> object_type_to_string' ot in
"["^s "["^s
and object_type_to_string' ot = and object_type_to_string' ot =
@ -158,7 +158,7 @@ let package_to_string p =
let cn_to_java_type cn = let cn_to_java_type cn =
(package_to_string (JBasics.cn_package cn), (package_to_string (JBasics.cn_package cn),
(JBasics.cn_simple_name cn)) (JBasics.cn_simple_name cn))
let rec vt_to_java_type vt = let rec vt_to_java_type vt =
@ -274,7 +274,7 @@ let collect_models_class_fields classpath_field_map static cn cf l =
(Sil.pp_typ_full pe_text) classpath_ft (Sil.pp_typ_full pe_text) classpath_ft
(Sil.pp_typ_full pe_text) field_type in l (Sil.pp_typ_full pe_text) field_type in l
with Not_found -> with Not_found ->
(field_name, field_type, annotation):: l (field_name, field_type, annotation):: l
let add_model_fields program (static_fields, nonstatic_fields) cn = let add_model_fields program (static_fields, nonstatic_fields) cn =
@ -312,7 +312,7 @@ let rec create_sil_type program tenv cn =
let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in
(sil_interface_list, [], static_fields, item_annotation) (sil_interface_list, [], static_fields, item_annotation)
| Javalib.JClass jclass -> | Javalib.JClass jclass ->
(* TODO: create two functions to get static fields and non-static ones *) (* TODO: create two functions to get static fields and non-static ones *)
let static_fields, nonstatic_fields = let static_fields, nonstatic_fields =
let classpath_static_fields = get_all_fields program true cn let classpath_static_fields = get_all_fields program true cn
and classpath_nonstatic_fields = get_all_fields program false cn in and classpath_nonstatic_fields = get_all_fields program false cn in
@ -421,7 +421,7 @@ let extract_array_type typ =
(** translate the type of an expression, looking in the method signature for formal parameters (** translate the type of an expression, looking in the method signature for formal parameters
this is because variables in expressions do not have accurate types *) this is because variables in expressions do not have accurate types *)
let rec expr_type context expr = let rec expr_type context expr =
let program = JContext.get_program context in let program = JContext.get_program context in
let tenv = JContext.get_tenv context in let tenv = JContext.get_tenv context in
@ -429,8 +429,8 @@ let rec expr_type context expr =
| JBir.Const const -> value_type program tenv (const_type const) | JBir.Const const -> value_type program tenv (const_type const)
| JBir.Var (vt, var) -> | JBir.Var (vt, var) ->
(match get_var_type context var with (match get_var_type context var with
| Some typ -> typ | Some typ -> typ
| None -> (value_type program tenv vt)) | None -> (value_type program tenv vt))
| JBir.Binop ((JBir.ArrayLoad typ), e1, e2) -> | JBir.Binop ((JBir.ArrayLoad typ), e1, e2) ->
let typ = expr_type context e1 in let typ = expr_type context e1 in
(extract_array_type typ) (extract_array_type typ)
@ -438,8 +438,8 @@ let rec expr_type context expr =
(** Returns the return type of the method based on the return type (** Returns the return type of the method based on the return type
specified in ms. If the method is the initialiser, return the type specified in ms. If the method is the initialiser, return the type
Object instead. *) Object instead. *)
let return_type program tenv ms meth_kind = let return_type program tenv ms meth_kind =
if meth_kind = JContext.Init then if meth_kind = JContext.Init then
get_class_type program tenv (JBasics.make_cn JConfig.object_cl) get_class_type program tenv (JBasics.make_cn JConfig.object_cl)
@ -467,7 +467,7 @@ let saturate_tenv_with_classpath classpath tenv =
Sil.TN_csu (Sil.Class, classname) in Sil.TN_csu (Sil.Class, classname) in
let rec is_useful_subtype jar_tenv = function let rec is_useful_subtype jar_tenv = function
| Sil.TN_csu (Sil.Class, classname) when | Sil.TN_csu (Sil.Class, classname) when
Mangled.equal classname JConfig.java_lang_object_classname -> false Mangled.equal classname JConfig.java_lang_object_classname -> false
| typename when Sil.tenv_mem tenv typename -> true | typename when Sil.tenv_mem tenv typename -> true
| typename -> | typename ->
begin begin
@ -515,8 +515,8 @@ let never_returning_null =
let fragment_type = "android.support.v4.app.Fragment" in let fragment_type = "android.support.v4.app.Fragment" in
let never_null_method_sigs = let never_null_method_sigs =
[ [
(fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static); (fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static);
(fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static) (fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static)
] in ] in
let make_procname = function let make_procname = function
| (class_name, method_name, arg_types, ret_type, kind) -> | (class_name, method_name, arg_types, ret_type, kind) ->

18
infer/src/llvm/lMain.ml
Unescape View File

@ -12,13 +12,13 @@ open Printf
exception UsageError of string exception UsageError of string
let () = try let () = try
if Array.length Sys.argv < 2 then if Array.length Sys.argv < 2 then
raise (UsageError ("Missing source file as first command line argument.")) raise (UsageError ("Missing source file as first command line argument."))
else else
let filename = Sys.argv.(1) in let filename = Sys.argv.(1) in
let lexbuf = Lexing.from_channel (open_in filename) in let lexbuf = Lexing.from_channel (open_in filename) in
let prog = LParser.prog LLexer.token lexbuf in let prog = LParser.prog LLexer.token lexbuf in
let pretty = LPretty.pretty_prog prog in let pretty = LPretty.pretty_prog prog in
LTrans.gen_prog prog; () LTrans.gen_prog prog; ()
with with
| UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n") | UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n")

10
infer/src/llvm/lPretty.ml
Unescape View File

@ -47,10 +47,10 @@ let pretty_instr : instr -> string = function
let pretty_instr_ln (i : instr) : string = pretty_instr i ^ "\n" let pretty_instr_ln (i : instr) : string = pretty_instr i ^ "\n"
let pretty_func_def : func_def -> string = function let pretty_func_def : func_def -> string = function
FuncDef (name, ret_tp, params, instrs) -> FuncDef (name, ret_tp, params, instrs) ->
"define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^ "define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^
concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^ concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^
concatmap "" pretty_instr_ln instrs ^ "}\n" concatmap "" pretty_instr_ln instrs ^ "}\n"
let pretty_prog : prog -> string = function let pretty_prog : prog -> string = function
Prog defs -> concatmap "" pretty_func_def defs Prog defs -> concatmap "" pretty_func_def defs

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save