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

[SIL] splitting off biabd stuff from SIL

Browse Source 
Summary:
Move most of IR/Sil.ml into a new file biabduction/Predicates.ml to
reflect the fact that they are only useful for the biabduction analysis.
Unfortunately this is a huge change.

I tried to keep the change to a minimum, it's mostly about doing
s/Sil/Predicates/ in lots of places but sometimes I used the trick of
specifying parameters or return value types to avoid specifying the
module altogether. This isn't done consistently because there were just
too many places to change for poor me.

Reviewed By: ngorogiannis

Differential Revision: D19158530

fbshipit-source-id: d6dbcfe72
master
Jules Villard 5 years ago committed by Facebook Github Bot
parent bc799fc6cd
commit 65d0d18326
37 changed files with 3276 additions and 3170 deletions
Show Stats Download Patch File Download Diff File

1254
infer/src/IR/Sil.ml
View File

File diff suppressed because it is too large Load Diff

374
infer/src/IR/Sil.mli
Unescape View File

@ -78,186 +78,10 @@ val skip_instr : instr
val instr_is_auxiliary : instr -> bool
(** Check if an instruction is auxiliary, or if it comes from source instructions. *)
(** Offset for an lvalue. *)
type offset = Off_fld of Typ.Fieldname.t * Typ.t | Off_index of Exp.t
(** {2 Components of Propositions} *)
(** an atom is a pure atomic formula *)
type atom =
| Aeq of Exp.t * Exp.t (** equality *)
| Aneq of Exp.t * Exp.t (** disequality *)
| Apred of PredSymb.t * Exp.t list (** predicate symbol applied to exps *)
| Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *)
[@@deriving compare]
val equal_atom : atom -> atom -> bool
val atom_has_local_addr : atom -> bool
(** kind of lseg or dllseg predicates *)
type lseg_kind =
| Lseg_NE (** nonempty (possibly circular) listseg *)
| Lseg_PE (** possibly empty (possibly circular) listseg *)
[@@deriving compare]
val equal_lseg_kind : lseg_kind -> lseg_kind -> bool
(** The boolean is true when the pointer was dereferenced without testing for zero. *)
type zero_flag = bool option
(** True when the value was obtained by doing case analysis on null in a procedure call. *)
type null_case_flag = bool
(** instrumentation of heap values *)
type inst =
| Iabstraction
| Iactual_precondition
| Ialloc
| Iformal of zero_flag * null_case_flag
| Iinitial
| Ilookup
| Inone
| Inullify
| Irearrange of zero_flag * null_case_flag * int * PredSymb.path_pos
| Itaint
| Iupdate of zero_flag * null_case_flag * int * PredSymb.path_pos
| Ireturn_from_call of int
[@@deriving compare]
val equal_inst : inst -> inst -> bool
val inst_actual_precondition : inst
val inst_formal : inst
val inst_initial : inst
(** for formal parameters and heap values at the beginning of the function *)
val inst_lookup : inst
(** for initial values *)
val inst_none : inst
val inst_nullify : inst
val inst_rearrange : bool -> Location.t -> PredSymb.path_pos -> inst
(** the boolean indicates whether the pointer is known nonzero *)
val inst_update : Location.t -> PredSymb.path_pos -> inst
val inst_set_null_case_flag : inst -> inst
(** Set the null case flag of the inst. *)
val inst_new_loc : Location.t -> inst -> inst
(** update the location of the instrumentation *)
val update_inst : inst -> inst -> inst
(** Update [inst_old] to [inst_new] preserving the zero flag *)
exception JoinFail
val inst_partial_join : inst -> inst -> inst
(** join of instrumentations, can raise JoinFail *)
val inst_partial_meet : inst -> inst -> inst
(** meet of instrumentations *)
(** structured expressions represent a value of structured type, such as an array or a struct. *)
type 'inst strexp0 =
| Eexp of Exp.t * 'inst (** Base case: expression with instrumentation *)
| Estruct of (Typ.Fieldname.t * 'inst strexp0) list * 'inst (** C structure *)
| Earray of Exp.t * (Exp.t * 'inst strexp0) list * 'inst
(** Array of given length There are two conditions imposed / used in the array case. First, if
some index and value pair appears inside an array in a strexp, then the index is less than
the length of the array. For instance, [x |->\[10 | e1: v1\]] implies that [e1 <= 9].
Second, if two indices appear in an array, they should be different. For instance,
[x |->\[10 | e1: v1, e2: v2\]] implies that [e1 != e2]. *)
[@@deriving compare]
type strexp = inst strexp0
val compare_strexp : ?inst:bool -> strexp -> strexp -> int
(** Comparison function for strexp. The inst:: parameter specifies whether instumentations should
also be considered (false by default). *)
val equal_strexp : ?inst:bool -> strexp -> strexp -> bool
(** Equality function for strexp. The inst:: parameter specifies whether instumentations should also
be considered (false by default). *)
(** an atomic heap predicate *)
type 'inst hpred0 =
| Hpointsto of Exp.t * 'inst strexp0 * Exp.t
(** represents [exp|->strexp:typexp] where [typexp] is an expression representing a type, e.h.
[sizeof(t)]. *)
| Hlseg of lseg_kind * 'inst hpara0 * Exp.t * Exp.t * Exp.t list
(** higher - order predicate for singly - linked lists. Should ensure that exp1!= exp2 implies
that exp1 is allocated. 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. *)
| Hdllseg of lseg_kind * 'inst hpara_dll0 * Exp.t * Exp.t * Exp.t * Exp.t * Exp.t list
(** higher-order predicate for doubly-linked lists. Parameter for the higher-order
singly-linked list predicate. Means "lambda (root,next,svars). Exists evars. body". Assume
that root, next, svars, evars are disjoint sets of primed identifiers, and include all the
free primed identifiers in body. body should not contain any non - primed identifiers or
program variables (i.e. pvars). *)
[@@deriving compare]
and 'inst hpara0 =
{root: Ident.t; next: Ident.t; svars: Ident.t list; evars: Ident.t list; body: 'inst hpred0 list}
[@@deriving compare]
(** parameter for the higher-order doubly-linked list predicates. Assume that all the free
identifiers in body_dll should belong to cell, blink, flink, svars_dll, evars_dll. *)
and 'inst hpara_dll0 =
{ cell: Ident.t (** address cell *)
; blink: Ident.t (** backward link *)
; flink: Ident.t (** forward link *)
; svars_dll: Ident.t list
; evars_dll: Ident.t list
; body_dll: 'inst hpred0 list }
[@@deriving compare]
type hpred = inst hpred0
type hpara = inst hpara0
type hpara_dll = inst hpara_dll0
val compare_hpred : ?inst:bool -> hpred -> hpred -> int
(** Comparison function for hpred. The inst:: parameter specifies whether instumentations should
also be considered (false by default). *)
val equal_hpred : ?inst:bool -> hpred -> hpred -> bool
(** Equality function for hpred. The inst:: parameter specifies whether instumentations should also
be considered (false by default). *)
module HpredSet : Caml.Set.S with type elt = hpred
(** Sets of heap predicates *)
(** {2 Compaction} *)
type sharing_env
val create_sharing_env : unit -> sharing_env
(** Create a sharing env to store canonical representations *)
val hpred_compact : sharing_env -> hpred -> hpred
(** Return a compact representation of the exp *)
val is_objc_object : hpred -> bool
(** {2 Comparision And Inspection Functions} *)
val add_with_block_parameters_flag : instr -> instr
(** Adds a with_blocks_parameters flag to a method call, when the arguments contain an Objective-C
block, and the method is an Objective-C method (to be extended to other methods) *)
(** {2 Pretty Printing} *)
val pp_offset : Pp.env -> F.formatter -> offset -> unit
val d_offset_list : offset list -> unit
(** Dump a list of offsets *)
val location_of_instr : instr -> Location.t
(** Get the location of the instruction *)
@ -274,201 +98,3 @@ val pp_instr : print_types:bool -> Pp.env -> F.formatter -> instr -> unit
val d_instr : instr -> unit
(** Dump an instruction. *)
val pp_atom : Pp.env -> F.formatter -> atom -> unit
(** Pretty print an atom. *)
val d_atom : atom -> unit
(** Dump an atom. *)
val pp_inst : F.formatter -> inst -> unit
(** pretty-print an inst *)
val pp_sexp : Pp.env -> F.formatter -> strexp -> unit
(** Pretty print a strexp. *)
val d_sexp : strexp -> unit
(** Dump a strexp. *)
val pp_hpred : Pp.env -> F.formatter -> hpred -> unit
(** Pretty print a hpred. *)
val d_hpred : hpred -> unit
(** Dump a hpred. *)
val pp_hpara : Pp.env -> F.formatter -> hpara -> unit
(** Pretty print a hpara. *)
val pp_hpara_dll : Pp.env -> F.formatter -> hpara_dll -> unit
(** Pretty print a hpara_dll. *)
(** Module Predicates records the occurrences of predicates as parameters of (doubly -)linked lists
and Epara. Provides unique numbering for predicates and an iterator. *)
module Predicates : sig
(** predicate environment *)
type env
val empty_env : unit -> env
(** create an empty predicate environment *)
val is_empty : env -> bool
(** return true if the environment is empty *)
val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit
(** [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. *)
val process_hpred : env -> hpred -> unit
(** Process one hpred, updating the predicate environment *)
end
val pp_hpred_env : Pp.env -> Predicates.env option -> F.formatter -> hpred -> unit
(** Pretty print a hpred with optional predicate env *)
(** {2 Functions for traversing SIL data types} *)
val strexp_expmap : (Exp.t * inst option -> Exp.t * inst option) -> strexp -> strexp
(** Change exps in strexp using [f]. WARNING: the result might not be normalized. *)
val hpred_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred -> hpred
(** Change exps in hpred by [f]. WARNING: the result might not be normalized. *)
val hpred_instmap : (inst -> inst) -> hpred -> hpred
(** Change instrumentations in hpred using [f]. *)
val hpred_list_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred list -> hpred list
(** Change exps in hpred list by [f]. WARNING: the result might not be normalized. *)
val atom_expmap : (Exp.t -> Exp.t) -> atom -> atom
(** Change exps in atom by [f]. WARNING: the result might not be normalized. *)
val hpred_list_get_lexps : (Exp.t -> bool) -> hpred list -> Exp.t list
val hpred_entries : hpred -> Exp.t list
val atom_free_vars : atom -> Ident.t Sequence.t
val atom_gen_free_vars : atom -> (unit, Ident.t) Sequence.Generator.t
val hpred_free_vars : hpred -> Ident.t Sequence.t
val hpred_gen_free_vars : hpred -> (unit, Ident.t) Sequence.Generator.t
val hpara_shallow_free_vars : hpara -> Ident.t Sequence.t
val hpara_dll_shallow_free_vars : hpara_dll -> Ident.t Sequence.t
(** Variables in hpara_dll, excluding bound vars in the body *)
(** {2 Substitution} *)
type subst = private (Ident.t * Exp.t) list [@@deriving compare]
val equal_subst : subst -> subst -> bool
(** Equality for substitutions. *)
val subst_of_list : (Ident.t * Exp.t) list -> subst
(** Create a substitution from a list of pairs. For all (id1, e1), (id2, e2) in the input list, if
id1 = id2, then e1 = e2. *)
val subst_of_list_duplicates : (Ident.t * Exp.t) list -> subst
(** like subst_of_list, but allow duplicate ids and only keep the first occurrence *)
val sub_to_list : subst -> (Ident.t * Exp.t) list
(** Convert a subst to a list of pairs. *)
val sub_empty : subst
(** The empty substitution. *)
val is_sub_empty : subst -> bool
val sub_join : subst -> subst -> subst
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the
output is this common part. The second and third components are the remainder of [subst1] and
[subst2], respectively. *)
val sub_symmetric_difference : subst -> subst -> subst * subst * subst
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the
output is this common part. The second and third components are the remainder of [subst1] and
[subst2], respectively. *)
val sub_find : (Ident.t -> bool) -> subst -> Exp.t
(** [sub_find filter sub] returns the expression associated to the first identifier that satisfies
[filter]. Raise [Not_found] if there isn't one. *)
val sub_filter : (Ident.t -> bool) -> subst -> subst
(** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *)
val sub_filter_pair : subst -> f:(Ident.t * Exp.t -> bool) -> subst
(** [sub_filter_exp filter sub] restricts the domain of [sub] to the identifiers satisfying
[filter(id, sub(id))]. *)
val sub_range_partition : (Exp.t -> bool) -> subst -> subst * subst
(** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy
[filter]. *)
val sub_domain_partition : (Ident.t -> bool) -> subst -> subst * subst
(** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers
satisfy [filter]. *)
val sub_domain : subst -> Ident.t list
(** Return the list of identifiers in the domain of the substitution. *)
val sub_range : subst -> Exp.t list
(** Return the list of expressions in the range of the substitution. *)
val sub_range_map : (Exp.t -> Exp.t) -> subst -> subst
(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *)
val sub_map : (Ident.t -> Ident.t) -> (Exp.t -> Exp.t) -> subst -> subst
(** [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]. *)
val extend_sub : subst -> Ident.t -> Exp.t -> subst option
(** Extend substitution and return [None] if not possible. *)
val subst_free_vars : subst -> Ident.t Sequence.t
val subst_gen_free_vars : subst -> (unit, Ident.t) Sequence.Generator.t
(** substitution functions WARNING: these functions do not ensure that the results are normalized. *)
val exp_sub : subst -> Exp.t -> Exp.t
val atom_sub : subst -> atom -> atom
val instr_sub : subst -> instr -> instr
(** apply [subst] to all id's in [instr], including LHS id's *)
val hpred_sub : subst -> hpred -> hpred
(** {2 Functions for replacing occurrences of expressions.} *)
val exp_replace_exp : (Exp.t * Exp.t) list -> Exp.t -> Exp.t
val atom_replace_exp : (Exp.t * Exp.t) list -> atom -> atom
val hpred_replace_exp : (Exp.t * Exp.t) list -> hpred -> hpred
(** {2 Functions for constructing or destructing entities in this module} *)
val exp_get_offsets : Exp.t -> offset list
(** Compute the offset list of an expression *)
val exp_add_offsets : Exp.t -> offset list -> Exp.t
(** Add the offset list to an expression *)
val sigma_to_sigma_ne : hpred list -> (atom list * hpred list) list
val hpara_instantiate : hpara -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list
(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], [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\]] for some fresh [_zs'].*)
val hpara_dll_instantiate :
hpara_dll -> Exp.t -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list
(** [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], then the result of the
instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] for some fresh
[_zs'].*)
val custom_error : Pvar.t

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

@ -47,7 +47,7 @@ let is_special_field matcher field_name_opt field =
(** Check whether the hpred is a |-> representing a resource in the Racquire state *)
let hpred_is_open_resource tenv prop = function
| Sil.Hpointsto (e, _, _) -> (
| Predicates.Hpointsto (e, _, _) -> (
match Attribute.get_resource tenv prop e with
| Some (Apred (Aresource {ra_kind= Racquire; ra_res= res}, _)) ->
Some res
@ -214,7 +214,7 @@ and exp_lv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option =
None )
else
let seen = Exp.Set.add e seen_ in
match Prop.exp_normalize_noabs tenv Sil.sub_empty e with
match Prop.exp_normalize_noabs tenv Predicates.sub_empty e with
| Exp.Const c ->
if verbose then (L.d_str "exp_lv_dexp: constant " ; Exp.d_exp e ; L.d_ln ()) ;
Some (DExp.Dderef (DExp.Dconst c))
@ -407,12 +407,13 @@ let explain_allocation_mismatch ra_alloc ra_dealloc =
(** check whether the type of leaked [hpred] appears as a predicate
in an inductive predicate in [prop] *)
let leak_from_list_abstraction hpred prop =
let hpred_type = function
| Sil.Hpointsto (_, _, texp) ->
let hpred_type (hpred : Predicates.hpred) =
match hpred with
| Hpointsto (_, _, texp) ->
Some texp
| Sil.Hlseg (_, {Sil.body= [Sil.Hpointsto (_, _, texp)]}, _, _, _) ->
| Hlseg (_, {body= [Hpointsto (_, _, texp)]}, _, _, _) ->
Some texp
| Sil.Hdllseg (_, {Sil.body_dll= [Sil.Hpointsto (_, _, texp)]}, _, _, _, _, _) ->
| Hdllseg (_, {body_dll= [Hpointsto (_, _, texp)]}, _, _, _, _, _) ->
Some texp
| _ ->
None
@ -421,12 +422,12 @@ let leak_from_list_abstraction hpred prop =
let check_hpred texp hp =
match hpred_type hp with Some texp' when Exp.equal texp texp' -> found := true | _ -> ()
in
let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body in
let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body_dll in
let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Predicates.body in
let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Predicates.body_dll in
match hpred_type hpred with
| Some texp ->
let env = Prop.prop_pred_env prop in
Sil.Predicates.iter env (check_hpara texp) (check_hpara_dll texp) ;
Predicates.Env.iter env (check_hpara texp) (check_hpara_dll texp) ;
if !found then (
L.d_str "leak_from_list_abstraction of predicate of type " ;
Exp.d_texp_full texp ;
@ -437,13 +438,15 @@ let leak_from_list_abstraction hpred prop =
(** find the type of hpred, if any *)
let find_hpred_typ hpred = match hpred with Sil.Hpointsto (_, _, texp) -> Some texp | _ -> None
let find_hpred_typ hpred =
match hpred with Predicates.Hpointsto (_, _, texp) -> Some texp | _ -> None
(** find the type of pvar and remove the pointer, if any *)
let find_typ_without_ptr prop pvar =
let res = ref None in
let do_hpred = function
| Sil.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) ->
| Predicates.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) ->
res := Some te
| _ ->
()
@ -571,7 +574,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
let rec find sigma_acc sigma_todo exp =
let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) =
match se with
| Sil.Eexp (e, _) when Exp.equal exp e -> (
| Predicates.Eexp (e, _) when Exp.equal exp e -> (
let sigma' = List.rev_append sigma_acc' sigma_todo' in
match lexp with
| Exp.Lvar pv ->
@ -604,7 +607,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
in
let do_sexp sigma_acc' sigma_todo' lexp sexp texp =
match sexp with
| Sil.Eexp (e, _) when Exp.equal exp e -> (
| Predicates.Eexp (e, _) when Exp.equal exp e -> (
let sigma' = List.rev_append sigma_acc' sigma_todo' in
match lexp with
| Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) ->
@ -622,7 +625,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
Exp.d_exp lexp ;
L.d_ln () ) ;
(None, None) )
| Sil.Estruct (fsel, _) ->
| Predicates.Estruct (fsel, _) ->
let res = ref (None, None) in
List.iter ~f:(do_fse res sigma_acc' sigma_todo' lexp texp) fsel ;
!res
@ -637,13 +640,13 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
| _ ->
false
in
List.exists ~f:filter (Sil.sub_to_list prop.Prop.sub)
List.exists ~f:filter (Predicates.sub_to_list prop.Prop.sub)
in
function
| Sil.Hpointsto (Exp.Lvar pv, sexp, texp)
| Predicates.Hpointsto (Exp.Lvar pv, sexp, texp)
when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv ->
do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp
| Sil.Hpointsto (Exp.Var id, sexp, texp)
| Predicates.Hpointsto (Exp.Var id, sexp, texp)
when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) ->
do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp
| _ ->
@ -673,17 +676,18 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
let access_opt ?(is_nullable = false) inst =
match inst with
| Sil.Iupdate (_, ncf, n, _) ->
match (inst : Predicates.inst) with
| Iupdate (_, ncf, n, _) ->
Some (Localise.Last_assigned (n, ncf))
| Sil.Irearrange (_, _, n, _) ->
| Irearrange (_, _, n, _) ->
Some (Localise.Last_accessed (n, is_nullable))
| Sil.Ireturn_from_call n ->
| Ireturn_from_call n ->
Some (Localise.Returned_from_call n)
| Sil.Ialloc when Language.curr_language_is Java ->
| Ialloc when Language.curr_language_is Java ->
Some Localise.Initialized_automatically
| inst ->
if verbose then L.d_printfln "explain_dexp_access: inst is not an update %a" Sil.pp_inst inst ;
if verbose then
L.d_printfln "explain_dexp_access: inst is not an update %a" Predicates.pp_inst inst ;
None
@ -693,19 +697,19 @@ let explain_dexp_access prop dexp is_nullable =
let sexpo_to_inst = function
| None ->
None
| Some (Sil.Eexp (_, inst)) ->
| Some (Predicates.Eexp (_, inst)) ->
Some inst
| Some se ->
if verbose then (
L.d_str "sexpo_to_inst: can't find inst " ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_ln () ) ;
None
in
let find_ptsto (e : Exp.t) : Sil.strexp option =
let find_ptsto (e : Exp.t) : Predicates.strexp option =
let res = ref None in
let do_hpred = function
| Sil.Hpointsto (e', se, _) when Exp.equal e e' ->
| Predicates.Hpointsto (e', se, _) when Exp.equal e e' ->
res := Some se
| _ ->
()
@ -731,28 +735,28 @@ let explain_dexp_access prop dexp is_nullable =
| (e1, se) :: esel' ->
if Exp.equal e1 e then Some se else lookup_esel esel' e
in
let rec lookup : DExp.t -> Sil.strexp option = function
let rec lookup : DExp.t -> Predicates.strexp option = function
| DExp.Dconst c ->
Some (Sil.Eexp (Exp.Const c, Sil.inst_none))
Some (Predicates.Eexp (Exp.Const c, Predicates.inst_none))
| DExp.Darray (de1, de2) -> (
match (lookup de1, lookup de2) with
| None, _ | _, None ->
None
| Some (Sil.Earray (_, esel, _)), Some (Sil.Eexp (e, _)) ->
| Some (Predicates.Earray (_, esel, _)), Some (Predicates.Eexp (e, _)) ->
lookup_esel esel e
| Some se1, Some se2 ->
if verbose then (
L.d_str "lookup: case not matched on Darray " ;
Sil.d_sexp se1 ;
Predicates.d_sexp se1 ;
L.d_str " " ;
Sil.d_sexp se2 ;
Predicates.d_sexp se2 ;
L.d_ln () ) ;
None )
| DExp.Darrow (DExp.Dpvaraddr pvar, f) -> (
match lookup (DExp.Dpvaraddr pvar) with
| None ->
None
| Some (Sil.Estruct (fsel, _)) ->
| Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f
| Some _ ->
if verbose then L.d_strln "lookup: case not matched on Darrow" ;
@ -761,7 +765,7 @@ let explain_dexp_access prop dexp is_nullable =
match lookup (DExp.Dderef de1) with
| None ->
None
| Some (Sil.Estruct (fsel, _)) ->
| Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f
| Some _ ->
if verbose then L.d_strln "lookup: case not matched on Darrow" ;
@ -770,9 +774,9 @@ let explain_dexp_access prop dexp is_nullable =
match lookup de1 with
| None ->
None
| Some (Sil.Estruct (fsel, _)) ->
| Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f
| Some (Sil.Eexp (Const (Cfun _), _) as fun_strexp) ->
| Some (Predicates.Eexp (Const (Cfun _), _) as fun_strexp) ->
Some fun_strexp
| Some _ ->
if verbose then L.d_strln "lookup: case not matched on Ddot" ;
@ -781,7 +785,13 @@ let explain_dexp_access prop dexp is_nullable =
if verbose then L.d_strln "lookup: found Dpvar" ;
find_ptsto (Exp.Lvar pvar)
| DExp.Dderef de -> (
match lookup de with None -> None | Some (Sil.Eexp (e, _)) -> find_ptsto e | Some _ -> None )
match lookup de with
| None ->
None
| Some (Predicates.Eexp (e, _)) ->
find_ptsto e
| Some _ ->
None )
| DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de ->
if verbose then L.d_printfln "lookup: case )pvar + constant) %a" DExp.pp de ;
None
@ -790,7 +800,7 @@ let explain_dexp_access prop dexp is_nullable =
match c with
| Const.Cfun _ ->
(* Treat function as an update *)
Some (Sil.Eexp (Exp.Const c, Sil.Ireturn_from_call loc.Location.line))
Some (Predicates.Eexp (Exp.Const c, Predicates.Ireturn_from_call loc.Location.line))
| _ ->
None )
| DExp.Dpvaraddr pvar ->
@ -1051,21 +1061,21 @@ let find_with_exp prop exp =
if is_none !res then res := Some (pv, Fstruct (List.rev fld_lst))
in
let rec search_struct pv fld_lst = function
| Sil.Eexp (e, _) ->
| Predicates.Eexp (e, _) ->
if Exp.equal e exp then found_in_struct pv fld_lst
| Sil.Estruct (fsel, _) ->
| Predicates.Estruct (fsel, _) ->
List.iter ~f:(fun (f, se) -> search_struct pv (f :: fld_lst) se) fsel
| _ ->
()
in
let do_hpred_pointed_by_pvar pv e = function
| Sil.Hpointsto (e1, se, _) ->
| Predicates.Hpointsto (e1, se, _) ->
if Exp.equal e e1 then search_struct pv [] se
| _ ->
()
in
let do_hpred = function
| Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) ->
| Predicates.Hpointsto (Lvar pv, Eexp (e, _), _) ->
if Exp.equal e exp then found_in_pvar pv
else List.iter ~f:(do_hpred_pointed_by_pvar pv e) prop.Prop.sigma
| _ ->

6
infer/src/backend/errdesc.mli
Unescape View File

@ -14,7 +14,7 @@ val vpath_find : Tenv.t -> 'a Prop.t -> Exp.t -> DecompiledExp.vpath * Typ.t opt
(** find the dexp, if any, where the given value is stored also return the type of the value if
found *)
val hpred_is_open_resource : Tenv.t -> 'a Prop.t -> Sil.hpred -> PredSymb.resource option
val hpred_is_open_resource : Tenv.t -> 'a Prop.t -> Predicates.hpred -> PredSymb.resource option
(** Check whether the hpred is a |-> representing a resource in the Racquire state *)
val find_normal_variable_funcall :
@ -107,7 +107,7 @@ val explain_unary_minus_applied_to_unsigned_expression :
val explain_leak :
Tenv.t
-> Sil.hpred
-> Predicates.hpred
-> 'a Prop.t
-> PredSymb.t option
-> string option
@ -125,4 +125,4 @@ val warning_err : Location.t -> ('a, Format.formatter, unit) format -> 'a
val find_outermost_dereference : Tenv.t -> Procdesc.Node.t -> Exp.t -> DecompiledExp.t option
val access_opt : ?is_nullable:bool -> Sil.inst -> Localise.access option
val access_opt : ?is_nullable:bool -> Predicates.inst -> Localise.access option

265
infer/src/biabduction/Abs.ml
Unescape View File

@ -19,9 +19,9 @@ type rule =
; r_root: Match.hpred_pat
; r_sigma: Match.hpred_pat list
; (* sigma should be in a specific order *)
r_new_sigma: Sil.hpred list
; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Sil.subst -> Sil.atom list
; r_condition: Prop.normal Prop.t -> Sil.subst -> bool }
r_new_sigma: Predicates.hpred list
; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Predicates.subst -> Predicates.atom list
; r_condition: Prop.normal Prop.t -> Predicates.subst -> bool }
let sigma_rewrite tenv p r : Prop.normal Prop.t option =
match Match.prop_match_with_impl tenv p r.r_condition r.r_vars r.r_root r.r_sigma with
@ -43,7 +43,7 @@ let create_fresh_primeds_ls para =
let id_next = Ident.create_fresh Ident.kprimed in
let id_end = Ident.create_fresh Ident.kprimed in
let ids_shared =
let svars = para.Sil.svars in
let svars = para.Predicates.svars in
let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars
in
@ -56,15 +56,16 @@ let create_fresh_primeds_ls para =
(ids_tuple, exps_tuple)
let create_condition_ls ids_private id_base p_leftover (inst : Sil.subst) =
let create_condition_ls ids_private id_base p_leftover (inst : Predicates.subst) =
let insts_of_private_ids, insts_of_public_ids, inst_of_base =
let f id' = List.exists ~f:(fun id'' -> Ident.equal id' id'') ids_private in
let inst_private, inst_public = Sil.sub_domain_partition f inst in
let insts_of_public_ids = Sil.sub_range inst_public in
let inst_private, inst_public = Predicates.sub_domain_partition f inst in
let insts_of_public_ids = Predicates.sub_range inst_public in
let inst_of_base =
try Sil.sub_find (Ident.equal id_base) inst_public with Caml.Not_found -> assert false
try Predicates.sub_find (Ident.equal id_base) inst_public
with Caml.Not_found -> assert false
in
let insts_of_private_ids = Sil.sub_range inst_private in
let insts_of_private_ids = Predicates.sub_range inst_private in
(insts_of_private_ids, insts_of_public_ids, inst_of_base)
in
(*
@ -94,16 +95,16 @@ let create_condition_ls ids_private id_base p_leftover (inst : Sil.subst) =
Exp.free_vars e |> Fn.non intersects_fav_insts_of_private_ids )
let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) =
let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Predicates.hpara) =
let ids_tuple, exps_tuple = create_fresh_primeds_ls para in
let id_base, id_next, id_end, ids_shared = ids_tuple in
let exp_base, exp_next, exp_end, exps_shared = exps_tuple in
let ids_exist_fst, para_fst = Sil.hpara_instantiate para exp_base exp_next exps_shared in
let ids_exist_fst, para_fst = Predicates.hpara_instantiate para exp_base exp_next exps_shared in
let para_fst_start, para_fst_rest =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in
match para_fst with
| [] ->
L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ;
L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Predicates.pp_hpara Pp.text) para ;
assert false
| hpred :: hpreds ->
let hpat = mark_impl_flag hpred in
@ -112,12 +113,12 @@ let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) =
in
let ids_exist_snd, para_snd =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in
let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let ids, para_body = Predicates.hpara_instantiate para exp_next exp_end exps_shared in
let para_body_hpats = List.map ~f:mark_impl_flag para_body in
(ids, para_body_hpats)
in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in
create_condition_ls ids_private id_base
@ -134,11 +135,11 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para =
let ids_tuple, exps_tuple = create_fresh_primeds_ls para in
let id_base, id_next, id_end, ids_shared = ids_tuple in
let exp_base, exp_next, exp_end, exps_shared = exps_tuple in
let ids_exist, para_inst = Sil.hpara_instantiate para exp_base exp_next exps_shared in
let ids_exist, para_inst = Predicates.hpara_instantiate para exp_base exp_next exps_shared in
let para_inst_start, para_inst_rest =
match para_inst with
| [] ->
L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ;
L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Predicates.pp_hpara Pp.text) para ;
assert false
| hpred :: hpreds ->
let allow_impl hpred = {Match.hpred; Match.flag= impl_ok1} in
@ -147,8 +148,8 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para =
let lseg_pat =
{Match.hpred= Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag= impl_ok2}
in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base
@ -169,13 +170,13 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para =
{Match.hpred= Prop.mk_lseg tenv k1 para exp_base exp_next exps_shared; Match.flag= impl_ok1}
in
let ids_exist, para_inst_pat =
let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let ids, para_body = Predicates.hpara_instantiate para exp_next exp_end exps_shared in
let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in
let para_body_pat = List.map ~f:allow_impl para_body in
(ids, para_body_pat)
in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base
@ -188,12 +189,12 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para =
; r_condition= condition }
let lseg_kind_add k1 k2 =
let lseg_kind_add (k1 : Predicates.lseg_kind) (k2 : Predicates.lseg_kind) : Predicates.lseg_kind =
match (k1, k2) with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE ->
Sil.Lseg_NE
| Sil.Lseg_PE, Sil.Lseg_PE ->
Sil.Lseg_PE
| Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_NE ->
Lseg_NE
| Lseg_PE, Lseg_PE ->
Lseg_PE
let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para =
@ -208,7 +209,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para =
in
let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_lseg tenv k_res para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) =
let gen_pi_res _ _ (_ : Predicates.subst) =
[]
(*
let inst_base, inst_next, inst_end =
@ -217,7 +218,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para =
(find id_base, find id_next, find id_end)
with Not_found -> assert false in
let spooky_case _ =
(equal_lseg_kind Sil.Lseg_PE k_res)
(equal_lseg_kind Lseg_PE k_res)
&& (check_allocatedness p_leftover inst_end)
&& ((check_disequal p_start inst_base inst_next)
|| (check_disequal p_start inst_next inst_end)) in
@ -240,20 +241,20 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para =
; r_condition= condition }
let mk_rules_for_sll tenv (para : Sil.hpara) : rule list =
let mk_rules_for_sll tenv (para : Predicates.hpara) : rule list =
if not Config.nelseg then
let pts_pts = mk_rule_ptspts_ls tenv true true para in
let pts_pels = mk_rule_ptsls_ls tenv Sil.Lseg_PE true false para in
let pels_pts = mk_rule_lspts_ls tenv Sil.Lseg_PE false true para in
let pels_nels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_NE false false para in
let nels_pels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_PE false false para in
let pels_pels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_PE false false para in
let pts_pels = mk_rule_ptsls_ls tenv Lseg_PE true false para in
let pels_pts = mk_rule_lspts_ls tenv Lseg_PE false true para in
let pels_nels = mk_rule_lsls_ls tenv Lseg_PE Lseg_NE false false para in
let nels_pels = mk_rule_lsls_ls tenv Lseg_NE Lseg_PE false false para in
let pels_pels = mk_rule_lsls_ls tenv Lseg_PE Lseg_PE false false para in
[pts_pts; pts_pels; pels_pts; pels_nels; nels_pels; pels_pels]
else
let pts_pts = mk_rule_ptspts_ls tenv true true para in
let pts_nels = mk_rule_ptsls_ls tenv Sil.Lseg_NE true false para in
let nels_pts = mk_rule_lspts_ls tenv Sil.Lseg_NE false true para in
let nels_nels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_NE false false para in
let pts_nels = mk_rule_ptsls_ls tenv Lseg_NE true false para in
let nels_pts = mk_rule_lspts_ls tenv Lseg_NE false true para in
let nels_nels = mk_rule_lsls_ls tenv Lseg_NE Lseg_NE false false para in
[pts_pts; pts_nels; nels_pts; nels_nels]
@ -267,7 +268,7 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para =
let id_oB = Ident.create_fresh Ident.kprimed in
let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared =
let svars = para.Sil.svars_dll in
let svars = para.Predicates.svars_dll in
let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars
in
@ -276,12 +277,15 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para =
let exp_oB = Exp.Var id_oB in
let exp_oF = Exp.Var id_oF in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in
let ids_exist_fst, para_fst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in
let ids_exist_fst, para_fst =
Predicates.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared
in
let para_fst_start, para_fst_rest =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in
match para_fst with
| [] ->
L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Sil.pp_hpara_dll Pp.text) para ;
L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Predicates.pp_hpara_dll Pp.text)
para ;
assert false
| hpred :: hpreds ->
let hpat = mark_impl_flag hpred in
@ -290,12 +294,12 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para =
in
let ids_exist_snd, para_snd =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in
let ids, para_body = Sil.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in
let ids, para_body = Predicates.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in
let para_body_hpats = List.map ~f:mark_impl_flag para_body in
(ids, para_body_hpats)
in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
(* for the case of ptspts since iF'=iB therefore iF' cannot be private*)
let ids_private = ids_exist_fst @ ids_exist_snd in
@ -322,7 +326,7 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para =
let id_oF = Ident.create_fresh Ident.kprimed in
let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared =
let svars = para.Sil.svars_dll in
let svars = para.Predicates.svars_dll in
let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars
in
@ -332,7 +336,9 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para =
let exp_oF = Exp.Var id_oF in
let exp_iB = Exp.Var id_iB in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in
let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in
let ids_exist, para_inst =
Predicates.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared
in
let para_inst_start, para_inst_rest =
match para_inst with
| [] ->
@ -345,8 +351,8 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para =
{ Match.hpred= Prop.mk_dllseg tenv k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared
; Match.flag= impl_ok2 }
in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = id_iF' :: ids_exist in
create_condition_dll ids_private id_iF
@ -366,7 +372,7 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para =
let id_oB' = Ident.create_fresh Ident.kprimed in
let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared =
let svars = para.Sil.svars_dll in
let svars = para.Predicates.svars_dll in
let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars
in
@ -376,7 +382,9 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para =
let exp_oB' = Exp.Var id_oB' in
let exp_oF = Exp.Var id_oF in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in
let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared in
let ids_exist, para_inst =
Predicates.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared
in
let para_inst_pat =
let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in
List.map ~f:allow_impl para_inst
@ -385,8 +393,8 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para =
{ Match.hpred= Prop.mk_dllseg tenv k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared
; Match.flag= impl_ok1 }
in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = id_oB' :: ids_exist in
create_condition_dll ids_private id_iF
@ -407,7 +415,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para =
let id_oF = Ident.create_fresh Ident.kprimed in
let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared =
let svars = para.Sil.svars_dll in
let svars = para.Predicates.svars_dll in
let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars
in
@ -428,7 +436,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para =
in
let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_dllseg tenv k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in
let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition =
let ids_private = [id_iF'; id_oB'] in
create_condition_dll ids_private id_iF
@ -441,20 +449,20 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para =
; r_condition= condition }
let mk_rules_for_dll tenv (para : Sil.hpara_dll) : rule list =
let mk_rules_for_dll tenv (para : Predicates.hpara_dll) : rule list =
if not Config.nelseg then
let pts_pts = mk_rule_ptspts_dll tenv true true para in
let pts_pedll = mk_rule_ptsdll_dll tenv Sil.Lseg_PE true false para in
let pedll_pts = mk_rule_dllpts_dll tenv Sil.Lseg_PE false true para in
let pedll_nedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_NE false false para in
let nedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_PE false false para in
let pedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_PE false false para in
let pts_pedll = mk_rule_ptsdll_dll tenv Lseg_PE true false para in
let pedll_pts = mk_rule_dllpts_dll tenv Lseg_PE false true para in
let pedll_nedll = mk_rule_dlldll_dll tenv Lseg_PE Lseg_NE false false para in
let nedll_pedll = mk_rule_dlldll_dll tenv Lseg_NE Lseg_PE false false para in
let pedll_pedll = mk_rule_dlldll_dll tenv Lseg_PE Lseg_PE false false para in
[pts_pts; pts_pedll; pedll_pts; pedll_nedll; nedll_pedll; pedll_pedll]
else
let ptspts_dll = mk_rule_ptspts_dll tenv true true para in
let ptsdll_dll = mk_rule_ptsdll_dll tenv Sil.Lseg_NE true false para in
let dllpts_dll = mk_rule_dllpts_dll tenv Sil.Lseg_NE false true para in
let dlldll_dll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_NE false false para in
let ptsdll_dll = mk_rule_ptsdll_dll tenv Lseg_NE true false para in
let dllpts_dll = mk_rule_dllpts_dll tenv Lseg_NE false true para in
let dlldll_dll = mk_rule_dlldll_dll tenv Lseg_NE Lseg_NE false false para in
[ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll]
@ -493,7 +501,7 @@ let typ_get_recursive_flds tenv typ_exp =
assert false
let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option =
let discover_para_roots tenv p root1 next1 root2 next2 : Predicates.hpara option =
let eq_arg1 = Exp.equal root1 next1 in
let eq_arg2 = Exp.equal root2 next2 in
let precondition_check = (not eq_arg1) && not eq_arg2 in
@ -510,7 +518,8 @@ let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option =
Some hpara
let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpara_dll option =
let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 :
Predicates.hpara_dll option =
let eq_arg1 = Exp.equal root1 blink1 in
let eq_arg1' = Exp.equal root1 flink1 in
let eq_arg2 = Exp.equal root2 blink2 in
@ -535,21 +544,21 @@ let discover_para_candidates tenv p =
let get_edges_strexp rec_flds root se =
let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in
match se with
| Sil.Eexp _ | Sil.Earray _ ->
| Predicates.Eexp _ | Predicates.Earray _ ->
()
| Sil.Estruct (fsel, _) ->
| Predicates.Estruct (fsel, _) ->
let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let process (_, nextse) =
match nextse with Sil.Eexp (next, _) -> add_edge (root, next) | _ -> assert false
match nextse with Predicates.Eexp (next, _) -> add_edge (root, next) | _ -> assert false
in
List.iter ~f:process fsel'
in
let rec get_edges_sigma = function
| [] ->
()
| Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest ->
| Predicates.Hlseg _ :: sigma_rest | Predicates.Hdllseg _ :: sigma_rest ->
get_edges_sigma sigma_rest
| Sil.Hpointsto (root, se, te) :: sigma_rest ->
| Predicates.Hpointsto (root, se, te) :: sigma_rest ->
let rec_flds = typ_get_recursive_flds tenv te in
get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest
in
@ -577,12 +586,12 @@ let discover_para_dll_candidates tenv p =
let get_edges_strexp rec_flds root se =
let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in
match se with
| Sil.Eexp _ | Sil.Earray _ ->
| Predicates.Eexp _ | Predicates.Earray _ ->
()
| Sil.Estruct (fsel, _) ->
| Predicates.Estruct (fsel, _) ->
let fsel' = List.rev_filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let convert_to_exp acc (_, se) =
match se with Sil.Eexp (e, _) -> e :: acc | _ -> assert false
match se with Predicates.Eexp (e, _) -> e :: acc | _ -> assert false
in
let links = List.fold ~f:convert_to_exp ~init:[] fsel' in
let rec iter_pairs = function
@ -597,9 +606,9 @@ let discover_para_dll_candidates tenv p =
let rec get_edges_sigma = function
| [] ->
()
| Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest ->
| Predicates.Hlseg _ :: sigma_rest | Predicates.Hdllseg _ :: sigma_rest ->
get_edges_sigma sigma_rest
| Sil.Hpointsto (root, se, te) :: sigma_rest ->
| Predicates.Hpointsto (root, se, te) :: sigma_rest ->
let rec_flds = typ_get_recursive_flds tenv te in
get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest
in
@ -659,7 +668,7 @@ let discover_para_dll tenv p =
(****************** Start of the ADT abs_rules ******************)
(** Type of parameter for abstraction rules *)
type para_ty = SLL of Sil.hpara | DLL of Sil.hpara_dll
type para_ty = SLL of Predicates.hpara | DLL of Predicates.hpara_dll
(** Rule set: a list of rules of a given type *)
type rule_set = para_ty * rule list
@ -677,16 +686,16 @@ let set_current_rules rules = Global.current_rules := rules
let reset_current_rules () = Global.current_rules := []
let eqs_sub subst eqs =
List.map ~f:(fun (e1, e2) -> (Sil.exp_sub subst e1, Sil.exp_sub subst e2)) eqs
List.map ~f:(fun (e1, e2) -> (Predicates.exp_sub subst e1, Predicates.exp_sub subst e2)) eqs
let eqs_solve ids_in eqs_in =
let rec solve (sub : Sil.subst) (eqs : (Exp.t * Exp.t) list) : Sil.subst option =
let rec solve (sub : Predicates.subst) (eqs : (Exp.t * Exp.t) list) : Predicates.subst option =
let do_default id e eqs_rest =
if not (List.exists ~f:(fun id' -> Ident.equal id id') ids_in) then None
else
let sub' =
match Sil.extend_sub sub id e with
match Predicates.extend_sub sub id e with
| None ->
L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ;
assert false
@ -714,32 +723,36 @@ let eqs_solve ids_in eqs_in =
None
in
let compute_ids sub =
let sub_list = Sil.sub_to_list sub in
let sub_list = Predicates.sub_to_list sub in
let sub_dom = List.map ~f:fst sub_list in
let filter id = not (List.exists ~f:(fun id' -> Ident.equal id id') sub_dom) in
List.filter ~f:filter ids_in
in
match solve Sil.sub_empty eqs_in with None -> None | Some sub -> Some (compute_ids sub, sub)
match solve Predicates.sub_empty eqs_in with
| None ->
None
| Some sub ->
Some (compute_ids sub, sub)
let sigma_special_cases_eqs sigma =
let rec f ids_acc eqs_acc sigma_acc = function
| [] ->
[(List.rev ids_acc, List.rev eqs_acc, List.rev sigma_acc)]
| (Sil.Hpointsto _ as hpred) :: sigma_rest ->
| (Predicates.Hpointsto _ as hpred) :: sigma_rest ->
f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest
| (Sil.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest ->
| (Predicates.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest ->
let empty_case = f ids_acc ((e1, e2) :: eqs_acc) sigma_acc sigma_rest in
let pointsto_case =
let eids, para_inst = Sil.hpara_instantiate para e1 e2 es in
let eids, para_inst = Predicates.hpara_instantiate para e1 e2 es in
f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest)
in
let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in
empty_case @ pointsto_case @ general_case
| (Sil.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest ->
| (Predicates.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest ->
let empty_case = f ids_acc ((e1, e3) :: (e2, e4) :: eqs_acc) sigma_acc sigma_rest in
let pointsto_case =
let eids, para_inst = Sil.hpara_dll_instantiate para e1 e2 e3 es in
let eids, para_inst = Predicates.hpara_dll_instantiate para e1 e2 e3 es in
f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest)
in
let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in
@ -748,7 +761,7 @@ let sigma_special_cases_eqs sigma =
f [] [] [] sigma
let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list =
let sigma_special_cases ids sigma : (Ident.t list * Predicates.hpred list) list =
let special_cases_eqs = sigma_special_cases_eqs sigma in
let special_cases_rev =
let f acc (eids_cur, eqs_cur, sigma_cur) =
@ -757,22 +770,24 @@ let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list =
| None ->
acc
| Some (ids_res, sub) ->
(ids_res, List.map ~f:(Sil.hpred_sub sub) sigma_cur) :: acc
(ids_res, List.map ~f:(Predicates.hpred_sub sub) sigma_cur) :: acc
in
List.fold ~f ~init:[] special_cases_eqs
in
List.rev special_cases_rev
let hpara_special_cases hpara : Sil.hpara list =
let update_para (evars', body') = {hpara with Sil.evars= evars'; Sil.body= body'} in
let special_cases = sigma_special_cases hpara.Sil.evars hpara.Sil.body in
let hpara_special_cases hpara : Predicates.hpara list =
let update_para (evars', body') = {hpara with Predicates.evars= evars'; Predicates.body= body'} in
let special_cases = sigma_special_cases hpara.Predicates.evars hpara.Predicates.body in
List.map ~f:update_para special_cases
let hpara_special_cases_dll hpara : Sil.hpara_dll list =
let update_para (evars', body') = {hpara with Sil.evars_dll= evars'; Sil.body_dll= body'} in
let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in
let hpara_special_cases_dll hpara : Predicates.hpara_dll list =
let update_para (evars', body') =
{hpara with Predicates.evars_dll= evars'; Predicates.body_dll= body'}
in
let special_cases = sigma_special_cases hpara.Predicates.evars_dll hpara.Predicates.body_dll in
List.map ~f:update_para special_cases
@ -861,7 +876,7 @@ let abstract_pure_part tenv p ~(from_abstract_footprint : bool) =
let fav_nonpure = Prop.non_pure_free_vars p |> Ident.set_of_sequence in
(* vars in current and footprint sigma *)
let filter atom =
Sil.atom_free_vars atom
Predicates.atom_free_vars atom
|> Sequence.for_all ~f:(fun id ->
if Ident.is_primed id then Ident.Set.mem id fav_sigma
else if Ident.is_footprint id then Ident.Set.mem id fav_nonpure
@ -872,26 +887,26 @@ let abstract_pure_part tenv p ~(from_abstract_footprint : bool) =
let new_pure =
List.fold
~f:(fun pi a ->
match a with
match (a : Predicates.atom) with
(* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *)
| Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Lt, _, _))
| Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const (Const.Cint i))
| Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, _, _))
| Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const (Const.Cint i))
| Aeq (Const (Cint i), BinOp (Lt, _, _))
| Aeq (BinOp (Lt, _, _), Const (Cint i))
| Aeq (Const (Cint i), BinOp (Le, _, _))
| Aeq (BinOp (Le, _, _), Const (Cint i))
when IntLit.isone i ->
a :: pi
| Sil.Aeq (Exp.Var name, e) when not (Ident.is_primed name) -> (
match e with Exp.Var _ | Exp.Const _ -> a :: pi | _ -> pi )
| Sil.Aneq (Var _, _) | Sil.Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) ->
| Aeq (Var name, e) when not (Ident.is_primed name) -> (
match e with Var _ | Const _ -> a :: pi | _ -> pi )
| Aneq (Var _, _) | Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) ->
a :: pi
| Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ ->
| Aeq _ | Aneq _ | Apred _ | Anpred _ ->
pi )
~init:[] pi_filtered
in
List.rev new_pure
in
let new_pure = do_pure (Prop.get_pure p) in
let eprop' = Prop.set p ~pi:new_pure ~sub:Sil.sub_empty in
let eprop' = Prop.set p ~pi:new_pure ~sub:Predicates.sub_empty in
let eprop'' =
if !BiabductionConfig.footprint && not from_abstract_footprint then
let new_pi_footprint = do_pure p.Prop.pi_fp in
@ -915,10 +930,10 @@ let abstract_gc tenv p =
Sequence.exists fav_seq ~f:(fun id -> Ident.Set.mem id fav_p_without_pi)
in
let strong_filter = function
| Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) ->
| Predicates.Aeq (e1, e2) | Predicates.Aneq (e1, e2) ->
check (Exp.free_vars e1) && check (Exp.free_vars e2)
| (Sil.Apred _ | Anpred _) as a ->
check (Sil.atom_free_vars a)
| (Predicates.Apred _ | Anpred _) as a ->
check (Predicates.atom_free_vars a)
in
let new_pi = List.filter ~f:strong_filter pi in
let prop = Prop.normalize tenv (Prop.set p ~pi:new_pi) in
@ -934,9 +949,9 @@ let sigma_reachable root_fav sigma =
let reach_set = ref root_fav in
let edges = ref [] in
let do_hpred hpred =
let hp_fav_set = Sil.hpred_free_vars hpred |> Ident.set_of_sequence in
let hp_fav_set = Predicates.hpred_free_vars hpred |> Ident.set_of_sequence in
let add_entry e = edges := (e, hp_fav_set) :: !edges in
List.iter ~f:add_entry (Sil.hpred_entries hpred)
List.iter ~f:add_entry (Predicates.hpred_entries hpred)
in
List.iter ~f:do_hpred sigma ;
let edge_fires (e, _) =
@ -962,7 +977,7 @@ let sigma_reachable root_fav sigma =
in
find_fixpoint !edges ;
(* L.d_str "reachable: ";
Ident.Set.iter (fun id -> Sil.d_exp (Exp.Var id); L.d_str " ") !reach_set;
Ident.Set.iter (fun id -> Predicates.d_exp (Exp.Var id); L.d_str " ") !reach_set;
L.d_ln (); *)
!reach_set
@ -1015,7 +1030,7 @@ let check_junk pname tenv prop =
| [] ->
List.rev sigma_done
| hpred :: sigma_todo' ->
let entries = Sil.hpred_entries hpred in
let entries = Predicates.hpred_entries hpred in
if should_remove_hpred entries then (
let part = if fp_part then "footprint" else "normal" in
L.d_printfln ".... Prop with garbage in %s part ...." part ;
@ -1139,7 +1154,7 @@ let check_junk pname tenv prop =
else remove_junk fp_part fav_root sigma'
in
let sigma_new =
let fav_sub = Sil.subst_free_vars prop.Prop.sub |> Ident.set_of_sequence in
let fav_sub = Predicates.subst_free_vars prop.Prop.sub |> Ident.set_of_sequence in
let fav_sub_sigmafp =
Prop.sigma_free_vars prop.Prop.sigma_fp |> Ident.set_of_sequence ~init:fav_sub
in
@ -1164,9 +1179,9 @@ let remove_pure_garbage tenv ?(count = fun _ -> 0) prop =
let changed = ref false in
let rec go prop =
let propcount = prop |> Prop.free_vars |> Ident.counts_of_sequence in
let prop = Prop.set prop ~pi:(Prop.get_pure prop) ~sub:Sil.sub_empty in
let prop = Prop.set prop ~pi:(Prop.get_pure prop) ~sub:Predicates.sub_empty in
let drop id = Int.equal 1 (count id + propcount id) in
let keep atom = not (Sequence.exists ~f:drop (Sil.atom_free_vars atom)) in
let keep atom = not (Sequence.exists ~f:drop (Predicates.atom_free_vars atom)) in
let pi = List.filter ~f:keep prop.Prop.pi in
let dropped = List.length pi < List.length prop.Prop.pi in
changed := !changed || dropped ;
@ -1209,9 +1224,9 @@ let abstract_spec pname tenv spec =
a disequality. As a workaround, here we drop pure facts from the consequent that are known to
be true. *)
let module AtomSet = Caml.Set.Make (struct
type t = Sil.atom
type t = Predicates.atom
let compare = Sil.compare_atom
let compare = Predicates.compare_atom
end) in
let pre_pure =
let pre = Jprop.to_prop spec.pre in
@ -1272,21 +1287,21 @@ let abstract_prop pname tenv ~(rename_primed : bool) ~(from_abstract_footprint :
let get_local_stack cur_sigma init_sigma =
let filter_stack = function
| Sil.Hpointsto (Exp.Lvar _, _, _) ->
| Predicates.Hpointsto (Exp.Lvar _, _, _) ->
true
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ ->
| Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
false
in
let get_stack_var = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
pvar
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ ->
| Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
assert false
in
let filter_local_stack olds = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
not (List.exists ~f:(Pvar.equal pvar) olds)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ ->
| Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
false
in
let init_stack = List.filter ~f:filter_stack init_sigma in
@ -1309,9 +1324,9 @@ let extract_footprint_for_abs (p : 'a Prop.t) : Prop.exposed Prop.t * Pvar.t lis
let remove_local_stack sigma pvars =
let filter_non_stack = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
not (List.exists ~f:(Pvar.equal pvar) pvars)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ ->
| Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
true
in
List.filter ~f:filter_non_stack sigma

99
infer/src/biabduction/Absarray.ml
Unescape View File

@ -29,7 +29,7 @@ let array_clean_new_index footprint_part new_idx =
(** Abstraction for Arrays *)
type sigma = Sil.hpred list
type sigma = Predicates.hpred list
(** Matcher for the sigma part specialized to strexps *)
module StrexpMatch : sig
@ -39,11 +39,11 @@ module StrexpMatch : sig
val path_to_exps : path -> Exp.t list
(** convert a path into a list of expressions *)
val path_from_exp_offsets : Exp.t -> Sil.offset list -> path
val path_from_exp_offsets : Exp.t -> Predicates.offset list -> path
(** create a path from a root and a list of offsets *)
(** path to the root, length, elements and type of a new_array *)
type strexp_data = path * Sil.strexp * Typ.t
type strexp_data = path * Predicates.strexp * Typ.t
(** sigma with info about a current array *)
type t
@ -57,7 +57,7 @@ module StrexpMatch : sig
val get_data : Tenv.t -> t -> strexp_data
(** Get the array *)
val replace_strexp : Tenv.t -> bool -> t -> Sil.strexp -> sigma
val replace_strexp : Tenv.t -> bool -> t -> Predicates.strexp -> sigma
(** Replace the strexp at a given position by a new strexp *)
val replace_index : Tenv.t -> bool -> t -> Exp.t -> Exp.t -> sigma
@ -74,7 +74,7 @@ end = struct
let fail () =
L.d_strln "Failure of get_strexp_at_syn_offsets" ;
L.d_str "se: " ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_ln () ;
L.d_str "t: " ;
Typ.d_full t ;
@ -84,7 +84,7 @@ end = struct
match (se, t.desc, syn_offs) with
| _, _, [] ->
(se, t)
| Sil.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> (
| Predicates.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
@ -92,7 +92,7 @@ end = struct
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| None ->
fail () )
| Sil.Earray (_, esel, _), Typ.Tarray {elt= t'}, Index ind :: syn_offs' ->
| Predicates.Earray (_, esel, _), Typ.Tarray {elt= t'}, Index ind :: syn_offs' ->
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| _ ->
@ -104,7 +104,7 @@ end = struct
match (se, t.desc, syn_offs) with
| _, _, [] ->
update se
| Sil.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> (
| Predicates.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in
@ -119,16 +119,16 @@ end = struct
if Typ.Fieldname.equal f'' fld then (fld, se_mod) else (f'', se'') )
fsel
in
Sil.Estruct (fsel', inst)
Predicates.Estruct (fsel', inst)
| None ->
assert false )
| Sil.Earray (len, esel, inst), Tarray {elt= t'}, Index idx :: syn_offs' ->
| Predicates.Earray (len, esel, inst), Tarray {elt= t'}, Index idx :: syn_offs' ->
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let esel' =
List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel
in
Sil.Earray (len, esel', inst)
Predicates.Earray (len, esel', inst)
| _ ->
assert false
@ -151,9 +151,9 @@ end = struct
(** create a path from a root and a list of offsets *)
let path_from_exp_offsets root offs =
let offset_to_syn_offset = function
| Sil.Off_fld (fld, typ) ->
| Predicates.Off_fld (fld, typ) ->
Field (fld, typ)
| Sil.Off_index idx ->
| Predicates.Off_index idx ->
Index idx
in
let syn_offs = List.map ~f:offset_to_syn_offset offs in
@ -161,14 +161,14 @@ end = struct
(** path to the root, len, elements and type of a new_array *)
type strexp_data = path * Sil.strexp * Typ.t
type strexp_data = path * Predicates.strexp * Typ.t
(** Store hpred using physical equality, and offset list for an array *)
type t = sigma * Sil.hpred * syn_offset list
type t = sigma * Predicates.hpred * syn_offset list
(** Find an array at the given path. Can raise [Not_found] *)
let find_path sigma (root, syn_offs) : t =
let filter = function Sil.Hpointsto (e, _, _) -> Exp.equal root e | _ -> false in
let filter = function Predicates.Hpointsto (e, _, _) -> Exp.equal root e | _ -> false in
let hpred = List.find_exn ~f:filter sigma in
(sigma, hpred, syn_offs)
@ -182,13 +182,13 @@ end = struct
if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found
else
match (se, typ.desc) with
| Sil.Estruct (fsel, _), Tstruct name -> (
| Predicates.Estruct (fsel, _), Tstruct name -> (
match Tenv.lookup tenv name with
| Some {fields} ->
find_offset_fsel sigma_other hpred root offs fsel fields typ
| None ->
() )
| Sil.Earray (_, esel, _), Tarray {elt} ->
| Predicates.Earray (_, esel, _), Tarray {elt} ->
find_offset_esel sigma_other hpred root offs esel elt
| _ ->
()
@ -216,7 +216,7 @@ end = struct
()
| hpred :: sigma_rest ->
( match hpred with
| Sil.Hpointsto (root, se, te) ->
| Predicates.Hpointsto (root, se, te) ->
let sigma_other = sigma_seen @ sigma_rest in
find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te)
| _ ->
@ -229,7 +229,7 @@ end = struct
(** Get the matched strexp *)
let get_data tenv ((_, hpred, syn_offs) : t) =
match hpred with
| Sil.Hpointsto (root, se, te) ->
| Predicates.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in
let path' = (root, syn_offs) in
@ -248,22 +248,22 @@ end = struct
let update se' =
let se_in = update se' in
match (se', se_in) with
| Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2) ->
| Predicates.Earray (len, esel, _), Predicates.Earray (_, esel_in, inst2) ->
let orig_indices = List.map ~f:fst esel in
let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in
let process_index idx =
if index_is_not_new idx then idx else array_clean_new_index footprint_part idx
in
let esel_in' = List.map ~f:(fun (idx, se) -> (process_index idx, se)) esel_in in
Sil.Earray (len, esel_in', inst2)
Predicates.Earray (len, esel_in', inst2)
| _, _ ->
se_in
in
match hpred with
| Sil.Hpointsto (root, se, te) ->
| Predicates.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update in
Sil.Hpointsto (root, se', te)
Predicates.Hpointsto (root, se', te)
| _ ->
assert false
@ -280,13 +280,13 @@ end = struct
(index' : Exp.t) =
let update se' =
match se' with
| Sil.Earray (len, esel, inst) ->
| Predicates.Earray (len, esel, inst) ->
let esel' =
List.map
~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se'))
esel
in
Sil.Earray (len, esel', inst)
Predicates.Earray (len, esel', inst)
| _ ->
assert false
in
@ -407,7 +407,7 @@ let index_is_pointed_to tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path)
in
let pointers = List.concat_map ~f:add_index_to_paths indices in
let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) ->
| Predicates.Hpointsto (_, Predicates.Eexp (e, _), _) ->
List.exists ~f:(Exp.equal e) pointers
| _ ->
false
@ -464,13 +464,13 @@ let keep_only_indices tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) (i
let matched = StrexpMatch.find_path sigma path in
let _, se, _ = StrexpMatch.get_data tenv matched in
match se with
| Sil.Earray (len, esel, inst) ->
| Predicates.Earray (len, esel, inst) ->
let esel', esel_leftover' =
List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel
in
if List.is_empty esel_leftover' then (sigma, false)
else
let se' = Sil.Earray (len, esel', inst) in
let se' = Predicates.Earray (len, esel', inst) in
let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in
(sigma', true)
| _ ->
@ -493,7 +493,7 @@ let array_typ_can_abstract {Typ.desc} =
let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool =
let can_abstract_se =
match se with
| Sil.Earray (_, esel, _) ->
| Predicates.Earray (_, esel, _) ->
let len = List.length esel in
len > 1
| _ ->
@ -543,7 +543,7 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _) : StrexpMatch.str
partition_abstract should_keep abstract esel default_indices
in
let do_footprint () =
match se_in with Sil.Earray (_, esel, _) -> do_array_footprint esel | _ -> assert false
match se_in with Predicates.Earray (_, esel, _) -> do_array_footprint esel | _ -> assert false
in
let filter_abstract d_keys should_keep abstract ksel default_keys =
let keep_ksel = List.filter ~f:should_keep ksel in
@ -568,7 +568,11 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _) : StrexpMatch.str
filter_abstract Exp.d_list should_keep abstract esel []
in
let do_reexecution () =
match se_in with Sil.Earray (_, esel, _) -> do_array_reexecution esel | _ -> assert false
match se_in with
| Predicates.Earray (_, esel, _) ->
do_array_reexecution esel
| _ ->
assert false
in
if !BiabductionConfig.footprint then do_footprint () else do_reexecution ()
@ -595,29 +599,29 @@ let check_after_array_abstraction tenv prop =
else not (Exp.free_vars ind |> Sequence.exists ~f:Ident.is_primed)
in
let rec check_se root offs typ = function
| Sil.Eexp _ ->
| Predicates.Eexp _ ->
()
| Sil.Earray (_, esel, _) ->
| Predicates.Earray (_, esel, _) ->
(* check that no more than 2 elements are in the array *)
let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in
if List.length esel > 2 && array_typ_can_abstract typ then
if List.for_all ~f:(check_index root offs) esel then () else report_error prop
else
List.iter
~f:(fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se)
~f:(fun (ind, se) -> check_se root (offs @ [Predicates.Off_index ind]) typ_elem se)
esel
| Sil.Estruct (fsel, _) ->
| Predicates.Estruct (fsel, _) ->
List.iter
~f:(fun (f, se) ->
let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se )
check_se root (offs @ [Predicates.Off_fld (f, typ)]) typ_f se )
fsel
in
let check_hpred = function
| Sil.Hpointsto (root, se, texp) ->
| Predicates.Hpointsto (root, se, texp) ->
let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in
check_se root [] typ se
| Sil.Hlseg _ | Sil.Hdllseg _ ->
| Predicates.Hlseg _ | Predicates.Hdllseg _ ->
()
in
let check_sigma sigma = List.iter ~f:check_hpred sigma in
@ -639,7 +643,8 @@ let remove_redundant_elements tenv prop =
let occurs_at_most_once : Ident.t -> bool =
let fav_curr =
let ( @@@ ) = Sequence.append in
Sil.subst_free_vars prop.Prop.sub @@@ Prop.pi_free_vars prop.Prop.pi
Predicates.subst_free_vars prop.Prop.sub
@@@ Prop.pi_free_vars prop.Prop.pi
@@@ Prop.sigma_free_vars prop.Prop.sigma
in
let fav_foot =
@ -657,34 +662,34 @@ let remove_redundant_elements tenv prop =
L.d_strln "kill_redundant: removing " ;
Exp.d_exp e ;
L.d_str " " ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_ln () ;
array_abstraction_performed := true ;
modified := true ;
false
in
match (e, se) with
| Exp.Const (Const.Cint i), Sil.Eexp (Exp.Var id, _)
| Exp.Const (Const.Cint i), Predicates.Eexp (Exp.Var id, _)
when ((not fp_part) || IntLit.iszero i)
&& (not (Ident.is_normal id))
&& occurs_at_most_once id ->
remove () (* unknown value can be removed in re-execution mode or if the index is zero *)
| Exp.Var id, Sil.Eexp _ when (not (Ident.is_normal id)) && occurs_at_most_once id ->
| Exp.Var id, Predicates.Eexp _ when (not (Ident.is_normal id)) && occurs_at_most_once id ->
remove () (* index unknown can be removed *)
| _ ->
true
in
let remove_redundant_se fp_part = function
| Sil.Earray (len, esel, inst) ->
| Predicates.Earray (len, esel, inst) ->
let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in
Sil.Earray (len, esel', inst)
Predicates.Earray (len, esel', inst)
| se ->
se
in
let remove_redundant_hpred fp_part = function
| Sil.Hpointsto (e, se, te) ->
| Predicates.Hpointsto (e, se, te) ->
let se' = remove_redundant_se fp_part se in
Sil.Hpointsto (e, se', te)
Predicates.Hpointsto (e, se', te)
| hpred ->
hpred
in

61
infer/src/biabduction/Attribute.ml
Unescape View File

@ -11,12 +11,12 @@ open! IStd
(** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *)
(** Check whether an atom is used to mark an attribute *)
let is_pred atom = match atom with Sil.Apred _ | Anpred _ -> true | _ -> false
let is_pred atom = match atom with Predicates.Apred _ | Anpred _ -> true | _ -> false
(** Add an attribute associated to the argument expressions *)
let add tenv ?(footprint = false) ?(polarity = true) prop attr args =
Prop.prop_atom_and tenv ~footprint prop
(if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args))
(if polarity then Predicates.Apred (attr, args) else Predicates.Anpred (attr, args))
let attributes_in_same_category attr1 attr2 =
@ -28,19 +28,19 @@ let attributes_in_same_category attr1 attr2 =
(** Replace an attribute associated to the expression *)
let add_or_replace_check_changed tenv check_attribute_change prop atom =
match atom with
| Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) ->
| Predicates.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) ->
let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in
let _, nexp = List.hd_exn pairs in
(* len exps0 > 0 by match *)
let atom_map = function
| (Sil.Apred (att, exp :: _) | Anpred (att, exp :: _))
| (Predicates.Apred (att, exp :: _) | Anpred (att, exp :: _))
when Exp.equal nexp exp && attributes_in_same_category att att0 ->
check_attribute_change att att0 ; atom
| atom' ->
atom'
in
let pi = prop.Prop.pi in
let pi' = IList.map_changed ~equal:Sil.equal_atom ~f:atom_map pi in
let pi' = IList.map_changed ~equal:Predicates.equal_atom ~f:atom_map pi in
if phys_equal pi pi' then Prop.prop_atom_and tenv prop atom
else Prop.normalize tenv (Prop.set prop ~pi:pi')
| _ ->
@ -65,7 +65,7 @@ let get_for_exp tenv (prop : 'a Prop.t) exp =
let nexp = Prop.exp_normalize_prop tenv prop exp in
let atom_get_attr attributes atom =
match atom with
| (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp ->
| (Predicates.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp ->
atom :: attributes
| _ ->
attributes
@ -77,7 +77,7 @@ let get tenv prop exp category =
let atts = get_for_exp tenv prop exp in
List.find
~f:(function
| Sil.Apred (att, _) | Anpred (att, _) ->
| Predicates.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category
| _ ->
false )
@ -97,7 +97,7 @@ let get_wontleak tenv prop exp = get tenv prop exp ACwontleak
let has_dangling_uninit tenv prop exp =
let la = get_for_exp tenv prop exp in
List.exists
~f:(function Sil.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false)
~f:(function Predicates.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false)
la
@ -110,7 +110,7 @@ let filter_atoms tenv ~f prop =
let remove tenv prop atom =
if is_pred atom then
let natom = Prop.atom_normalize_prop tenv prop atom in
let f a = not (Sil.equal_atom natom a) in
let f a = not (Predicates.equal_atom natom a) in
filter_atoms tenv ~f prop
else prop
@ -118,7 +118,7 @@ let remove tenv prop atom =
(** Remove an attribute from all the atoms in the heap *)
let remove_for_attr tenv prop att0 =
let f = function
| Sil.Apred (att, _) | Anpred (att, _) ->
| Predicates.Apred (att, _) | Anpred (att, _) ->
not (PredSymb.equal att0 att)
| _ ->
true
@ -128,7 +128,7 @@ let remove_for_attr tenv prop att0 =
let remove_resource tenv ra_kind ra_res =
let f = function
| Sil.Apred (Aresource res_action, _) ->
| Predicates.Apred (Aresource res_action, _) ->
PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0
|| PredSymb.compare_resource res_action.ra_res ra_res <> 0
| _ ->
@ -146,15 +146,15 @@ let map_resource tenv prop f =
att
in
let atom_map = function
| Sil.Apred (att, ([e] as es)) ->
Sil.Apred (attribute_map e att, es)
| Sil.Anpred (att, ([e] as es)) ->
Sil.Anpred (attribute_map e att, es)
| Predicates.Apred (att, ([e] as es)) ->
Predicates.Apred (attribute_map e att, es)
| Predicates.Anpred (att, ([e] as es)) ->
Predicates.Anpred (attribute_map e att, es)
| atom ->
atom
in
let pi0 = prop.Prop.pi in
let pi1 = IList.map_changed ~equal:Sil.equal_atom ~f:atom_map pi0 in
let pi1 = IList.map_changed ~equal:Predicates.equal_atom ~f:atom_map pi0 in
if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1)
@ -165,7 +165,7 @@ let replace_objc_null tenv prop lhs_exp rhs_exp =
| Some atom, Exp.Var _ ->
let prop = remove tenv prop atom in
let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop in
let natom = Sil.atom_replace_exp [(rhs_exp, lhs_exp)] atom in
let natom = Predicates.atom_replace_exp [(rhs_exp, lhs_exp)] atom in
add_or_replace tenv prop natom
| _ ->
prop
@ -281,7 +281,7 @@ let find_arithmetic_problem tenv proc_node_session prop exp =
of stack variables whose address was still present after deallocation. *)
let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
let filter = function
| Sil.Hpointsto (Exp.Lvar v, _, _) ->
| Predicates.Hpointsto (Exp.Lvar v, _, _) ->
List.exists ~f:(Pvar.equal v) pvars
| _ ->
false
@ -294,7 +294,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
let exp_replace =
List.map
~f:(function
| Sil.Hpointsto (Exp.Lvar v, _, _) ->
| Predicates.Hpointsto (Exp.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars ;
(Exp.Lvar v, Exp.Var freshv)
@ -302,11 +302,14 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
assert false )
sigma_stack
in
let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in
let pi = List.map ~f:(Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in
let pi1 =
List.map ~f:(fun (id, e) -> Predicates.Aeq (Exp.Var id, e)) (Predicates.sub_to_list p.sub)
in
let pi = List.map ~f:(Predicates.atom_replace_exp exp_replace) (p.pi @ pi1) in
let p' =
Prop.normalize tenv
(Prop.set p ~sub:Sil.sub_empty ~sigma:(Prop.sigma_replace_exp tenv exp_replace sigma_other))
(Prop.set p ~sub:Predicates.sub_empty
~sigma:(Prop.sigma_replace_exp tenv exp_replace sigma_other))
in
let p'' =
let res = ref p' in
@ -317,7 +320,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
(* the address of a de-allocated stack var in in the post *)
if Ident.Set.mem freshv p'_fav then (
stack_vars_address_in_post := v :: !stack_vars_address_in_post ;
let pred = Sil.Apred (Adangling DAaddr_stack_var, [Exp.Var freshv]) in
let pred = Predicates.Apred (Adangling DAaddr_stack_var, [Exp.Var freshv]) in
res := add_or_replace tenv !res pred )
in
List.iter ~f:do_var !fresh_address_vars ;
@ -326,7 +329,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
(* Filter out local addresses in p'' *)
let filtered_pi, changed =
List.fold_right p''.pi ~init:([], false) ~f:(fun a (filtered, changed) ->
if Sil.atom_has_local_addr a then (filtered, true) else (a :: filtered, changed) )
if Predicates.atom_has_local_addr a then (filtered, true) else (a :: filtered, changed) )
in
(* Avoid normalization when p'' does not change *)
let p''' = if changed then Prop.normalize tenv (Prop.set p'' ~pi:filtered_pi) else p'' in
@ -339,18 +342,18 @@ let find_equal_formal_path tenv e prop =
let rec find_in_sigma e seen_hpreds =
List.fold_right
~f:(fun hpred res ->
if List.mem ~equal:Sil.equal_hpred seen_hpreds hpred then None
if List.mem ~equal:Predicates.equal_hpred seen_hpreds hpred then None
else
let seen_hpreds = hpred :: seen_hpreds in
match res with
| Some _ ->
res
| None -> (
match hpred with
| Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _)
match (hpred : Predicates.hpred) with
| Hpointsto (Exp.Lvar pvar1, Eexp (exp2, Predicates.Iformal (_, _)), _)
when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) ->
Some (Exp.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) ->
| Hpointsto (exp1, Estruct (fields, _), _) ->
List.fold_right
~f:(fun (field, strexp) res ->
match res with
@ -358,7 +361,7 @@ let find_equal_formal_path tenv e prop =
res
| None -> (
match strexp with
| Sil.Eexp (exp2, _) when Exp.equal exp2 e -> (
| Predicates.Eexp (exp2, _) when Exp.equal exp2 e -> (
match find_in_sigma exp1 seen_hpreds with
| Some vfs ->
Some (Exp.Lfield (vfs, field, Typ.mk Tvoid))

22
infer/src/biabduction/Attribute.mli
Unescape View File

@ -10,7 +10,7 @@ open! IStd
(** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *)
val is_pred : Sil.atom -> bool
val is_pred : Predicates.atom -> bool
(** Check whether an atom is used to mark an attribute *)
val add :
@ -23,43 +23,43 @@ val add :
-> Prop.normal Prop.t
(** Add an attribute associated to the argument expressions *)
val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Predicates.atom -> Prop.normal Prop.t
(** Replace an attribute associated to the expression *)
val add_or_replace_check_changed :
Tenv.t
-> (PredSymb.t -> PredSymb.t -> unit)
-> Prop.normal Prop.t
-> Sil.atom
-> Predicates.atom
-> Prop.normal Prop.t
(** Replace an attribute associated to the expression, and call the given function with new and old
attributes if they changed. *)
val get_all : 'a Prop.t -> Sil.atom list
val get_all : 'a Prop.t -> Predicates.atom list
(** Get all the attributes of the prop *)
val get_for_exp : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom list
val get_for_exp : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom list
(** Get the attributes associated to the expression, if any *)
val get_objc_null : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
val get_objc_null : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option
(** Get the objc null attribute associated to the expression, if any *)
val get_observer : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
val get_observer : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option
(** Get the observer attribute associated to the expression, if any *)
val get_resource : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
val get_resource : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option
(** Get the resource attribute associated to the expression, if any *)
val get_undef : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
val get_undef : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option
(** Get the undef attribute associated to the expression, if any *)
val get_wontleak : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
val get_wontleak : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option
(** Get the wontleak attribute associated to the expression, if any *)
val has_dangling_uninit : Tenv.t -> 'a Prop.t -> Exp.t -> bool
(** Test for existence of an Adangling DAuninit attribute associated to the exp *)
val remove : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
val remove : Tenv.t -> Prop.normal Prop.t -> Predicates.atom -> Prop.normal Prop.t
(** Remove an attribute *)
val remove_for_attr : Tenv.t -> Prop.normal Prop.t -> PredSymb.t -> Prop.normal Prop.t

4
infer/src/biabduction/BiabductionSummary.ml
Unescape View File

@ -175,7 +175,7 @@ module NormSpec : sig
val normalize : Tenv.t -> Prop.normal spec -> t
val compact : Sil.sharing_env -> t -> t
val compact : Predicates.sharing_env -> t -> t
(** Return a compact representation of the spec *)
val tospec : t -> Prop.normal spec
@ -208,7 +208,7 @@ end = struct
let idlist = free_vars tenv spec |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in
let count = ref 0 in
let sub =
Sil.subst_of_list
Predicates.subst_of_list
(List.map
~f:(fun id ->
incr count ;

4
infer/src/biabduction/BiabductionSummary.mli
Unescape View File

@ -31,7 +31,7 @@ module Jprop : sig
applies it to the subparts if the result is [None]. Returns the most absract results which
pass [filter]. *)
val jprop_sub : Sil.subst -> Prop.normal t -> Prop.exposed t
val jprop_sub : Predicates.subst -> Prop.normal t -> Prop.exposed t
(** apply a substitution to a jprop *)
val map : ('a Prop.t -> 'b Prop.t) -> 'a t -> 'b t
@ -58,7 +58,7 @@ type 'a spec = {pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited
module NormSpec : sig
type t
val compact : Sil.sharing_env -> t -> t
val compact : Predicates.sharing_env -> t -> t
(** Return a compact representation of the spec *)
val erase_join_info_pre : Tenv.t -> t -> t

46
infer/src/biabduction/BuiltinDefn.ml
Unescape View File

@ -25,13 +25,14 @@ let execute___builtin_va_arg {Builtin.summary; tenv; prop_; path; args; loc; exe
raise (Exceptions.Wrong_argument_number __POS__)
let mk_empty_array len = Sil.Earray (len, [], Sil.inst_none)
let mk_empty_array len = Predicates.Earray (len, [], Predicates.inst_none)
(* Make a rearranged array. As it is rearranged when it appears in a precondition
it requires that the function is called with the array allocated. If not infer
return a null pointer deref *)
let mk_empty_array_rearranged len =
Sil.Earray (len, [], Sil.inst_rearrange true (State.get_loc_exn ()) (State.get_path_pos ()))
Predicates.Earray
(len, [], Predicates.inst_rearrange true (State.get_loc_exn ()) (State.get_path_pos ()))
let extract_array_type typ =
@ -58,11 +59,11 @@ let add_array_to_prop tenv pdesc prop_ lexp typ =
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let hpred_opt =
List.find
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
prop.Prop.sigma
in
match hpred_opt with
| Some (Sil.Hpointsto (_, Sil.Earray (len, _, _), _)) ->
| Some (Predicates.Hpointsto (_, Predicates.Earray (len, _, _), _)) ->
Some (len, prop)
| Some _ ->
None (* e points to something but not an array *)
@ -125,12 +126,12 @@ let execute___set_array_length {Builtin.tenv; summary; prop_; path; args} : Buil
let n_len, prop = check_arith_norm_exp tenv pname len prop__ in
let hpred, sigma' =
List.partition_tf
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
prop.Prop.sigma
in
match hpred with
| [Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t)] ->
let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in
| [Predicates.Hpointsto (e, Earray (_, esel, inst), t)] ->
let hpred' = Predicates.Hpointsto (e, Earray (n_len, esel, inst), t) in
let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in
[(Prop.normalize tenv prop', path)]
| _ ->
@ -160,7 +161,7 @@ let create_type tenv n_lexp typ prop =
let prop_type =
match
List.find
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
prop.Prop.sigma
with
| Some _ ->
@ -169,7 +170,7 @@ let create_type tenv n_lexp typ prop =
let mhpred =
match typ.Typ.desc with
| Typ.Tptr (typ', _) ->
let sexp = Sil.Estruct ([], Sil.inst_none) in
let sexp = Predicates.Estruct ([], Predicates.inst_none) in
let texp =
Exp.Sizeof {typ= typ'; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
in
@ -222,7 +223,8 @@ let execute___get_type_of {Builtin.summary; tenv; prop_; path; ret_id_typ; args}
let hpred_opt =
List.find_map
~f:(function
| Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None )
| Predicates.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None
)
prop.Prop.sigma
in
match hpred_opt with
@ -241,12 +243,12 @@ let replace_ptsto_texp tenv prop root_e texp =
let process_sigma sigma =
let sigma1, sigma2 =
List.partition_tf
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e root_e | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e root_e | _ -> false)
sigma
in
match sigma1 with
| [Sil.Hpointsto (e, se, _)] ->
Sil.Hpointsto (e, se, texp) :: sigma2
| [Predicates.Hpointsto (e, se, _)] ->
Predicates.Hpointsto (e, se, texp) :: sigma2
| _ ->
sigma
in
@ -278,10 +280,10 @@ let execute___instanceof_cast ~instof {Builtin.summary; tenv; prop_; path; ret_i
else
let res_opt =
List.find
~f:(function Sil.Hpointsto (e1, _, _) -> Exp.equal e1 val1 | _ -> false)
~f:(function Predicates.Hpointsto (e1, _, _) -> Exp.equal e1 val1 | _ -> false)
prop.Prop.sigma
|> Option.map ~f:(function
| Sil.Hpointsto (_, _, texp1) -> (
| Predicates.Hpointsto (_, _, texp1) -> (
let pos_type_opt, neg_type_opt =
Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2
in
@ -438,7 +440,7 @@ let execute_exit {Builtin.prop_; path} : Builtin.ret_typ = SymExec.diverge prop_
let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter =
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (lexp, _, _), [] ->
| Predicates.Hpointsto (lexp, _, _), [] ->
let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
if mark_as_freed then
let pname = PredSymb.mem_dealloc_pname mk in
@ -456,7 +458,7 @@ let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter =
in
p_res :: acc
else prop :: acc
| Sil.Hpointsto _, _ :: _ ->
| Predicates.Hpointsto _, _ :: _ ->
assert false (* alignment error *)
| _ ->
assert false
@ -581,7 +583,7 @@ let execute_alloc mk can_return_null {Builtin.summary; tenv; prop_; path; ret_id
in
let id_new = Ident.create_fresh Ident.kprimed in
let exp_new = Exp.Var id_new in
let ptsto_new = Prop.mk_ptsto_exp tenv Prop.Fld_init (exp_new, cnt_te, None) Sil.Ialloc in
let ptsto_new = Prop.mk_ptsto_exp tenv Prop.Fld_init (exp_new, cnt_te, None) Predicates.Ialloc in
let prop_plus_ptsto =
let prop' = Prop.normalize tenv (Prop.prop_sigma_star prop [ptsto_new]) in
let ra =
@ -612,10 +614,10 @@ let execute___cxx_typeid ({Builtin.summary; tenv; prop_; args; loc; exe_env} as
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let typ =
List.find
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false)
prop.Prop.sigma
|> Option.value_map
~f:(function Sil.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_)
~f:(function Predicates.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_)
~default:typ_
in
let typ_string = Typ.to_string typ in
@ -763,7 +765,7 @@ let execute___infer_fail {Builtin.summary; tenv; prop_; path; args; loc; exe_env
in
let set_instr =
Sil.Store
{ e1= Exp.Lvar Sil.custom_error
{ e1= Exp.Lvar Predicates.custom_error
; root_typ= Typ.mk Tvoid
; typ= Typ.mk Tvoid
; e2= Exp.Const (Const.Cstr error_str)
@ -784,7 +786,7 @@ let execute___assert_fail {Builtin.summary; tenv; prop_; path; args; loc; exe_en
in
let set_instr =
Sil.Store
{ e1= Exp.Lvar Sil.custom_error
{ e1= Exp.Lvar Predicates.custom_error
; root_typ= Typ.mk Tvoid
; typ= Typ.mk Tvoid
; e2= Exp.Const (Const.Cstr error_str)

451
infer/src/biabduction/Dom.ml
View File

File diff suppressed because it is too large Load Diff

139
infer/src/biabduction/DotBiabduction.ml
Unescape View File

@ -53,15 +53,22 @@ type dotty_node =
(* Dotpointsto(coo,e,c): basic memory cell box for expression e at coordinate coo and color c *)
| Dotpointsto of coordinate * Exp.t * string
(* Dotstruct(coo,e,l,c): struct box for expression e with field list l at coordinate coo and color c *)
| Dotstruct of coordinate * Exp.t * (Typ.Fieldname.t * Sil.strexp) list * string * Exp.t
| Dotstruct of coordinate * Exp.t * (Typ.Fieldname.t * Predicates.strexp) list * string * Exp.t
(* Dotarray(coo,e1,e2,l,t,c): array box for expression e1 with field list l at coordinate coo and color c*)
(* e2 is the len and t is the type *)
| Dotarray of coordinate * Exp.t * Exp.t * (Exp.t * Sil.strexp) list * Typ.t * string
| Dotarray of coordinate * Exp.t * Exp.t * (Exp.t * Predicates.strexp) list * Typ.t * string
(* Dotlseg(coo,e1,e2,k,h,c): list box from e1 to e2 at coordinate coo and color c*)
| Dotlseg of coordinate * Exp.t * Exp.t * Sil.lseg_kind * Sil.hpred list * string
| Dotlseg of coordinate * Exp.t * Exp.t * Predicates.lseg_kind * Predicates.hpred list * string
(* Dotlseg(coo,e1,e2,e3,e4,k,h,c): doubly linked-list box from with parameters (e1,e2,e3,e4) at coordinate coo and color c*)
| Dotdllseg of
coordinate * Exp.t * Exp.t * Exp.t * Exp.t * Sil.lseg_kind * Sil.hpred list * string
coordinate
* Exp.t
* Exp.t
* Exp.t
* Exp.t
* Predicates.lseg_kind
* Predicates.hpred list
* string
let mk_coordinate i l = {id= i; lambda= l}
@ -126,16 +133,16 @@ let strip_special_chars b =
let rec strexp_to_string pe coo f se =
match se with
| Sil.Eexp (Exp.Lvar pvar, _) ->
match (se : Predicates.strexp) with
| Eexp (Exp.Lvar pvar, _) ->
(Pvar.pp pe) f pvar
| Sil.Eexp (Exp.Var id, _) ->
| Eexp (Exp.Var id, _) ->
if !print_full_prop then Ident.pp f id else ()
| Sil.Eexp (e, _) ->
| Eexp (e, _) ->
if !print_full_prop then (Exp.pp_diff pe) f e else F.pp_print_char f '_'
| Sil.Estruct (ls, _) ->
| Estruct (ls, _) ->
F.fprintf f " STRUCT | { %a } " (struct_to_dotty_str pe coo) ls
| Sil.Earray (e, idx, _) ->
| Earray (e, idx, _) ->
F.fprintf f " ARRAY[%a] | { %a } " (Exp.pp_diff pe) e (get_contents pe coo) idx
@ -152,14 +159,14 @@ and struct_to_dotty_str pe coo f ls : unit =
and get_contents_sexp pe coo f se =
match se with
| Sil.Eexp (e', _) ->
match (se : Predicates.strexp) with
| Eexp (e', _) ->
(Exp.pp_diff pe) f e'
| Sil.Estruct (se', _) ->
| Estruct (se', _) ->
F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se'
| Sil.Earray (e', [], _) ->
| Earray (e', [], _) ->
F.fprintf f "(ARRAY Size: %a) | { }" (Exp.pp_diff pe) e'
| Sil.Earray (e', (idx, a) :: linner, _) ->
| Earray (e', (idx, a) :: linner, _) ->
F.fprintf f "(ARRAY Size: %a) | { %a: %a | %a }" (Exp.pp_diff pe) e' (Exp.pp_diff pe) idx
(strexp_to_string pe coo) a (get_contents pe coo) linner
@ -257,7 +264,7 @@ let color_to_str (c : Pp.color) =
"red"
let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) list) =
let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Predicates.hpred * int) list) =
let exp_color hpred (exp : Exp.t) =
if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp)
@ -266,21 +273,21 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis
let n = !dotty_state_count in
incr dotty_state_count ;
let coo = mk_coordinate n lambda in
match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop ->
match (hpred : Predicates.hpred) with
| Hpointsto (_, Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop ->
let e_color_str = color_to_str (exp_color hpred e) in
[Dotdangling (coo, e, e_color_str)]
| Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) ->
| Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) ->
let e2_color_str = color_to_str (exp_color hpred e2) in
[Dotdangling (coo, e2, e2_color_str)]
| Sil.Hdllseg (_, _, _, e2, e3, _, _) ->
| Hdllseg (_, _, _, e2, e3, _, _) ->
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 ll =
if not (Exp.equal e2 Exp.zero) then [Dotdangling (coo, e2, e2_color_str)] else []
in
if not (Exp.equal e3 Exp.zero) then Dotdangling (coo, e3, e3_color_str) :: ll else ll
| Sil.Hpointsto (_, _, _) | _ ->
| Hpointsto (_, _, _) | _ ->
[]
(* arrays and struct do not give danglings*)
in
@ -329,36 +336,36 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis
let rec dotty_mk_node pe sigma =
let n = !dotty_state_count in
incr dotty_state_count ;
let do_hpred_lambda exp_color = function
| ( Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}})
, lambda ) ->
let do_hpred_lambda exp_color (hpred : Predicates.hpred) lambda =
match (hpred, lambda) with
| Hpointsto (e, Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}}), lambda ->
incr dotty_state_count ;
(* increment once more n+1 is the box for the array *)
let e_color_str = color_to_str (exp_color e) in
let e_color_str' = color_to_str (exp_color e') in
[ Dotpointsto (mk_coordinate n lambda, e, e_color_str)
; Dotarray (mk_coordinate (n + 1) lambda, e, e', l, t, e_color_str') ]
| Sil.Hpointsto (e, Sil.Estruct (l, _), te), lambda ->
| Hpointsto (e, Estruct (l, _), te), lambda ->
incr dotty_state_count ;
(* increment once more n+1 is the box for the struct *)
let e_color_str = color_to_str (exp_color e) in
(* [Dotpointsto((mk_coordinate n lambda), e, l, true, e_color_str)] *)
[ Dotpointsto (mk_coordinate n lambda, e, e_color_str)
; Dotstruct (mk_coordinate (n + 1) lambda, e, l, e_color_str, te) ]
| Sil.Hpointsto (e, _, _), lambda ->
| Hpointsto (e, _, _), lambda ->
let e_color_str = color_to_str (exp_color e) in
if List.mem ~equal:Exp.equal !struct_exp_nodes e then []
else [Dotpointsto (mk_coordinate n lambda, e, e_color_str)]
| Sil.Hlseg (k, hpara, e1, e2, _), lambda ->
| Hlseg (k, hpara, e1, e2, _), lambda ->
incr dotty_state_count ;
(* increment once more n+1 is the box for last element of the list *)
let eq_color_str = color_to_str (exp_color e1) in
[Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.Sil.body, eq_color_str)]
| Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda ->
[Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.body, eq_color_str)]
| Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda ->
let e1_color_str = color_to_str (exp_color e1) in
incr dotty_state_count ;
(* increment once more n+1 is the box for e4 *)
[Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str)]
[Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.body_dll, e1_color_str)]
in
match sigma with
| [] ->
@ -368,12 +375,12 @@ let rec dotty_mk_node pe sigma =
if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp)
in
do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma'
do_hpred_lambda exp_color hpred lambda @ dotty_mk_node pe sigma'
let set_exps_neq_zero pi =
let f = function
| Sil.Aneq (e, Exp.Const (Const.Cint i)) when IntLit.iszero i ->
| Predicates.Aneq (e, Const (Cint i)) when IntLit.iszero i ->
exps_neq_zero := e :: !exps_neq_zero
| _ ->
()
@ -403,19 +410,19 @@ let make_nil_node lambda =
let compute_fields_struct sigma =
fields_structs := [] ;
let rec do_strexp se in_struct =
match se with
| Sil.Eexp (e, _) ->
match (se : Predicates.strexp) with
| Eexp (e, _) ->
if in_struct then fields_structs := e :: !fields_structs else ()
| Sil.Estruct (l, _) ->
| Estruct (l, _) ->
List.iter ~f:(fun e -> do_strexp e true) (snd (List.unzip l))
| Sil.Earray (_, l, _) ->
| Earray (_, l, _) ->
List.iter ~f:(fun e -> do_strexp e false) (snd (List.unzip l))
in
let rec fs s =
match s with
| [] ->
()
| Sil.Hpointsto (_, se, _) :: s' ->
| Predicates.Hpointsto (_, se, _) :: s' ->
do_strexp se false ; fs s'
| _ :: s' ->
fs s'
@ -429,7 +436,7 @@ let compute_struct_exp_nodes sigma =
match s with
| [] ->
()
| Sil.Hpointsto (e, Sil.Estruct _, _) :: s' ->
| Predicates.Hpointsto (e, Estruct _, _) :: s' ->
struct_exp_nodes := e :: !struct_exp_nodes ;
sen s'
| _ :: s' ->
@ -449,7 +456,7 @@ let in_cycle cycle edge =
| Some cycle' ->
let fn, se = edge in
List.exists
~f:(fun (_, fn', se') -> Typ.Fieldname.equal fn fn' && Sil.equal_strexp se se')
~f:(fun (_, fn', se') -> Typ.Fieldname.equal fn fn' && Predicates.equal_strexp se se')
cycle'
| _ ->
false
@ -467,8 +474,8 @@ let node_in_cycle cycle node =
(* compute a list of (kind of link, field name, coo.id target, name_target) *)
let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
let find_target_one_fld (fn, se) =
match se with
| Sil.Eexp (e, _) -> (
match (se : Predicates.strexp) with
| Eexp (e, _) -> (
if is_nil e p then
let n' = make_nil_node lambda in
if !print_full_prop then [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] else []
@ -495,9 +502,9 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
(* by construction there must be at most 2 nodes for an expression*)
L.internal_error "@\n Too many nodes! Error! @\n@." ;
assert false )
| Sil.Estruct (_, _) ->
| Estruct (_, _) ->
[] (* inner struct are printed by print_struc function *)
| Sil.Earray _ ->
| Earray _ ->
[]
(* inner arrays are printed by print_array function *)
in
@ -512,8 +519,8 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
(* compute a list of (kind of link, field name, coo.id target, name_target) *)
let rec compute_target_array_elements dotnodes list_elements p f lambda =
let find_target_one_element (idx, se) =
match se with
| Sil.Eexp (e, _) -> (
match (se : Predicates.strexp) with
| Eexp (e, _) -> (
if is_nil e p then
let n' = make_nil_node lambda in
[(LinkArrayToExp, Exp.to_string idx, n', "")]
@ -536,9 +543,9 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
(* by construction there must be at most 2 nodes for an expression*)
L.internal_error "@\nToo many nodes! Error!@\n@." ;
assert false )
| Sil.Estruct (_, _) ->
| Estruct (_, _) ->
[] (* inner struct are printed by print_struc function *)
| Sil.Earray _ ->
| Earray _ ->
[]
(* inner arrays are printed by print_array function *)
in
@ -595,9 +602,9 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
match sigma with
| [] ->
[]
| (Sil.Hpointsto (e, Sil.Earray (_, lie, _), _), lambda) :: sigma' ->
| (Predicates.Hpointsto (e, Earray (_, lie, _), _), lambda) :: sigma' ->
make_links_for_arrays e lie lambda sigma'
| (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda) :: sigma' -> (
| (Predicates.Hpointsto (e, Estruct (lfld, _), _), lambda) :: sigma' -> (
let src = look_up dotnodes e lambda in
match src with
| [] ->
@ -630,7 +637,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
in
lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle
)
| (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' -> (
| (Predicates.Hpointsto (e, Eexp (e', _), _), lambda) :: sigma' -> (
let src = look_up dotnodes e lambda in
match src with
| [] ->
@ -648,7 +655,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
let ll = List.concat_map ~f:ff nl in
ll @ dotty_mk_set_links dotnodes sigma' p f cycle
else dotty_mk_set_links dotnodes sigma' p f cycle )
| (Sil.Hlseg (_, _, e1, e2, _), lambda) :: sigma' -> (
| (Predicates.Hlseg (_, _, e1, e2, _), lambda) :: sigma' -> (
let src = look_up dotnodes e1 lambda in
match src with
| [] ->
@ -659,7 +666,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab
in
lnk :: dotty_mk_set_links dotnodes sigma' p f cycle )
| (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> (
| (Predicates.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> (
let src = look_up dotnodes e1 lambda in
match src with
| [] ->
@ -856,11 +863,11 @@ and print_sll f pe nesting k e1 coo =
let lambda = coo.lambda in
let n' = !dotty_state_count in
incr dotty_state_count ;
( match k with
| Sil.Lseg_NE ->
( match (k : Predicates.lseg_kind) with
| Lseg_NE ->
F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";"
n' lambda "style=filled; color=lightgrey;"
| Sil.Lseg_PE ->
| Lseg_PE ->
F.fprintf f
"subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n'
lambda "style=filled; color=lightgrey;" ) ;
@ -883,11 +890,11 @@ and print_dll f pe nesting k e1 e4 coo =
let lambda = coo.lambda in
let n' = !dotty_state_count in
incr dotty_state_count ;
( match k with
| Sil.Lseg_NE ->
( match (k : Predicates.lseg_kind) with
| Lseg_NE ->
F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n'
lambda "style=filled; color=lightgrey;" "doubly-linked list NE"
| Sil.Lseg_PE ->
| Lseg_PE ->
F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n'
lambda "style=filled; color=lightgrey;" "doubly-linked list PE" ) ;
F.fprintf f "state%iL%i [label=\"%a\"]@\n" n lambda (Exp.pp_diff pe) e1 ;
@ -927,14 +934,14 @@ and dotty_pp_state f pe cycle dotnode =
print_struct f pe e1 te l' coo c
| Dotarray (coo, e1, e2, l, _, c) when !print_full_prop ->
print_array f pe e1 e2 l coo c
| Dotlseg (coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_NE e1 coo
| Dotlseg (coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_PE e1 coo
| Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_NE e1 e4 coo
| Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_PE e1 e4 coo
| Dotlseg (coo, e1, _, Lseg_NE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Predicates.Lseg_NE e1 coo
| Dotlseg (coo, e1, _, Lseg_PE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Predicates.Lseg_PE e1 coo
| Dotdllseg (coo, e1, _, _, e4, Lseg_NE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Predicates.Lseg_NE e1 e4 coo
| Dotdllseg (coo, e1, _, _, e4, Lseg_PE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Predicates.Lseg_PE e1 e4 coo
| _ ->
()

213
infer/src/biabduction/Match.ml
Unescape View File

@ -16,20 +16,20 @@ let mem_idlist i l = List.exists ~f:(Ident.equal i) l
(** Type for a hpred pattern. flag=false means that the implication between hpreds is not
considered, and flag = true means that it is considered during pattern matching *)
type hpred_pat = {hpred: Sil.hpred; flag: bool}
type hpred_pat = {hpred: Predicates.hpred; flag: bool}
(** Checks [e1 = e2\[sub ++ sub'\]] for some [sub'] with [dom(sub') subseteq vars]. 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 : (Predicates.subst * Ident.t list) option =
let check_equal sub vars e1 e2 =
let e2_inst = Sil.exp_sub sub e2 in
let e2_inst = Predicates.exp_sub sub e2 in
if Exp.equal e1 e2_inst then Some (sub, vars) else None
in
match (e1, e2) with
| _, Exp.Var id2 when Ident.is_primed id2 && mem_idlist id2 vars ->
let vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in
let sub_new =
match Sil.extend_sub sub id2 e1 with
match Predicates.extend_sub sub id2 e1 with
| None ->
assert false (* happens when vars contains the same variable twice. *)
| Some sub_new ->
@ -97,17 +97,18 @@ let exp_list_match es1 sub vars es2 =
(** Checks [sexp1 = sexp2\[sub ++ sub'\]] for some [sub'] with [dom(sub') subseteq vars]. Returns
[(sub ++ sub', vars - dom(sub'))]. WARNING: This function does not consider the fact that the
analyzer 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 : Predicates.strexp) sub vars (sexp2 : Predicates.strexp) :
(Predicates.subst * Ident.t list) option =
match (sexp1, sexp2) with
| Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) ->
| Eexp (exp1, _), Eexp (exp2, _) ->
exp_match exp1 sub vars exp2
| Sil.Eexp _, _ | _, Sil.Eexp _ ->
| Eexp _, _ | _, Eexp _ ->
None
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) ->
| Estruct (fsel1, _), Estruct (fsel2, _) ->
fsel_match fsel1 sub vars fsel2
| Sil.Estruct _, _ | _, Sil.Estruct _ ->
| Estruct _, _ | _, Estruct _ ->
None
| Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> (
| Earray (len1, isel1, _), Earray (len2, isel2, _) -> (
match exp_match len1 sub vars len2 with
| Some (sub', vars') ->
isel_match isel1 sub' vars' isel2
@ -148,15 +149,15 @@ and isel_match isel1 sub vars isel2 =
| [], _ | _, [] ->
None
| (idx1, se1') :: isel1', (idx2, se2') :: isel2' ->
let idx2 = Sil.exp_sub sub idx2 in
let idx2 = Predicates.exp_sub sub idx2 in
let sanity_check = not (List.exists ~f:(fun id -> Exp.ident_mem idx2 id) vars) in
if not sanity_check then (
let pe = Pp.text in
L.internal_error "@[.... Sanity Check Failure while Matching Index-Strexps ....@\n" ;
L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Exp.pp_diff pe) idx1 (Sil.pp_sexp pe)
se1' ;
L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Exp.pp_diff pe) idx1
(Predicates.pp_sexp pe) se1' ;
L.internal_error "@[<4> IDX2: %a, STREXP2: %a@\n@." (Exp.pp_diff pe) idx2
(Sil.pp_sexp pe) se2' ;
(Predicates.pp_sexp pe) se2' ;
assert false )
else if Exp.equal idx1 idx2 then
match strexp_match se1' sub vars se2' with
@ -168,13 +169,13 @@ and isel_match isel1 sub vars isel2 =
(* extends substitution sub by creating a new substitution for vars *)
let sub_extend_with_ren (sub : Sil.subst) vars =
let sub_extend_with_ren (sub : Predicates.subst) vars =
let f id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in
let renaming_for_vars = Sil.subst_of_list (List.map ~f vars) in
Sil.sub_join sub renaming_for_vars
let renaming_for_vars = Predicates.subst_of_list (List.map ~f vars) in
Predicates.sub_join sub renaming_for_vars
type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool
type sidecondition = Prop.normal Prop.t -> Predicates.subst -> bool
let rec execute_with_backtracking = function
| [] ->
@ -186,35 +187,33 @@ let rec execute_with_backtracking = function
match res_f with None -> execute_with_backtracking fs | Some _ -> res_f )
let rec instantiate_to_emp p condition (sub : Sil.subst) vars = function
let rec instantiate_to_emp p condition (sub : Predicates.subst) vars = function
| [] ->
if condition p sub then Some (sub, p) else None
| hpat :: hpats -> (
if not hpat.flag then None
else
match hpat.hpred with
| Sil.Hpointsto _
| Sil.Hlseg (Sil.Lseg_NE, _, _, _, _)
| Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) ->
match (hpat.hpred : Predicates.hpred) with
| Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) ->
None
| Sil.Hlseg (_, _, e1, e2, _) -> (
| Hlseg (_, _, e1, e2, _) -> (
let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem e1 id) vars) in
if not fully_instantiated then None
else
let e1' = Sil.exp_sub sub e1 in
let e1' = Predicates.exp_sub sub e1 in
match exp_match e1' sub vars e2 with
| None ->
None
| Some (sub_new, vars_leftover) ->
instantiate_to_emp p condition sub_new vars_leftover hpats )
| Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> (
| Hdllseg (_, _, iF, oB, oF, iB, _) -> (
let fully_instantiated =
not (List.exists ~f:(fun id -> Exp.ident_mem iF id || Exp.ident_mem oB id) vars)
in
if not fully_instantiated then None
else
let iF' = Sil.exp_sub sub iF in
let oB' = Sil.exp_sub sub oB in
let iF' = Predicates.exp_sub sub iF in
let oB' = Predicates.exp_sub sub oB in
match exp_list_match [iF'; oB'] sub vars [oF; iB] with
| None ->
None
@ -268,7 +267,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
prop_match_with_impl_sub tenv p_rest condition sub_new vars_leftover hpat_next hpats_rest
in
let gen_filter_pointsto lexp2 strexp2 te2 = function
| Sil.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 -> (
| Predicates.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 -> (
match exp_match lexp1 sub vars lexp2 with
| None ->
None
@ -277,15 +276,16 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| _ ->
None
in
let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function
| Sil.Hpointsto _ ->
let gen_filter_lseg (k2 : Predicates.lseg_kind) para2 e_start2 e_end2 es_shared2 hpred =
match (hpred : Predicates.hpred) with
| Hpointsto _ ->
None
| Sil.Hlseg (k1, para1, e_start1, e_end1, es_shared1) ->
| Hlseg (k1, para1, e_start1, e_end1, es_shared1) ->
let do_kinds_match =
match (k1, k2) with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE ->
| Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_PE ->
true
| Sil.Lseg_PE, Sil.Lseg_NE ->
| Lseg_PE, Lseg_NE ->
false
in
(* let do_paras_match = hpara_match_with_impl tenv hpat.flag para1 para2 *)
@ -295,18 +295,19 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
let es1 = [e_start1; e_end1] @ es_shared1 in
let es2 = [e_start2; e_end2] @ es_shared2 in
exp_list_match es1 sub vars es2
| Sil.Hdllseg _ ->
| Hdllseg _ ->
None
in
let gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 = function
| Sil.Hpointsto _ | Sil.Hlseg _ ->
let gen_filter_dllseg (k2 : Predicates.lseg_kind) para2 iF2 oB2 oF2 iB2 es_shared2 hpred =
match (hpred : Predicates.hpred) with
| Hpointsto _ | Hlseg _ ->
None
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) ->
| Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) ->
let do_kinds_match =
match (k1, k2) with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE ->
| Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_PE ->
true
| Sil.Lseg_PE, Sil.Lseg_NE ->
| Lseg_PE, Lseg_NE ->
false
in
(* let do_paras_match = hpara_dll_match_with_impl tenv hpat.flag para1 para2 *)
@ -318,7 +319,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
exp_list_match es1 sub vars es2
in
match hpat.hpred with
| Sil.Hpointsto (lexp2, strexp2, te2) -> (
| Hpointsto (lexp2, strexp2, te2) -> (
let filter = gen_filter_pointsto lexp2 strexp2 te2 in
match (Prop.prop_iter_find iter filter, hpats) with
| None, _ ->
@ -327,7 +328,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
do_empty_hpats iter_cur ()
| Some iter_cur, _ ->
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] )
| Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) -> (
| Hlseg (k2, para2, e_start2, e_end2, es_shared2) -> (
let filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in
let do_emp_lseg _ =
let fully_instantiated_start2 =
@ -335,7 +336,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in
if not fully_instantiated_start2 then None
else
let e_start2' = Sil.exp_sub sub e_start2 in
let e_start2' = Predicates.exp_sub sub e_start2 in
match (exp_match e_start2' sub vars e_end2, hpats) with
| None, _ ->
(*
@ -354,7 +355,9 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest
in
let do_para_lseg _ =
let para2_exist_vars, para2_inst = Sil.hpara_instantiate para2 e_start2 e_end2 es_shared2 in
let para2_exist_vars, para2_inst =
Predicates.hpara_instantiate para2 e_start2 e_end2 es_shared2
in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
let allow_impl hpred = {hpred; flag= true} in
let para2_hpat, para2_hpats =
@ -373,7 +376,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
let not_in_para2_exist_vars id =
not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars)
in
let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in
let sub_res' = Predicates.sub_filter not_in_para2_exist_vars sub_res in
Some (sub_res', p_leftover)
| Some _ ->
None
@ -382,7 +385,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| None, _ when not hpat.flag ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
None
| None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE ->
| None, _ when Predicates.equal_lseg_kind k2 Lseg_NE ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
do_para_lseg ()
| None, _ ->
@ -394,7 +397,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| Some iter_cur, _ ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] )
| Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> (
| Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> (
let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in
let do_emp_dllseg _ =
let fully_instantiated_iFoB2 =
@ -402,8 +405,8 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in
if not fully_instantiated_iFoB2 then None
else
let iF2' = Sil.exp_sub sub iF2 in
let oB2' = Sil.exp_sub sub oB2 in
let iF2' = Predicates.exp_sub sub iF2 in
let oB2' = Predicates.exp_sub sub oB2 in
match (exp_list_match [iF2'; oB2'] sub vars [oF2; iB2], hpats) with
| None, _ ->
None
@ -419,13 +422,13 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
let fully_instantiated_iF2 = not (List.exists ~f:(fun id -> Exp.ident_mem iF2 id) vars) in
if not fully_instantiated_iF2 then None
else
let iF2' = Sil.exp_sub sub iF2 in
let iF2' = Predicates.exp_sub sub iF2 in
match exp_match iF2' sub vars iB2 with
| None ->
None
| Some (sub_new, vars_leftover) -> (
let para2_exist_vars, para2_inst =
Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2
Predicates.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2
in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
let allow_impl hpred = {hpred; flag= true} in
@ -448,7 +451,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
let not_in_para2_exist_vars id =
not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars)
in
let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in
let sub_res' = Predicates.sub_filter not_in_para2_exist_vars sub_res in
Some (sub_res', p_leftover)
| Some _ ->
None )
@ -456,7 +459,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
match (Prop.prop_iter_find iter filter, hpats) with
| None, _ when not hpat.flag ->
None
| None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE ->
| None, _ when Predicates.equal_lseg_kind k2 Lseg_NE ->
do_para_dllseg ()
| None, _ ->
execute_with_backtracking [do_emp_dllseg; do_para_dllseg]
@ -495,19 +498,23 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 =
let sub_eids = List.map ~f:(fun (id2, id1) -> (id2, Exp.Var id1)) ren_eids in
(sub_eids, eids_fresh)
in
let sub = Sil.subst_of_list (sub_ids @ sub_eids) in
let sub = Predicates.subst_of_list (sub_ids @ sub_eids) in
match sigma2 with
| [] ->
if List.is_empty sigma1 then true else false
| hpred2 :: sigma2 -> (
let hpat2, hpats2 =
let hpred2_ren, sigma2_ren = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in
let hpred2_ren, sigma2_ren =
(Predicates.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2)
in
let allow_impl hpred = {hpred; flag= impl_ok} in
(allow_impl hpred2_ren, List.map ~f:allow_impl sigma2_ren)
in
let condition _ _ = true in
let p1 = Prop.normalize tenv (Prop.from_sigma sigma1) in
match prop_match_with_impl_sub tenv p1 condition Sil.sub_empty eids_fresh hpat2 hpats2 with
match
prop_match_with_impl_sub tenv p1 condition Predicates.sub_empty eids_fresh hpat2 hpats2
with
| None ->
false
| Some (_, p1') when Prop.prop_is_emp p1' ->
@ -517,28 +524,19 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 =
with Invalid_argument _ -> false
and hpara_match_with_impl tenv impl_ok para1 para2 : bool =
(*
L.out "@[.... hpara_match_with_impl_sub ....@.";
L.out "@[<4> HPARA1: %a@\n@." pp_hpara para1;
L.out "@[<4> HPARA2: %a@\n@." pp_hpara para2;
*)
let ids1 = para1.Sil.root :: para1.Sil.next :: para1.Sil.svars in
let ids2 = para2.Sil.root :: para2.Sil.next :: para2.Sil.svars in
let eids2 = para2.Sil.evars in
hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body eids2 ids2 para2.Sil.body
and hpara_match_with_impl tenv impl_ok (para1 : Predicates.hpara) (para2 : Predicates.hpara) =
let ids1 = para1.root :: para1.next :: para1.svars in
let ids2 = para2.root :: para2.next :: para2.svars in
let eids2 = para2.evars in
hpara_common_match_with_impl tenv impl_ok ids1 para1.body eids2 ids2 para2.body
and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool =
(*
L.out "@[.... hpara_dll_match_with_impl_sub ....@.";
L.out "@[<4> HPARA1: %a@\n@." pp_hpara_dll para1;
L.out "@[<4> HPARA2: %a@\n@." pp_hpara_dll para2;
*)
let ids1 = para1.Sil.cell :: para1.Sil.blink :: para1.Sil.flink :: para1.Sil.svars_dll in
let ids2 = para2.Sil.cell :: para2.Sil.blink :: para2.Sil.flink :: para2.Sil.svars_dll in
let eids2 = para2.Sil.evars_dll in
hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body_dll eids2 ids2 para2.Sil.body_dll
and hpara_dll_match_with_impl tenv impl_ok (para1 : Predicates.hpara_dll)
(para2 : Predicates.hpara_dll) =
let ids1 = para1.cell :: para1.blink :: para1.flink :: para1.svars_dll in
let ids2 = para2.cell :: para2.blink :: para2.flink :: para2.svars_dll in
let eids2 = para2.evars_dll in
hpara_common_match_with_impl tenv impl_ok ids1 para1.body_dll eids2 ids2 para2.body_dll
(** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that
@ -547,14 +545,13 @@ and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool =
+ [p |- (hpat.hpred * hpats.hpred)\[subst\] * p_leftover]. Using the flag [field], we can
control the strength of |-. *)
let prop_match_with_impl tenv p condition vars hpat hpats =
prop_match_with_impl_sub tenv p condition Sil.sub_empty vars hpat hpats
prop_match_with_impl_sub tenv p condition Predicates.sub_empty vars hpat hpats
let sigma_remove_hpred eq sigma e =
let filter = function
| Sil.Hpointsto (root, _, _)
| Sil.Hlseg (_, _, root, _, _)
| Sil.Hdllseg (_, _, root, _, _, _, _) ->
let filter hpred =
match (hpred : Predicates.hpred) with
| Hpointsto (root, _, _) | Hlseg (_, _, root, _, _) | Hdllseg (_, _, root, _, _, _, _) ->
eq root e
in
let sigma_e, sigma_no_e = List.partition_tf ~f:filter sigma in
@ -573,23 +570,24 @@ type iso_mode = Exact | LFieldForget | RFieldForget [@@deriving compare]
let equal_iso_mode = [%compare.equal: iso_mode]
let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
let rec generate_todos_from_strexp mode todos (sexp1 : Predicates.strexp)
(sexp2 : Predicates.strexp) =
match (sexp1, sexp2) with
| Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) ->
| Eexp (exp1, _), Eexp (exp2, _) ->
let new_todos = (exp1, exp2) :: todos in
Some new_todos
| Sil.Eexp _, _ ->
| Eexp _, _ ->
None
| Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) ->
| Estruct (fel1, _), Estruct (fel2, _) ->
(* assume sorted w.r.t. fields *)
if List.length fel1 <> List.length fel2 && equal_iso_mode mode Exact then None
else generate_todos_from_fel mode todos fel1 fel2
| Sil.Estruct _, _ ->
| Estruct _, _ ->
None
| Sil.Earray (len1, iel1, _), Sil.Earray (len2, iel2, _) ->
| Earray (len1, iel1, _), Earray (len2, iel2, _) ->
if (not (Exp.equal len1 len2)) || List.length iel1 <> List.length iel2 then None
else generate_todos_from_iel mode todos iel1 iel2
| Sil.Earray _, _ ->
| Earray _, _ ->
None
@ -697,10 +695,11 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm
generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo )
| None, _ | _, None ->
None
| Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2))
| Some (Predicates.Hpointsto (_, _, te1)), Some (Predicates.Hpointsto (_, _, te2))
when not (Exp.equal te1 te2) ->
None
| Some (Sil.Hpointsto (_, se1, _) as hpred1), Some (Sil.Hpointsto (_, se2, _) as hpred2) -> (
| ( Some (Predicates.Hpointsto (_, se1, _) as hpred1)
, Some (Predicates.Hpointsto (_, se2, _) as hpred2) ) -> (
match generate_todos_from_strexp mode [] se1 se2 with
| None ->
None
@ -721,8 +720,8 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm
let new_todos = todos'' @ todos' in
generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos
new_sigma_todo )
| ( Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1)
, Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> (
| ( Some (Predicates.Hlseg (k1, para1, root1, next1, shared1) as hpred1)
, Some (Predicates.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> (
if k1 <> k2 || not (hpara_iso tenv para1 para2) then None
else
try
@ -746,8 +745,8 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm
generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos
new_sigma_todo
with Invalid_argument _ -> None )
| ( 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 (Predicates.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1)
, Some (Predicates.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) -> (
if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None
else
try
@ -794,14 +793,14 @@ let find_partial_iso tenv eq corres todos sigma =
(** Lift the kind of list segment predicates to PE *)
let hpred_lift_to_pe hpred =
let hpred_lift_to_pe (hpred : Predicates.hpred) : Predicates.hpred =
match hpred with
| Sil.Hpointsto _ ->
| Hpointsto _ ->
hpred
| Sil.Hlseg (_, para, root, next, shared) ->
Sil.Hlseg (Sil.Lseg_PE, para, root, next, shared)
| Sil.Hdllseg (_, para, iF, oB, oF, iB, shared) ->
Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared)
| Hlseg (_, para, root, next, shared) ->
Hlseg (Lseg_PE, para, root, next, shared)
| Hdllseg (_, para, iF, oB, oF, iB, shared) ->
Hdllseg (Lseg_PE, para, iF, oB, oF, iB, shared)
(** Lift the kind of list segment predicates to PE in a given sigma *)
@ -855,7 +854,7 @@ let hpara_create tenv corres sigma1 root1 next1 =
let id_root = get_id1 root1 in
let id_next = get_id1 next1 in
let hpara =
{Sil.root= id_root; Sil.next= id_next; Sil.svars= ids_shared; Sil.evars= ids_exists; Sil.body}
{Predicates.root= id_root; next= id_next; svars= ids_shared; evars= ids_exists; body}
in
(hpara, es_shared)
@ -875,11 +874,11 @@ let hpara_dll_create tenv corres sigma1 root1 blink1 flink1 =
let id_blink = get_id1 blink1 in
let id_flink = get_id1 flink1 in
let hpara_dll =
{ Sil.cell= id_root
; Sil.blink= id_blink
; Sil.flink= id_flink
; Sil.svars_dll= ids_shared
; Sil.evars_dll= ids_exists
; Sil.body_dll= body }
{ Predicates.cell= id_root
; blink= id_blink
; flink= id_flink
; svars_dll= ids_shared
; evars_dll= ids_exists
; body_dll= body }
in
(hpara_dll, es_shared)

31
infer/src/biabduction/Match.mli
Unescape View File

@ -17,15 +17,16 @@ open! IStd
(* TODO: missing documentation *)
val hpara_match_with_impl : Tenv.t -> bool -> Sil.hpara -> Sil.hpara -> bool
val hpara_match_with_impl : Tenv.t -> bool -> Predicates.hpara -> Predicates.hpara -> bool
val hpara_dll_match_with_impl : Tenv.t -> bool -> Sil.hpara_dll -> Sil.hpara_dll -> bool
val hpara_dll_match_with_impl :
Tenv.t -> bool -> Predicates.hpara_dll -> Predicates.hpara_dll -> bool
(** Type for a hpred pattern. [flag=false] means that the implication between hpreds is not
considered, and [flag = true] means that it is considered during pattern matching. *)
type hpred_pat = {hpred: Sil.hpred; flag: bool}
type hpred_pat = {hpred: Predicates.hpred; flag: bool}
type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool
type sidecondition = Prop.normal Prop.t -> Predicates.subst -> bool
val prop_match_with_impl :
Tenv.t
@ -34,7 +35,7 @@ val prop_match_with_impl :
-> Ident.t list
-> hpred_pat
-> hpred_pat list
-> (Sil.subst * Prop.normal Prop.t) option
-> (Predicates.subst * Prop.normal Prop.t) option
(** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that
+ [dom(subst) = vars]
@ -47,22 +48,28 @@ val find_partial_iso :
-> (Exp.t -> Exp.t -> bool)
-> (Exp.t * Exp.t) list
-> (Exp.t * Exp.t) list
-> Sil.hpred list
-> ((Exp.t * Exp.t) list * Sil.hpred list * Sil.hpred list * Sil.hpred list) option
-> Predicates.hpred list
-> ((Exp.t * Exp.t) list * Predicates.hpred list * Predicates.hpred list * Predicates.hpred list)
option
(** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. The first argument
is an equality checker. 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 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 part of the input sigma. *)
val hpara_iso : Tenv.t -> Sil.hpara -> Sil.hpara -> bool
val hpara_iso : Tenv.t -> Predicates.hpara -> Predicates.hpara -> bool
(** [hpara_iso] soundly checks whether two hparas are isomorphic. *)
val hpara_dll_iso : Tenv.t -> Sil.hpara_dll -> Sil.hpara_dll -> bool
val hpara_dll_iso : Tenv.t -> Predicates.hpara_dll -> Predicates.hpara_dll -> bool
(** [hpara_dll_iso] soundly checks whether two hpara_dlls are isomorphic. *)
val hpara_create :
Tenv.t -> (Exp.t * Exp.t) list -> Sil.hpred list -> Exp.t -> Exp.t -> Sil.hpara * Exp.t list
Tenv.t
-> (Exp.t * Exp.t) list
-> Predicates.hpred list
-> Exp.t
-> Exp.t
-> Predicates.hpara * Exp.t list
(** [hpara_create] takes a correspondence, and a sigma, a root and a next for the first part of this
correspondence. Then, it creates a hpara and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *)
@ -70,11 +77,11 @@ val hpara_create :
val hpara_dll_create :
Tenv.t
-> (Exp.t * Exp.t) list
-> Sil.hpred list
-> Predicates.hpred list
-> Exp.t
-> Exp.t
-> Exp.t
-> Sil.hpara_dll * Exp.t list
-> Predicates.hpara_dll * Exp.t list
(** [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 hpara_dll and discovers a list of shared
expressions that are passed as arguments to hpara. Both of them are returned as a result. *)

1257
infer/src/biabduction/Predicates.ml
View File

File diff suppressed because it is too large Load Diff

382
infer/src/biabduction/Predicates.mli
Unescape View File

@ -0,0 +1,382 @@
(*
* Copyright (c) Facebook, Inc. and its affiliates.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
open! IStd
module F = Format
(** Offset for an lvalue. *)
type offset = Off_fld of Typ.Fieldname.t * Typ.t | Off_index of Exp.t
(** {2 Components of Propositions} *)
(** an atom is a pure atomic formula *)
type atom =
| Aeq of Exp.t * Exp.t (** equality *)
| Aneq of Exp.t * Exp.t (** disequality *)
| Apred of PredSymb.t * Exp.t list (** predicate symbol applied to exps *)
| Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *)
[@@deriving compare]
val equal_atom : atom -> atom -> bool
val atom_has_local_addr : atom -> bool
(** kind of lseg or dllseg predicates *)
type lseg_kind =
| Lseg_NE (** nonempty (possibly circular) listseg *)
| Lseg_PE (** possibly empty (possibly circular) listseg *)
[@@deriving compare]
val equal_lseg_kind : lseg_kind -> lseg_kind -> bool
(** The boolean is true when the pointer was dereferenced without testing for zero. *)
type zero_flag = bool option
(** True when the value was obtained by doing case analysis on null in a procedure call. *)
type null_case_flag = bool
(** instrumentation of heap values *)
type inst =
| Iabstraction
| Iactual_precondition
| Ialloc
| Iformal of zero_flag * null_case_flag
| Iinitial
| Ilookup
| Inone
| Inullify
| Irearrange of zero_flag * null_case_flag * int * PredSymb.path_pos
| Itaint
| Iupdate of zero_flag * null_case_flag * int * PredSymb.path_pos
| Ireturn_from_call of int
[@@deriving compare]
val equal_inst : inst -> inst -> bool
val inst_actual_precondition : inst
val inst_formal : inst
val inst_initial : inst
(** for formal parameters and heap values at the beginning of the function *)
val inst_lookup : inst
(** for initial values *)
val inst_none : inst
val inst_nullify : inst
val inst_rearrange : bool -> Location.t -> PredSymb.path_pos -> inst
(** the boolean indicates whether the pointer is known nonzero *)
val inst_update : Location.t -> PredSymb.path_pos -> inst
val inst_set_null_case_flag : inst -> inst
(** Set the null case flag of the inst. *)
val inst_new_loc : Location.t -> inst -> inst
(** update the location of the instrumentation *)
val update_inst : inst -> inst -> inst
(** Update [inst_old] to [inst_new] preserving the zero flag *)
exception JoinFail
val inst_partial_join : inst -> inst -> inst
(** join of instrumentations, can raise JoinFail *)
val inst_partial_meet : inst -> inst -> inst
(** meet of instrumentations *)
(** structured expressions represent a value of structured type, such as an array or a struct. *)
type 'inst strexp0 =
| Eexp of Exp.t * 'inst (** Base case: expression with instrumentation *)
| Estruct of (Typ.Fieldname.t * 'inst strexp0) list * 'inst (** C structure *)
| Earray of Exp.t * (Exp.t * 'inst strexp0) list * 'inst
(** Array of given length There are two conditions imposed / used in the array case. First, if
some index and value pair appears inside an array in a strexp, then the index is less than
the length of the array. For instance, [x |->\[10 | e1: v1\]] implies that [e1 <= 9].
Second, if two indices appear in an array, they should be different. For instance,
[x |->\[10 | e1: v1, e2: v2\]] implies that [e1 != e2]. *)
[@@deriving compare]
type strexp = inst strexp0
val compare_strexp : ?inst:bool -> strexp -> strexp -> int
(** Comparison function for strexp. The inst:: parameter specifies whether instumentations should
also be considered (false by default). *)
val equal_strexp : ?inst:bool -> strexp -> strexp -> bool
(** Equality function for strexp. The inst:: parameter specifies whether instumentations should also
be considered (false by default). *)
(** an atomic heap predicate *)
type 'inst hpred0 =
| Hpointsto of Exp.t * 'inst strexp0 * Exp.t
(** represents [exp|->strexp:typexp] where [typexp] is an expression representing a type, e.h.
[sizeof(t)]. *)
| Hlseg of lseg_kind * 'inst hpara0 * Exp.t * Exp.t * Exp.t list
(** higher - order predicate for singly - linked lists. Should ensure that exp1!= exp2 implies
that exp1 is allocated. 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. *)
| Hdllseg of lseg_kind * 'inst hpara_dll0 * Exp.t * Exp.t * Exp.t * Exp.t * Exp.t list
(** higher-order predicate for doubly-linked lists. Parameter for the higher-order
singly-linked list predicate. Means "lambda (root,next,svars). Exists evars. body". Assume
that root, next, svars, evars are disjoint sets of primed identifiers, and include all the
free primed identifiers in body. body should not contain any non - primed identifiers or
program variables (i.e. pvars). *)
[@@deriving compare]
and 'inst hpara0 =
{root: Ident.t; next: Ident.t; svars: Ident.t list; evars: Ident.t list; body: 'inst hpred0 list}
[@@deriving compare]
(** parameter for the higher-order doubly-linked list predicates. Assume that all the free
identifiers in body_dll should belong to cell, blink, flink, svars_dll, evars_dll. *)
and 'inst hpara_dll0 =
{ cell: Ident.t (** address cell *)
; blink: Ident.t (** backward link *)
; flink: Ident.t (** forward link *)
; svars_dll: Ident.t list
; evars_dll: Ident.t list
; body_dll: 'inst hpred0 list }
[@@deriving compare]
type hpred = inst hpred0
type hpara = inst hpara0
type hpara_dll = inst hpara_dll0
val compare_hpred : ?inst:bool -> hpred -> hpred -> int
(** Comparison function for hpred. The inst:: parameter specifies whether instumentations should
also be considered (false by default). *)
val equal_hpred : ?inst:bool -> hpred -> hpred -> bool
(** Equality function for hpred. The inst:: parameter specifies whether instumentations should also
be considered (false by default). *)
module HpredSet : Caml.Set.S with type elt = hpred
(** Sets of heap predicates *)
(** {2 Compaction} *)
type sharing_env
val create_sharing_env : unit -> sharing_env
(** Create a sharing env to store canonical representations *)
val hpred_compact : sharing_env -> hpred -> hpred
(** Return a compact representation of the exp *)
val is_objc_object : hpred -> bool
(** {2 Comparision And Inspection Functions} *)
val pp_offset : Pp.env -> F.formatter -> offset -> unit
val d_offset_list : offset list -> unit
(** Dump a list of offsets *)
val pp_atom : Pp.env -> F.formatter -> atom -> unit
(** Pretty print an atom. *)
val d_atom : atom -> unit
(** Dump an atom. *)
val pp_inst : F.formatter -> inst -> unit
(** pretty-print an inst *)
val pp_sexp : Pp.env -> F.formatter -> strexp -> unit
(** Pretty print a strexp. *)
val d_sexp : strexp -> unit
(** Dump a strexp. *)
val pp_hpred : Pp.env -> F.formatter -> hpred -> unit
(** Pretty print a hpred. *)
val d_hpred : hpred -> unit
(** Dump a hpred. *)
val pp_hpara : Pp.env -> F.formatter -> hpara -> unit
(** Pretty print a hpara. *)
val pp_hpara_dll : Pp.env -> F.formatter -> hpara_dll -> unit
(** Pretty print a hpara_dll. *)
(** record the occurrences of predicates as parameters of (doubly -)linked lists and Epara. Provides
unique numbering for predicates and an iterator. *)
module Env : sig
(** predicate environment *)
type t
val mk_empty : unit -> t
(** create an empty predicate environment *)
val is_empty : t -> bool
(** return true if the environment is empty *)
val iter : t -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit
(** [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. *)
val process_hpred : t -> hpred -> unit
(** Process one hpred, updating the predicate environment *)
end
val pp_hpred_env : Pp.env -> Env.t option -> F.formatter -> hpred -> unit
(** Pretty print a hpred with optional predicate env *)
(** {2 Functions for traversing SIL data types} *)
val strexp_expmap : (Exp.t * inst option -> Exp.t * inst option) -> strexp -> strexp
(** Change exps in strexp using [f]. WARNING: the result might not be normalized. *)
val hpred_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred -> hpred
(** Change exps in hpred by [f]. WARNING: the result might not be normalized. *)
val hpred_instmap : (inst -> inst) -> hpred -> hpred
(** Change instrumentations in hpred using [f]. *)
val hpred_list_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred list -> hpred list
(** Change exps in hpred list by [f]. WARNING: the result might not be normalized. *)
val atom_expmap : (Exp.t -> Exp.t) -> atom -> atom
(** Change exps in atom by [f]. WARNING: the result might not be normalized. *)
val hpred_list_get_lexps : (Exp.t -> bool) -> hpred list -> Exp.t list
val hpred_entries : hpred -> Exp.t list
val atom_free_vars : atom -> Ident.t Sequence.t
val atom_gen_free_vars : atom -> (unit, Ident.t) Sequence.Generator.t
val hpred_free_vars : hpred -> Ident.t Sequence.t
val hpred_gen_free_vars : hpred -> (unit, Ident.t) Sequence.Generator.t
val hpara_shallow_free_vars : hpara -> Ident.t Sequence.t
val hpara_dll_shallow_free_vars : hpara_dll -> Ident.t Sequence.t
(** Variables in hpara_dll, excluding bound vars in the body *)
(** {2 Substitution} *)
type subst = private (Ident.t * Exp.t) list [@@deriving compare]
val equal_subst : subst -> subst -> bool
(** Equality for substitutions. *)
val subst_of_list : (Ident.t * Exp.t) list -> subst
(** Create a substitution from a list of pairs. For all (id1, e1), (id2, e2) in the input list, if
id1 = id2, then e1 = e2. *)
val subst_of_list_duplicates : (Ident.t * Exp.t) list -> subst
(** like subst_of_list, but allow duplicate ids and only keep the first occurrence *)
val sub_to_list : subst -> (Ident.t * Exp.t) list
(** Convert a subst to a list of pairs. *)
val sub_empty : subst
(** The empty substitution. *)
val is_sub_empty : subst -> bool
val sub_join : subst -> subst -> subst
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the
output is this common part. The second and third components are the remainder of [subst1] and
[subst2], respectively. *)
val sub_symmetric_difference : subst -> subst -> subst * subst * subst
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the
output is this common part. The second and third components are the remainder of [subst1] and
[subst2], respectively. *)
val sub_find : (Ident.t -> bool) -> subst -> Exp.t
(** [sub_find filter sub] returns the expression associated to the first identifier that satisfies
[filter]. Raise [Not_found] if there isn't one. *)
val sub_filter : (Ident.t -> bool) -> subst -> subst
(** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *)
val sub_filter_pair : subst -> f:(Ident.t * Exp.t -> bool) -> subst
(** [sub_filter_exp filter sub] restricts the domain of [sub] to the identifiers satisfying
[filter(id, sub(id))]. *)
val sub_range_partition : (Exp.t -> bool) -> subst -> subst * subst
(** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy
[filter]. *)
val sub_domain_partition : (Ident.t -> bool) -> subst -> subst * subst
(** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers
satisfy [filter]. *)
val sub_domain : subst -> Ident.t list
(** Return the list of identifiers in the domain of the substitution. *)
val sub_range : subst -> Exp.t list
(** Return the list of expressions in the range of the substitution. *)
val sub_range_map : (Exp.t -> Exp.t) -> subst -> subst
(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *)
val sub_map : (Ident.t -> Ident.t) -> (Exp.t -> Exp.t) -> subst -> subst
(** [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]. *)
val extend_sub : subst -> Ident.t -> Exp.t -> subst option
(** Extend substitution and return [None] if not possible. *)
val subst_free_vars : subst -> Ident.t Sequence.t
val subst_gen_free_vars : subst -> (unit, Ident.t) Sequence.Generator.t
(** substitution functions WARNING: these functions do not ensure that the results are normalized. *)
val exp_sub : subst -> Exp.t -> Exp.t
val atom_sub : subst -> atom -> atom
val instr_sub : subst -> Sil.instr -> Sil.instr
(** apply [subst] to all id's in [instr], including LHS id's *)
val hpred_sub : subst -> hpred -> hpred
(** {2 Functions for replacing occurrences of expressions.} *)
val exp_replace_exp : (Exp.t * Exp.t) list -> Exp.t -> Exp.t
val atom_replace_exp : (Exp.t * Exp.t) list -> atom -> atom
val hpred_replace_exp : (Exp.t * Exp.t) list -> hpred -> hpred
(** {2 Functions for constructing or destructing entities in this module} *)
val exp_get_offsets : Exp.t -> offset list
(** Compute the offset list of an expression *)
val exp_add_offsets : Exp.t -> offset list -> Exp.t
(** Add the offset list to an expression *)
val sigma_to_sigma_ne : hpred list -> (atom list * hpred list) list
val hpara_instantiate : hpara -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list
(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], [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\]] for some fresh [_zs'].*)
val hpara_dll_instantiate :
hpara_dll -> Exp.t -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list
(** [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], then the result of the
instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] for some fresh
[_zs'].*)
val custom_error : Pvar.t

413
infer/src/biabduction/Prop.ml
View File

File diff suppressed because it is too large Load Diff

33
infer/src/biabduction/Prop.mli
Unescape View File

@ -7,11 +7,10 @@
*)
open! IStd
open Predicates
(** Functions for Propositions (i.e., Symbolic Heaps) *)
open Sil
(** kind for normal props, i.e. normalized *)
type normal
@ -23,14 +22,14 @@ type sorted
(** Proposition. *)
type pi = Sil.atom list
type pi = atom list
type sigma = Sil.hpred list
type sigma = hpred list
(** the kind 'a should range over [normal] and [exposed] *)
type 'a t = private
{ sigma: sigma (** spatial part *)
; sub: Sil.subst (** substitution *)
; sub: subst (** substitution *)
; pi: pi (** pure part *)
; sigma_fp: sigma (** abduced spatial part *)
; pi_fp: pi (** abduced pure part *) }
@ -77,7 +76,7 @@ val prop_update_obj_sub : Pp.env -> 'a t -> Pp.env
val pp_prop : Pp.env -> Format.formatter -> 'a t -> unit
(** Pretty print a proposition. *)
val prop_pred_env : 'a t -> Sil.Predicates.env
val prop_pred_env : 'a t -> Predicates.Env.t
(** Create a predicate environment for a prop *)
val d_prop : 'a t -> unit
@ -119,16 +118,16 @@ val sigma_replace_exp : Tenv.t -> (Exp.t * Exp.t) list -> hpred list -> hpred li
(** {2 Normalization} *)
val mk_inequality : Tenv.t -> Exp.t -> Sil.atom
val mk_inequality : Tenv.t -> Exp.t -> atom
(** Turn an inequality expression into an atom *)
val atom_is_inequality : Sil.atom -> bool
val atom_is_inequality : atom -> bool
(** Return [true] if the atom is an inequality *)
val atom_exp_le_const : Sil.atom -> (Exp.t * IntLit.t) option
val atom_exp_le_const : atom -> (Exp.t * IntLit.t) option
(** If the atom is [e<=n] return [e,n] *)
val atom_const_lt_exp : Sil.atom -> (IntLit.t * Exp.t) option
val atom_const_lt_exp : atom -> (IntLit.t * Exp.t) option
(** If the atom is [n<e] return [n,e] *)
val exp_normalize_prop : ?destructive:bool -> Tenv.t -> 'a t -> Exp.t -> Exp.t
@ -138,7 +137,7 @@ val exp_normalize_prop : ?destructive:bool -> Tenv.t -> 'a t -> Exp.t -> Exp.t
If [destructive] is true then normalize more aggressively, which may lose some useful structure
or types. *)
val exp_normalize_noabs : Tenv.t -> Sil.subst -> Exp.t -> Exp.t
val exp_normalize_noabs : Tenv.t -> subst -> Exp.t -> Exp.t
(** Normalize the expression without abstracting complex subexpressions *)
val exp_collapse_consecutive_indices_prop : Typ.t -> Exp.t -> Exp.t
@ -184,18 +183,17 @@ val mk_pred : Tenv.t -> PredSymb.t -> Exp.t list -> atom
val mk_npred : Tenv.t -> PredSymb.t -> Exp.t list -> atom
(** Construct a negative pred. *)
val create_strexp_of_type :
Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> Sil.inst -> Sil.strexp
val create_strexp_of_type : Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> inst -> strexp
(** create a strexp of the given type, populating the structures if [expand_structs] is true *)
val mk_ptsto : Tenv.t -> Exp.t -> strexp -> Exp.t -> hpred
(** Construct a pointsto. *)
val mk_ptsto_exp : Tenv.t -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> Sil.inst -> hpred
val mk_ptsto_exp : Tenv.t -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> inst -> hpred
(** Construct a points-to predicate for an expression using either the provided expression [name] as
base for fresh identifiers. *)
val mk_ptsto_lvar : Tenv.t -> struct_init_mode -> Sil.inst -> Pvar.t * Exp.t * Exp.t option -> hpred
val mk_ptsto_lvar : Tenv.t -> struct_init_mode -> inst -> Pvar.t * Exp.t * Exp.t option -> hpred
(** Construct a points-to predicate for a single program variable. If [expand_structs] is true,
initialize the fields of structs with fresh variables. *)
@ -209,7 +207,7 @@ val mk_dllseg :
val prop_emp : normal t
(** Proposition [true /\ emp]. *)
val prop_reset_inst : (Sil.inst -> Sil.inst) -> 'a t -> exposed t
val prop_reset_inst : (inst -> inst) -> 'a t -> exposed t
(** Reset every inst in the prop using the given map *)
val prop_hpred_star : 'a t -> hpred -> exposed t
@ -260,8 +258,7 @@ val from_pi : pi -> exposed t
val from_sigma : sigma -> exposed t
(** Build an exposed prop from sigma *)
val set :
?sub:Sil.subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t
val set : ?sub:subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t
(** Set individual fields of the prop. *)
(** {2 Prop iterators} *)

45
infer/src/biabduction/PropUtil.ml
Unescape View File

@ -23,7 +23,7 @@ let get_name_of_objc_static_locals (curr_f : Procdesc.t) p =
[]
in
let hpred_local_static hpred =
match hpred with Sil.Hpointsto (e, _, _) -> [local_static e] | _ -> []
match hpred with Predicates.Hpointsto (e, _, _) -> [local_static e] | _ -> []
in
let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in
List.concat (List.concat vars_sigma)
@ -35,7 +35,7 @@ let get_name_of_objc_block_locals p =
match e with Exp.Lvar pvar when Pvar.is_block_pvar pvar -> [pvar] | _ -> []
in
let hpred_local_blocks hpred =
match hpred with Sil.Hpointsto (e, _, _) -> [local_blocks e] | _ -> []
match hpred with Predicates.Hpointsto (e, _, _) -> [local_blocks e] | _ -> []
in
let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in
List.concat (List.concat vars_sigma)
@ -45,32 +45,34 @@ let remove_abduced_retvars tenv p =
(* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *)
let compute_reachable p seed_exps =
let sigma, pi = (p.Prop.sigma, p.Prop.pi) in
let rec collect_exps exps = function
| Sil.Eexp (Exp.Exn e, _) ->
let rec collect_exps exps (sexp : Predicates.strexp) =
match sexp with
| Eexp (Exp.Exn e, _) ->
Exp.Set.add e exps
| Sil.Eexp (e, _) ->
| Eexp (e, _) ->
Exp.Set.add e exps
| Sil.Estruct (flds, _) ->
| Estruct (flds, _) ->
List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds
| Sil.Earray (_, elems, _) ->
| Earray (_, elems, _) ->
List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems
in
let rec compute_reachable_hpreds_rec sigma (reach, exps) =
let add_hpred_if_reachable (reach, exps) = function
| Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps ->
let reach' = Sil.HpredSet.add hpred reach in
let add_hpred_if_reachable (reach, exps) (hpred : Predicates.hpred) =
match hpred with
| Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps ->
let reach' = Predicates.HpredSet.add hpred reach in
let exps' = collect_exps exps rhs in
(reach', exps')
| Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in
| Hlseg (_, _, exp1, exp2, exp_l) as hpred ->
let reach' = Predicates.HpredSet.add hpred reach in
let exps' =
List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
~init:exps (exp1 :: exp2 :: exp_l)
in
(reach', exps')
| Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in
| Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred ->
let reach' = Predicates.HpredSet.add hpred reach in
let exps' =
List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
@ -82,11 +84,12 @@ let remove_abduced_retvars tenv p =
(reach, exps)
in
let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma in
if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps)
if Int.equal (Predicates.HpredSet.cardinal reach) (Predicates.HpredSet.cardinal reach') then
(reach, exps)
else compute_reachable_hpreds_rec sigma (reach', exps')
in
let reach_hpreds, reach_exps =
compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, seed_exps)
compute_reachable_hpreds_rec sigma (Predicates.HpredSet.empty, seed_exps)
in
(* filter away the pure atoms without reachable exps *)
let reach_pi =
@ -102,20 +105,20 @@ let remove_abduced_retvars tenv p =
in
List.filter
~f:(function
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) ->
| Predicates.Aeq (lhs, rhs) | Predicates.Aneq (lhs, rhs) ->
exp_contains lhs || exp_contains rhs
| Sil.Apred (_, es) | Sil.Anpred (_, es) ->
| Predicates.Apred (_, es) | Predicates.Anpred (_, es) ->
List.exists ~f:exp_contains es )
pi
in
(Sil.HpredSet.elements reach_hpreds, reach_pi)
(Predicates.HpredSet.elements reach_hpreds, reach_pi)
in
(* separate the abduced pvars from the normal ones, deallocate the abduced ones*)
let abduceds, normal_pvars =
List.fold
~f:(fun pvars hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
let abduceds, normal_pvars = pvars in
if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars)
else (abduceds, pvar :: normal_pvars)
@ -180,7 +183,7 @@ let remove_locals_formals tenv (curr_f : Procdesc.t) p =
(** remove seed vars from a prop *)
let remove_seed_vars tenv (prop : 'a Prop.t) : Prop.normal Prop.t =
let hpred_not_seed = function
| Sil.Hpointsto (Exp.Lvar pv, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pv, _, _) ->
not (Pvar.is_seed pv)
| _ ->
true

40
infer/src/biabduction/Propgraph.ml
Unescape View File

@ -17,7 +17,7 @@ type 'a t = 'a Prop.t
type sub_entry = Ident.t * Exp.t
type edge = Ehpred of Sil.hpred | Eatom of Sil.atom | Esub_entry of sub_entry
type edge = Ehpred of Predicates.hpred | Eatom of Predicates.atom | Esub_entry of sub_entry
let from_prop p = p
@ -26,19 +26,19 @@ let edge_is_hpred = function Ehpred _ -> true | Eatom _ -> false | Esub_entry _
(** Return the source of the edge *)
let edge_get_source = function
| Ehpred (Sil.Hpointsto (e, _, _)) ->
| Ehpred (Hpointsto (e, _, _)) ->
Some e
| Ehpred (Sil.Hlseg (_, _, e, _, _)) ->
| Ehpred (Hlseg (_, _, e, _, _)) ->
Some e
| Ehpred (Sil.Hdllseg (_, _, e1, _, _, _, _)) ->
| Ehpred (Hdllseg (_, _, e1, _, _, _, _)) ->
Some e1 (* only one direction supported for now *)
| Eatom (Sil.Aeq (e1, _)) ->
| Eatom (Aeq (e1, _)) ->
Some e1
| Eatom (Sil.Aneq (e1, _)) ->
| Eatom (Aneq (e1, _)) ->
Some e1
| Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) ->
| Eatom (Apred (_, e :: _) | Anpred (_, e :: _)) ->
Some e
| Eatom (Sil.Apred (_, []) | Anpred (_, [])) ->
| Eatom (Apred (_, []) | Anpred (_, [])) ->
None
| Esub_entry (x, _) ->
Some (Exp.Var x)
@ -48,7 +48,7 @@ let get_sigma footprint_part g = if footprint_part then g.Prop.sigma_fp else g.P
let get_pi footprint_part g = if footprint_part then g.Prop.pi_fp else g.Prop.pi
let get_subl footprint_part g = if footprint_part then [] else Sil.sub_to_list g.Prop.sub
let get_subl footprint_part g = if footprint_part then [] else Predicates.sub_to_list g.Prop.sub
(** [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]
@ -80,9 +80,9 @@ let get_edges footprint_part g =
let edge_equal e1 e2 =
match (e1, e2) with
| Ehpred hp1, Ehpred hp2 ->
Sil.equal_hpred hp1 hp2
Predicates.equal_hpred hp1 hp2
| Eatom a1, Eatom a2 ->
Sil.equal_atom a1 a2
Predicates.equal_atom a1 a2
| Esub_entry (x1, e1), Esub_entry (x2, e2) ->
Ident.equal x1 x2 && Exp.equal e1 e2
| _ ->
@ -109,13 +109,13 @@ let compute_exp_diff (e1 : Exp.t) (e2 : Exp.t) : Obj.t list =
(** Compute the subobjects in [se2] which are different from those in [se1] *)
let rec compute_sexp_diff (se1 : Sil.strexp) (se2 : Sil.strexp) : Obj.t list =
let rec compute_sexp_diff (se1 : Predicates.strexp) (se2 : Predicates.strexp) : Obj.t list =
match (se1, se2) with
| Sil.Eexp (e1, _), Sil.Eexp (e2, _) ->
| Eexp (e1, _), Eexp (e2, _) ->
if Exp.equal e1 e2 then [] else [Obj.repr se2]
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) ->
| Estruct (fsel1, _), Estruct (fsel2, _) ->
compute_fsel_diff fsel1 fsel2
| Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) ->
| Earray (e1, esel1, _), Earray (e2, esel2, _) ->
compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2
| _ ->
[Obj.repr se2]
@ -156,14 +156,14 @@ and compute_esel_diff esel1 esel2 : Obj.t list =
(** Compute the subobjects in [newedge] which are different from those in [oldedge] *)
let compute_edge_diff (oldedge : edge) (newedge : edge) : Obj.t list =
match (oldedge, newedge) with
| Ehpred (Sil.Hpointsto (_, se1, e1)), Ehpred (Sil.Hpointsto (_, se2, e2)) ->
| Ehpred (Hpointsto (_, se1, e1)), Ehpred (Hpointsto (_, se2, e2)) ->
compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2
| Eatom (Sil.Aeq (_, e1)), Eatom (Sil.Aeq (_, e2)) ->
| Eatom (Aeq (_, e1)), Eatom (Aeq (_, e2)) ->
compute_exp_diff e1 e2
| Eatom (Sil.Aneq (_, e1)), Eatom (Sil.Aneq (_, e2)) ->
| Eatom (Aneq (_, e1)), Eatom (Aneq (_, e2)) ->
compute_exp_diff e1 e2
| Eatom (Sil.Apred (_, es1)), Eatom (Sil.Apred (_, es2))
| Eatom (Sil.Anpred (_, es1)), Eatom (Sil.Anpred (_, es2)) ->
| Eatom (Apred (_, es1)), Eatom (Apred (_, es2))
| Eatom (Anpred (_, es1)), Eatom (Anpred (_, es2)) ->
List.concat (try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> [])
| Esub_entry (_, e1), Esub_entry (_, e2) ->
compute_exp_diff e1 e2

512
infer/src/biabduction/Prover.ml
View File

File diff suppressed because it is too large Load Diff

23
infer/src/biabduction/Prover.mli
Unescape View File

@ -10,9 +10,9 @@ open! IStd
(** Functions for Theorem Proving *)
open Sil
open Predicates
val atom_negate : Tenv.t -> Sil.atom -> Sil.atom
val atom_negate : Tenv.t -> atom -> atom
(** Negate an atom *)
(** {2 Ordinary Theorem Proving} *)
@ -49,7 +49,7 @@ val is_root : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> offset list opti
[offlist]. If so, it returns [Some(offlist)]. Otherwise, it returns [None]. Assumes that
[base_exp] points to the beginning of a structure, not the middle. *)
val expand_hpred_pointer : Tenv.t -> bool -> Sil.hpred -> bool * bool * Sil.hpred
val expand_hpred_pointer : Tenv.t -> bool -> hpred -> bool * bool * hpred
(** [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. *)
@ -70,13 +70,13 @@ val d_typings : (Exp.t * Exp.t) list -> unit
type implication_result =
| ImplOK of
( check list
* Sil.subst
* Sil.subst
* Sil.hpred list
* Sil.atom list
* Sil.hpred list
* Sil.hpred list
* Sil.hpred list
* subst
* subst
* hpred list
* atom list
* hpred list
* hpred list
* hpred list
* (Exp.t * Exp.t) list
* (Exp.t * Exp.t) list )
| ImplFail of check list
@ -89,8 +89,7 @@ val check_implication_for_footprint :
(** {2 Cover: minimum set of pi's whose disjunction is equivalent to true} *)
val find_minimum_pure_cover :
Tenv.t -> (Sil.atom list * 'a) list -> (Sil.atom list * 'a) list option
val find_minimum_pure_cover : Tenv.t -> (atom list * 'a) list -> (atom list * 'a) list option
(** Find minimum set of pi's in [cases] whose disjunction covers true *)
(** {2 Subtype checking} *)

265
infer/src/biabduction/Rearrange.ml
Unescape View File

@ -78,7 +78,7 @@ let bounds_check tenv pname prop len e =
let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (t : Typ.t)
(off : Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t =
(off : Predicates.offset list) inst : Predicates.atom list * Predicates.strexp * Typ.t =
if Config.trace_rearrange then (
L.d_increase_indent () ;
L.d_strln "entering create_struct_values" ;
@ -86,7 +86,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
Typ.d_full t ;
L.d_ln () ;
L.d_str "off: " ;
Sil.d_offset_list off ;
Predicates.d_offset_list off ;
L.d_ln () ;
L.d_ln () ) ;
let new_id () = incr max_stamp ; Ident.create kind !max_stamp in
@ -95,13 +95,13 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
L.d_str "create_struct_values type:" ;
Typ.d_full t ;
L.d_str " off: " ;
Sil.d_offset_list off ;
Predicates.d_offset_list off ;
L.d_ln () ;
raise (Exceptions.Bad_footprint pos)
in
match (t.desc, off) with
| Tstruct _, [] ->
([], Sil.Estruct ([], inst), t)
([], Predicates.Estruct ([], inst), t)
| Tstruct name, Off_fld (f, _) :: off' -> (
match Tenv.lookup tenv name with
| Some ({fields; statics} as struct_typ) -> (
@ -110,7 +110,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
let atoms', se', res_t' =
create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in
let se = Sil.Estruct ([(f, se')], inst) in
let se = Predicates.Estruct ([(f, se')], inst) in
let replace_typ_of_f (f', t', a') =
if Typ.Fieldname.equal f f' then (f, res_t', a') else (f', t', a')
in
@ -129,30 +129,30 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
in
let e' = Absarray.array_clean_new_index footprint_part e in
let len = Exp.Var (new_id ()) in
let se = Sil.Earray (len, [(e', se')], inst) in
let se = Predicates.Earray (len, [(e', se')], inst) in
let res_t = Typ.mk_array res_t' in
(Sil.Aeq (e, e') :: atoms', se, res_t)
(Predicates.Aeq (e, e') :: atoms', se, res_t)
| Tarray {elt= t'; length; stride}, off -> (
let len =
match length with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len)
in
match off with
| [] ->
([], Sil.Earray (len, [], inst), t)
| Sil.Off_index e :: off' ->
([], Predicates.Earray (len, [], inst), t)
| Predicates.Off_index e :: off' ->
bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ;
let atoms', se', res_t' =
create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in
let e' = Absarray.array_clean_new_index footprint_part e in
let se = Sil.Earray (len, [(e', se')], inst) in
let se = Predicates.Earray (len, [(e', se')], inst) in
let res_t = Typ.mk_array ~default:t res_t' ?length ?stride in
(Sil.Aeq (e, e') :: atoms', se, res_t)
| Sil.Off_fld _ :: _ ->
(Predicates.Aeq (e, e') :: atoms', se, res_t)
| Predicates.Off_fld _ :: _ ->
assert false )
| Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun, [] | Tptr _, [] | TVar _, [] ->
let id = new_id () in
([], Sil.Eexp (Exp.Var id, inst), t)
([], Predicates.Eexp (Exp.Var id, inst), t)
| (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _ | TVar _), Off_index e :: off' ->
(* In this case, we lift t to the t array. *)
let t', mk_typ_f =
@ -167,16 +167,16 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in
let e' = Absarray.array_clean_new_index footprint_part e in
let se = Sil.Earray (len, [(e', se')], inst) in
let se = Predicates.Earray (len, [(e', se')], inst) in
let res_t = mk_typ_f (Tarray {elt= res_t'; length= None; stride= None}) in
(Sil.Aeq (e, e') :: atoms', se, res_t)
(Predicates.Aeq (e, e') :: atoms', se, res_t)
| Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun, _ | Tptr _, _ | TVar _, _ ->
fail t off __POS__
in
if Config.trace_rearrange then (
let _, se, _ = res in
L.d_strln "exiting create_struct_values, returning" ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_decrease_indent () ;
L.d_ln () ;
L.d_ln () ) ;
@ -189,18 +189,18 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
If we want to implement the checks for array bounds errors,
we need to change this function. *)
let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se (typ : Typ.t)
(off : Sil.offset list) inst =
(off : Predicates.offset list) inst =
let new_id () = incr max_stamp ; Ident.create kind !max_stamp in
match (off, se, typ.desc) with
| [], Sil.Eexp _, _ | [], Sil.Estruct _, _ ->
| [], Predicates.Eexp _, _ | [], Predicates.Estruct _, _ ->
[([], se, typ)]
| [], Sil.Earray _, _ ->
let off_new = Sil.Off_index Exp.zero :: off in
| [], Predicates.Earray _, _ ->
let off_new = Predicates.Off_index Exp.zero :: off in
strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
| Off_fld _ :: _, Sil.Earray _, Tarray _ ->
let off_new = Sil.Off_index Exp.zero :: off in
| Off_fld _ :: _, Predicates.Earray _, Tarray _ ->
let off_new = Predicates.Off_index Exp.zero :: off in
strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
| Off_fld (f, _) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> (
| Off_fld (f, _) :: off', Predicates.Estruct (fsel, inst'), Tstruct name -> (
match Tenv.lookup tenv name with
| Some ({fields; statics} as struct_typ) -> (
match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with
@ -216,7 +216,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp
if Typ.Fieldname.equal f1 f then (f1, res_se') else ft1
in
let res_fsel' =
List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp]
List.sort ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp]
(List.map ~f:replace_fse fsel)
in
let replace_fta ((f1, _, a1) as fta1) =
@ -226,7 +226,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp
List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields)
in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
(res_atoms', Sil.Estruct (res_fsel', inst'), typ) :: acc
(res_atoms', Predicates.Estruct (res_fsel', inst'), typ) :: acc
in
List.fold ~f:replace ~init:[] atoms_se_typ_list'
| None ->
@ -234,7 +234,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp
create_struct_values pname tenv orig_prop footprint_part kind max_stamp typ' off' inst
in
let res_fsel' =
List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] ((f, se') :: fsel)
List.sort ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp] ((f, se') :: fsel)
in
let replace_fta (f', t', a') =
if Typ.Fieldname.equal f' f then (f, res_typ', a') else (f', t', a')
@ -243,30 +243,30 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp
List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields)
in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
[(atoms', Sil.Estruct (res_fsel', inst'), typ)] )
[(atoms', Predicates.Estruct (res_fsel', inst'), typ)] )
| None ->
raise (Exceptions.Missing_fld (f, __POS__)) )
| None ->
raise (Exceptions.Missing_fld (f, __POS__)) )
| Off_fld _ :: _, _, _ ->
raise (Exceptions.Bad_footprint __POS__)
| Off_index _ :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _)
| Off_index _ :: _, Sil.Estruct _, Tstruct _ ->
| Off_index _ :: _, Predicates.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _)
| Off_index _ :: _, Predicates.Estruct _, Tstruct _ ->
(* L.d_strln ~color:Orange "turn into an array"; *)
let len =
match se with
| Sil.Eexp (_, Sil.Ialloc) ->
| Predicates.Eexp (_, Predicates.Ialloc) ->
Exp.one (* if allocated explicitly, we know len is 1 *)
| _ ->
if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *)
else Exp.Var (new_id ())
in
let se_new = Sil.Earray (len, [(Exp.zero, se)], inst) in
let se_new = Predicates.Earray (len, [(Exp.zero, se)], inst) in
let typ_new = Typ.mk_array typ in
strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off
inst
| ( Off_index e :: off'
, Sil.Earray (len, esel, inst_arr)
, Predicates.Earray (len, esel, inst_arr)
, Tarray {elt= typ'; length= len_for_typ'; stride} ) -> (
bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ;
match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with
@ -280,7 +280,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp
let res_esel' = List.map ~f:replace_ise esel in
if Typ.equal res_typ' typ' || Int.equal (List.length res_esel') 1 then
( res_atoms'
, Sil.Earray (len, res_esel', inst_arr)
, Predicates.Earray (len, res_esel', inst_arr)
, Typ.mk_array ~default:typ res_typ' ?length:len_for_typ' ?stride )
:: acc
else raise (Exceptions.Bad_footprint __POS__)
@ -310,7 +310,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
false
in
if index_in_array then
let array_default = Sil.Earray (array_len, array_cont, inst_arr) in
let array_default = Predicates.Earray (array_len, array_cont, inst_arr) in
let typ_default = Typ.mk_array ~default:typ_array typ_cont ?length:typ_array_len in
[([], array_default, typ_default)]
else if !BiabductionConfig.footprint then (
@ -319,9 +319,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
in
check_sound elem_typ ;
let cont_new =
List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont)
List.sort ~compare:[%compare: Exp.t * Predicates.strexp] ((index, elem_se) :: array_cont)
in
let array_new = Sil.Earray (array_len, cont_new, inst_arr) in
let array_new = Predicates.Earray (array_len, cont_new, inst_arr) in
let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in
[(atoms, array_new, typ_new)] )
else
@ -333,9 +333,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
in
check_sound elem_typ ;
let cont_new =
List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont)
List.sort ~compare:[%compare: Exp.t * Predicates.strexp] ((index, elem_se) :: array_cont)
in
let array_new = Sil.Earray (array_len, cont_new, inst_arr) in
let array_new = Predicates.Earray (array_len, cont_new, inst_arr) in
let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in
[(atoms, array_new, typ_new)]
in
@ -351,9 +351,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
List.fold
~f:(fun acc' (atoms', se', typ') ->
check_sound typ' ;
let atoms_new = Sil.Aeq (index, i) :: atoms' in
let atoms_new = Predicates.Aeq (index, i) :: atoms' in
let isel_new = list_rev_and_concat isel_seen_rev ((i, se') :: isel_unseen) in
let array_new = Sil.Earray (array_len, isel_new, inst_arr) in
let array_new = Predicates.Earray (array_len, isel_new, inst_arr) in
let typ_new = Typ.mk_array ~default:typ_array typ' ?length:typ_array_len in
(atoms_new, array_new, typ_new) :: acc' )
~init:[] atoms_se_typ_list
@ -372,10 +372,10 @@ let laundry_offset_for_footprint max_stamp offs_in =
match offs with
| [] ->
(List.rev offs_seen, List.rev eqs)
| (Sil.Off_fld _ as off) :: offs' ->
| (Predicates.Off_fld _ as off) :: offs' ->
let offs_seen' = off :: offs_seen in
laundry offs_seen' eqs offs'
| (Sil.Off_index idx as off) :: offs' ->
| (Predicates.Off_index idx as off) :: offs' ->
if exp_has_only_footprint_ids idx then
let offs_seen' = off :: offs_seen in
laundry offs_seen' eqs offs'
@ -383,7 +383,7 @@ let laundry_offset_for_footprint max_stamp offs_in =
let () = incr max_stamp in
let fid_new = Ident.create Ident.kfootprint !max_stamp in
let exp_new = Exp.Var fid_new in
let off_new = Sil.Off_index exp_new in
let off_new = Predicates.Off_index exp_new in
let offs_seen' = off_new :: offs_seen in
let eqs' = (fid_new, idx) :: eqs in
laundry offs_seen' eqs' offs'
@ -392,7 +392,7 @@ let laundry_offset_for_footprint max_stamp offs_in =
let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se te
(off : Sil.offset list) inst =
(off : Predicates.offset list) inst =
let typ = Exp.texp_to_typ None te in
let off', laundry_atoms =
let off', eqs = laundry_offset_for_footprint max_stamp off in
@ -402,11 +402,11 @@ let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se t
in
if Config.trace_rearrange then (
L.d_str "entering strexp_extend_values se: " ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_str " typ: " ;
Typ.d_full typ ;
L.d_str " off': " ;
Sil.d_offset_list off' ;
Predicates.d_offset_list off' ;
L.d_strln (if footprint_part then " FP" else " RE") ) ;
let atoms_se_typ_list =
strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off' inst
@ -432,13 +432,13 @@ let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se t
let collect_root_offset exp =
let root = Exp.root_of_lexp exp in
let offsets = Sil.exp_get_offsets exp in
let offsets = Predicates.exp_get_offsets exp in
(root, offsets)
(** Exp.Construct a points-to predicate for an expression, to add to a footprint. *)
let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst :
Sil.hpred * Sil.hpred * Sil.atom list =
Predicates.hpred * Predicates.hpred * Predicates.atom list =
let root, off = collect_root_offset lexp in
if not (exp_has_only_footprint_ids root) then
if
@ -463,7 +463,7 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst :
let fun_exp = Exp.Const (Const.Cfun fun_name) in
( []
, Prop.mk_ptsto tenv root
(Sil.Eexp (fun_exp, inst))
(Predicates.Eexp (fun_exp, inst))
(Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) )
| _, [], Typ.Tfun ->
let atoms, se, typ =
@ -483,8 +483,8 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst :
)
in
let atoms, ptsto_foot = create_ptsto true off_foot in
let sub = Sil.subst_of_list eqs in
let ptsto = Sil.hpred_sub sub ptsto_foot in
let sub = Predicates.subst_of_list eqs in
let ptsto = Predicates.hpred_sub sub ptsto_foot in
let atoms' = List.map ~f:(fun (id, e) -> Prop.mk_eq tenv (Exp.Var id) e) eqs in
(ptsto, ptsto_foot, atoms @ atoms')
@ -492,10 +492,10 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst :
(** 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. *)
let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
let offset = Sil.exp_get_offsets lexp in
let offset = Predicates.exp_get_offsets lexp in
let _, se, _ =
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, t), _ ->
| Predicates.Hpointsto (e, se, t), _ ->
(e, se, t)
| _ ->
assert false
@ -503,9 +503,9 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
let rec check_offset se = function
| [] ->
None
| Sil.Off_fld (fld, _) :: off' -> (
| Predicates.Off_fld (fld, _) :: off' -> (
match se with
| Sil.Estruct (fsel, _) -> (
| Predicates.Estruct (fsel, _) -> (
match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with
| Some (_, se') ->
check_offset se' off'
@ -513,7 +513,7 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
Some fld )
| _ ->
Some fld )
| Sil.Off_index _ :: _ ->
| Predicates.Off_index _ :: _ ->
None
in
check_offset se offset
@ -528,36 +528,37 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
L.d_str "entering prop_iter_extend_ptsto lexp: " ;
Exp.d_exp lexp ;
L.d_ln () ) ;
let offset = Sil.exp_get_offsets lexp in
let offset = Predicates.exp_get_offsets lexp in
let max_stamp = Prop.prop_iter_max_stamp iter in
let extend_footprint_pred = function
| Sil.Hpointsto (e, se, te) ->
| Predicates.Hpointsto (e, se, te) ->
let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se te
offset inst
in
List.map
~f:(fun (atoms', se', te') -> (atoms', Sil.Hpointsto (e, se', te')))
~f:(fun (atoms', se', te') -> (atoms', Predicates.Hpointsto (e, se', te')))
atoms_se_te_list
| Sil.Hlseg (k, hpara, e1, e2, el) -> (
match hpara.Sil.body with
| Sil.Hpointsto (e', se', te') :: body_rest ->
| Predicates.Hlseg (k, hpara, e1, e2, el) -> (
match hpara.Predicates.body with
| Predicates.Hpointsto (e', se', te') :: body_rest ->
let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se' te'
offset inst
in
let atoms_body_list =
List.map
~f:(fun (atoms0, se0, te0) -> (atoms0, Sil.Hpointsto (e', se0, te0) :: body_rest))
~f:(fun (atoms0, se0, te0) ->
(atoms0, Predicates.Hpointsto (e', se0, te0) :: body_rest) )
atoms_se_te_list
in
let atoms_hpara_list =
List.map
~f:(fun (atoms, body') -> (atoms, {hpara with Sil.body= body'}))
~f:(fun (atoms, body') -> (atoms, {hpara with Predicates.body= body'}))
atoms_body_list
in
List.map
~f:(fun (atoms, hpara') -> (atoms, Sil.Hlseg (k, hpara', e1, e2, el)))
~f:(fun (atoms, hpara') -> (atoms, Predicates.Hlseg (k, hpara', e1, e2, el)))
atoms_hpara_list
| _ ->
assert false )
@ -568,7 +569,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let iter' =
List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms
in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se, te))
Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se, te))
in
let do_extend e se te =
if Config.trace_rearrange then (
@ -576,7 +577,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
L.d_str "e: " ;
Exp.d_exp e ;
L.d_str " se : " ;
Sil.d_sexp se ;
Predicates.d_sexp se ;
L.d_str " te: " ;
Exp.d_texp_full te ;
L.d_ln () ;
@ -608,11 +609,11 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let sigma_pto, sigma_rest =
List.partition_tf
~f:(function
| Sil.Hpointsto (e', _, _) ->
| Predicates.Hpointsto (e', _, _) ->
Exp.equal e e'
| Sil.Hlseg (_, _, e1, _, _) ->
| Predicates.Hlseg (_, _, e1, _, _) ->
Exp.equal e e1
| Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) ->
| Predicates.Hdllseg (_, _, e_iF, _, _, e_iB, _) ->
Exp.equal e e_iF || Exp.equal e e_iB )
footprint_sigma
in
@ -630,7 +631,8 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
[([], footprint_sigma)]
in
List.map
~f:(fun (atoms, sigma') -> (atoms, List.stable_sort ~compare:Sil.compare_hpred sigma'))
~f:(fun (atoms, sigma') ->
(atoms, List.stable_sort ~compare:Predicates.compare_hpred sigma') )
atoms_sigma_list
in
let iter_atoms_fp_sigma_list = list_product iter_list atoms_fp_sigma_list in
@ -660,7 +662,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
res_iter_list
in
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, te), _ ->
| Predicates.Hpointsto (e, se, te), _ ->
do_extend e se te
| _ ->
assert false
@ -695,7 +697,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
| Some iter ->
Prop.prop_iter_prev_then_insert iter ptsto
in
let offsets_default = Sil.exp_get_offsets lexp in
let offsets_default = Predicates.exp_get_offsets lexp in
Prop.prop_iter_set_state iter offsets_default
@ -817,10 +819,10 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
false
in
match get_fld_strexp_and_typ typ typ_matches_guarded_by flds with
| Some (Sil.Eexp (matching_exp, _), _) ->
| Some (Predicates.Eexp (matching_exp, _), _) ->
List.find_map
~f:(function
| Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ})
| Predicates.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ})
when Exp.equal lhs_exp matching_exp ->
get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds
| _ ->
@ -835,11 +837,12 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
~f:(fun hpred ->
(* FIXME: silenced warning may be legit *)
match[@warning "-57"] hpred with
| Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ})
| Sil.Hpointsto (_, Sil.Eexp ((Const (Cclass clazz) as lhs_exp), _), Exp.Sizeof {typ})
| Predicates.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ})
| Predicates.Hpointsto
(_, Predicates.Eexp ((Const (Cclass clazz) as lhs_exp), _), Exp.Sizeof {typ})
when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) ->
Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ)
| Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> (
Some (Predicates.Eexp (lhs_exp, Predicates.inst_none), typ)
| Predicates.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> (
(* first, try to find a field that exactly matches the guarded-by string *)
match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with
| None when guarded_by_str_is_this guarded_by_str0 ->
@ -852,7 +855,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
match_on_field_type typ flds
| Some _ as res_opt ->
res_opt )
| Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof {typ})
| Predicates.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof {typ})
when ( guarded_by_str_is_current_class_this guarded_by_str0 pname
|| guarded_by_str_is_super_class_this guarded_by_str0 pname )
&& Pvar.is_this pvar ->
@ -915,7 +918,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
false )
|| (* or the prop says we already have the lock *)
List.exists
~f:(function Sil.Apred (Alocked, _) -> true | _ -> false)
~f:(function Predicates.Apred (Alocked, _) -> true | _ -> false)
(Attribute.get_for_exp tenv prop guarded_by_exp)
in
let guardedby_is_self_referential =
@ -937,13 +940,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
let is_accessible_through_local_ref exp =
List.exists
~f:(function
| Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) ->
| Predicates.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) ->
Exp.equal exp rhs_exp
| Sil.Hpointsto (_, Estruct (flds, _), _) ->
| Predicates.Hpointsto (_, Estruct (flds, _), _) ->
List.exists
~f:(fun (fld, strexp) ->
match strexp with
| Sil.Eexp (rhs_exp, _) ->
| Predicates.Eexp (rhs_exp, _) ->
Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld)
| _ ->
false )
@ -965,7 +968,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
&& not (proc_has_suppress_guarded_by_annot pdesc)
in
match find_guarded_by_exp guarded_by_str prop.Prop.sigma with
| Some (Sil.Eexp (guarded_by_exp, _), typ) ->
| Some (Predicates.Eexp (guarded_by_exp, _), typ) ->
if is_read_write_lock typ then
(* TODO: model/understand read-write locks rather than ignoring them *)
prop
@ -1006,13 +1009,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
in
let check_fld_locks typ prop_acc (fld, strexp) =
match strexp with
| Sil.Eexp (exp, _) when Exp.equal exp lexp ->
| Predicates.Eexp (exp, _) when Exp.equal exp lexp ->
enforce_guarded_access fld typ prop_acc
| _ ->
prop_acc
in
let hpred_check_flds prop_acc = function
| Sil.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) ->
| Predicates.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) ->
List.fold ~f:(check_fld_locks typ) ~init:prop_acc flds
| _ ->
prop_acc
@ -1053,7 +1056,7 @@ let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst =
List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter_foot atoms
in
let iter' = Prop.prop_iter_replace_footprint_sigma iter_foot_atoms sigma_fp in
let offsets_default = Sil.exp_get_offsets lexp in
let offsets_default = Predicates.exp_get_offsets lexp in
Prop.prop_iter_set_state iter' offsets_default
@ -1117,7 +1120,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
else (
check_field_splitting () ;
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, te), offset ->
| Predicates.Hpointsto (e, se, te), offset ->
let max_stamp = Prop.prop_iter_max_stamp iter in
let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop false Ident.kprimed (ref max_stamp) se te
@ -1127,7 +1130,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
let iter' =
List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms'
in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se', te'))
Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se', te'))
in
let filter it =
let p = Prop.prop_iter_to_prop tenv it in
@ -1151,20 +1154,20 @@ let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist =
if Config.nelseg then
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_NE para n' e2 elist] in
let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_NE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_base_case =
let _, para_inst = Sil.hpara_instantiate para e1 e2 elist in
let _, para_inst = Predicates.hpara_instantiate para e1 e2 elist in
Prop.prop_iter_update_current_by_list iter para_inst
in
recurse_on_iters [iter_inductive_case; iter_base_case]
else
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in
let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_PE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
recurse_on_iters [iter_inductive_case]
@ -1174,14 +1177,12 @@ let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist =
let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 =
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll n' e1 e3 e4 elist]
in
let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll n' e1 e3 e4 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_base_case =
let _, para_dll_inst = Sil.hpara_dll_instantiate para_dll e1 e2 e3 elist in
let _, para_dll_inst = Predicates.hpara_dll_instantiate para_dll e1 e2 e3 elist in
let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in
let prop' = Prop.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' in
@ -1194,14 +1195,12 @@ let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3
let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 =
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll e1 e2 e4 n' elist]
in
let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll e1 e2 e4 n' elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_base_case =
let _, para_dll_inst = Sil.hpara_dll_instantiate para_dll e4 e2 e3 elist in
let _, para_dll_inst = Predicates.hpara_dll_instantiate para_dll e4 e2 e3 elist in
let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in
let prop' = Prop.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' in
@ -1214,8 +1213,8 @@ let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e
let iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist =
let iter_nonemp_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in
let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_PE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_subcases =
@ -1236,10 +1235,8 @@ let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter
elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 =
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll n' e1 e3 e4 elist]
in
let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll n' e1 e3 e4 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_subcases =
@ -1261,10 +1258,8 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p
elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 =
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll e1 e2 e4 n' elist]
in
let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll e1 e2 e4 n' elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1
in
let iter_subcases =
@ -1283,7 +1278,7 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p
(** find the type at the offset from the given type expression, if any *)
let type_at_offset tenv texp off =
let rec strip_offset (off : Sil.offset list) (typ : Typ.t) =
let rec strip_offset (off : Predicates.offset list) (typ : Typ.t) =
match (off, typ.desc) with
| [], _ ->
Some typ
@ -1310,7 +1305,7 @@ let type_at_offset tenv texp off =
let check_type_size tenv pname prop texp off typ_from_instr =
L.d_strln ~color:Orange "check_type_size" ;
L.d_str "off: " ;
Sil.d_offset_list off ;
Predicates.d_offset_list off ;
L.d_ln () ;
L.d_str "typ_from_instr: " ;
Typ.d_full typ_from_instr ;
@ -1345,9 +1340,9 @@ let check_type_size tenv pname prop texp off typ_from_instr =
* that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *)
let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
Sil.offset list Prop.prop_iter list =
Predicates.offset list Prop.prop_iter list =
let rec root_typ_of_offsets = function
| Sil.Off_fld (f, fld_typ) :: _ -> (
| Predicates.Off_fld (f, fld_typ) :: _ -> (
match fld_typ.desc with
| Tstruct _ ->
(* access through field: get the struct type from the field *)
@ -1362,12 +1357,12 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
fld_typ
| _ ->
typ_from_instr )
| Sil.Off_index _ :: off ->
| Predicates.Off_index _ :: off ->
Typ.mk_array (root_typ_of_offsets off)
| _ ->
typ_from_instr
in
let typ = root_typ_of_offsets (Sil.exp_get_offsets lexp) in
let typ = root_typ_of_offsets (Predicates.exp_get_offsets lexp) in
if Config.trace_rearrange then (
L.d_increase_indent () ;
L.d_strln "entering iter_rearrange" ;
@ -1414,9 +1409,9 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
f_many_iters [] iters
in
let filter = function
| Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) ->
| Predicates.Hpointsto (base, _, _) | Predicates.Hlseg (_, _, base, _, _) ->
Prover.is_root tenv prop base lexp
| Sil.Hdllseg (_, _, first, _, _, last, _) -> (
| Predicates.Hdllseg (_, _, first, _, _, last, _) -> (
let result_first = Prover.is_root tenv prop first lexp in
match result_first with
| None ->
@ -1430,14 +1425,14 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
[default_case_iter iter]
| Some iter -> (
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (_, _, texp), off ->
| Predicates.Hpointsto (_, _, texp), off ->
if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr ;
iter_rearrange_ptsto pname tenv prop iter lexp inst
| Sil.Hlseg (Sil.Lseg_NE, para, e1, e2, elist), _ ->
| Predicates.Hlseg (Lseg_NE, para, e1, e2, elist), _ ->
iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist
| Sil.Hlseg (Sil.Lseg_PE, para, e1, e2, elist), _ ->
| Predicates.Hlseg (Lseg_PE, para, e1, e2, elist), _ ->
iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist
| Sil.Hdllseg (Sil.Lseg_NE, para_dll, e1, e2, e3, e4, elist), _ -> (
| Predicates.Hdllseg (Lseg_NE, para_dll, e1, e2, e3, e4, elist), _ -> (
match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with
| None, None ->
assert false
@ -1445,7 +1440,7 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist
| _, Some _ ->
iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist )
| Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> (
| Predicates.Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> (
match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with
| None, None ->
assert false
@ -1474,7 +1469,7 @@ let var_has_annotation pdesc is_annotation pvar =
let attr_has_annot is_annotation tenv prop exp =
let attr_has_annot = function
| Sil.Apred ((Aretval (pname, ret_attr) | Aundef (pname, ret_attr, _, _)), _)
| Predicates.Apred ((Aretval (pname, ret_attr) | Aundef (pname, ret_attr, _, _)), _)
when is_annotation ret_attr ->
Some (Typ.Procname.to_string pname)
| _ ->
@ -1494,7 +1489,7 @@ let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, s
false
in
match strexp with
| Sil.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp ->
| Predicates.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp ->
let has_annot = fld_has_annot fld in
if has_annot then obj_str := Some (Typ.Fieldname.to_simplified_string fld) ;
has_annot
@ -1509,7 +1504,7 @@ let is_only_pt_by_fld_or_param_with_annot pdesc tenv prop deref_exp is_annotatio
let obj_str = ref None in
let is_pt_by_fld_or_param_with_annot hpred =
match hpred with
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp ((Exp.Var _ as exp), _), _)
| Predicates.Hpointsto (Exp.Lvar pvar, Eexp ((Exp.Var _ as exp), _), _)
when Exp.equal exp deref_exp ->
let var_has_annotation = Pvar.is_seed pvar && var_has_annotation pdesc is_annotation pvar in
if var_has_annotation then obj_str := Some (Pvar.to_string pvar) ;
@ -1517,7 +1512,7 @@ let is_only_pt_by_fld_or_param_with_annot pdesc tenv prop deref_exp is_annotatio
if Option.is_some procname_str_opt then obj_str := procname_str_opt ;
(* it's ok for a local with no annotation to point to deref_exp *)
var_has_annotation || Option.is_some procname_str_opt || Pvar.is_local pvar
| Sil.Hpointsto (_, Sil.Estruct (flds, _), Exp.Sizeof {typ}) ->
| Predicates.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) ->
List.for_all ~f:(is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp) flds
| _ ->
true
@ -1648,7 +1643,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc =
let get_exp_called () =
(* Exp called in the block's function call*)
match State.get_instr () with
| Some (Sil.Call (_, Exp.Var id, _, _, _)) ->
| Some (Sil.Call (_, Var id, _, _, _)) ->
Errdesc.find_ident_assignment (State.get_node_exn ()) id
| _ ->
None
@ -1708,7 +1703,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc =
It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *)
let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc :
Sil.offset list Prop.prop_iter list =
Predicates.offset list Prop.prop_iter list =
let nlexp =
match Prop.exp_normalize_prop tenv prop lexp with
| Exp.BinOp (Binop.PlusPI, ep, e) ->
@ -1718,7 +1713,7 @@ let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc :
e
in
let ptr_tested_for_zero = Prover.check_disequal tenv prop (Exp.root_of_lexp nlexp) Exp.zero in
let inst = Sil.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in
let inst = Predicates.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in
L.d_strln ".... Rearrangement Start ...." ;
L.d_str "Exp: " ;
Exp.d_exp nlexp ;

2
infer/src/biabduction/Rearrange.mli
Unescape View File

@ -32,7 +32,7 @@ val rearrange :
-> Typ.t
-> Prop.normal Prop.t
-> Location.t
-> Sil.offset list Prop.prop_iter list
-> Predicates.offset list Prop.prop_iter list
(** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. It returns an
iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which
leads to [lexp] as the iterator state. *)

13
infer/src/biabduction/RetainCycles.ml
Unescape View File

@ -136,7 +136,7 @@ let get_weak_alias_type prop e =
let sigma = prop.Prop.sigma in
let check_weak_alias hpred =
match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e', _), Sizeof {typ}) -> (
| Predicates.Hpointsto (_, Eexp (e', _), Sizeof {typ}) -> (
match typ.Typ.desc with
| (Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained))
when Exp.equal e' e ->
@ -154,7 +154,8 @@ let get_cycles found_cycles root tenv prop =
let sigma = prop.Prop.sigma in
let get_points_to e =
List.find
~f:(fun hpred -> match hpred with Sil.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false)
~f:(fun hpred ->
match hpred with Predicates.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false )
sigma
in
(* Perform a dfs of a graph stopping when e_root is reached. Returns the set of cycles reached. *)
@ -169,7 +170,7 @@ let get_cycles found_cycles root tenv prop =
match fields with
| [] ->
found_cycles
| (field, Sil.Eexp (f_exp, f_inst)) :: el' ->
| (field, Predicates.Eexp (f_exp, f_inst)) :: el' ->
let rc_field = {rc_field_name= field; rc_field_inst= f_inst} in
let obj_edge = {rc_from= from_node; rc_field} in
let edge = Object obj_edge in
@ -191,7 +192,7 @@ let get_cycles found_cycles root tenv prop =
match get_points_to f_exp with
| None ->
found_cycles
| Some (Sil.Hpointsto (_, Sil.Estruct (new_fields, _), Exp.Sizeof {typ= te}))
| Some (Predicates.Hpointsto (_, Estruct (new_fields, _), Exp.Sizeof {typ= te}))
when edge_is_strong tenv obj_edge ->
let rc_to = {rc_node_exp= f_exp; rc_node_typ= te} in
dfs ~found_cycles ~root_node ~from_node:rc_to ~rev_path:(edge :: rev_path)
@ -205,8 +206,8 @@ let get_cycles found_cycles root tenv prop =
found_cycles
in
match root with
| Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) when Sil.is_objc_object root
->
| Predicates.Hpointsto (e_root, Estruct (fl, _), Exp.Sizeof {typ= te})
when Predicates.is_objc_object root ->
let se_root = {rc_node_exp= e_root; rc_node_typ= te} in
(* start dfs with empty path and expr pointing to root *)
dfs ~found_cycles ~root_node:se_root ~from_node:se_root ~rev_path:[] ~fields:fl ~visited:[]

7
infer/src/biabduction/RetainCyclesType.ml
Unescape View File

@ -8,7 +8,7 @@ open! IStd
type retain_cycle_node = {rc_node_exp: Exp.t; rc_node_typ: Typ.t}
type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Sil.inst}
type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Predicates.inst}
type retain_cycle_edge_obj = {rc_from: retain_cycle_node; rc_field: retain_cycle_field}
@ -58,7 +58,7 @@ end)
let is_inst_rearrange node =
match node with
| Object obj -> (
match obj.rc_field.rc_field_inst with Sil.Irearrange _ -> true | _ -> false )
match obj.rc_field.rc_field_inst with Predicates.Irearrange _ -> true | _ -> false )
| Block _ ->
false
@ -99,7 +99,8 @@ let pp_retain_cycle_node f (node : retain_cycle_node) =
let pp_retain_cycle_field f (field : retain_cycle_field) =
Format.fprintf f "%a[%a]" Typ.Fieldname.pp field.rc_field_name Sil.pp_inst field.rc_field_inst
Format.fprintf f "%a[%a]" Typ.Fieldname.pp field.rc_field_name Predicates.pp_inst
field.rc_field_inst
let pp_retain_cycle_edge f (edge : retain_cycle_edge) =

2
infer/src/biabduction/RetainCyclesType.mli
Unescape View File

@ -9,7 +9,7 @@ open! IStd
type retain_cycle_node = {rc_node_exp: Exp.t; rc_node_typ: Typ.t}
type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Sil.inst}
type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Predicates.inst}
type retain_cycle_edge_obj = {rc_from: retain_cycle_node; rc_field: retain_cycle_field}

8
infer/src/biabduction/State.ml
Unescape View File

@ -110,9 +110,9 @@ let instrs_normalize instrs =
let subst =
let count = ref Int.min_value in
let gensym id = incr count ; Ident.set_stamp id !count in
Sil.subst_of_list (List.rev_map ~f:(fun id -> (id, Exp.Var (gensym id))) bound_ids)
Predicates.subst_of_list (List.rev_map ~f:(fun id -> (id, Exp.Var (gensym id))) bound_ids)
in
let subst_and_add acc instr = Sil.instr_sub subst instr :: acc in
let subst_and_add acc instr = Predicates.instr_sub subst instr :: acc in
Instrs.fold instrs ~init:[] ~f:subst_and_add
@ -167,7 +167,7 @@ let mk_find_duplicate_nodes : Procdesc.t -> Procdesc.Node.t -> Procdesc.NodeSet.
let get_inst_update pos =
let loc = get_loc_exn () in
Sil.inst_update loc pos
Predicates.inst_update loc pos
let get_path () =
@ -191,7 +191,7 @@ let extract_pre p tenv pdesc abstract_fun =
let sub =
let idlist = Prop.free_vars p |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in
let count = ref 0 in
Sil.subst_of_list
Predicates.subst_of_list
(List.map
~f:(fun id ->
incr count ;

2
infer/src/biabduction/State.mli
Unescape View File

@ -22,7 +22,7 @@ val get_diverging_states_node : unit -> Paths.PathSet.t
val get_diverging_states_proc : unit -> Paths.PathSet.t
(** Get the diverging states for the procedure *)
val get_inst_update : PredSymb.path_pos -> Sil.inst
val get_inst_update : PredSymb.path_pos -> Predicates.inst
(** Get update instrumentation for the current loc *)
val get_instr : unit -> Sil.instr option

131
infer/src/biabduction/SymExec.ml
Unescape View File

@ -20,7 +20,7 @@ let rec fldlist_assoc fld = function
if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l
let unroll_type tenv (typ : Typ.t) (off : Sil.offset) =
let unroll_type tenv (typ : Typ.t) (off : Predicates.offset) =
let fail pp_fld fld =
L.d_strln ".... Invalid Field Access ...." ;
L.d_printfln "Fld : %a" pp_fld fld ;
@ -41,7 +41,7 @@ let unroll_type tenv (typ : Typ.t) (off : Sil.offset) =
| _, Off_index (Const (Cint i)) when IntLit.iszero i ->
typ
| _ ->
fail (Sil.pp_offset Pp.text) off
fail (Predicates.pp_offset Pp.text) off
(** Apply function [f] to the expression at position [offlist] in [strexp]. If not found, expand
@ -60,10 +60,10 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
let pp_error () =
L.d_strln ".... Invalid Field ...." ;
L.d_str "strexp : " ;
Sil.d_sexp strexp ;
Predicates.d_sexp strexp ;
L.d_ln () ;
L.d_str "offlist : " ;
Sil.d_offset_list offlist ;
Predicates.d_offset_list offlist ;
L.d_ln () ;
L.d_str "type : " ;
Typ.d_full typ ;
@ -74,38 +74,40 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
L.d_ln ()
in
match (offlist, strexp, typ.Typ.desc) with
| [], Sil.Eexp (e, inst_curr), _ ->
| [], Predicates.Eexp (e, inst_curr), _ ->
let inst_new =
match inst with
| Sil.Ilookup ->
| Predicates.Ilookup ->
(* a lookup does not change an inst unless it is inst_initial *)
lookup_inst := Some inst_curr ;
inst_curr
| _ ->
Sil.update_inst inst_curr inst
Predicates.update_inst inst_curr inst
in
let e' = f (Some e) in
(e', Sil.Eexp (e', inst_new), typ, None)
| [], Sil.Estruct (fesl, inst'), _ ->
if not nullify_struct then (f None, Sil.Estruct (fesl, inst'), typ, None)
(e', Predicates.Eexp (e', inst_new), typ, None)
| [], Predicates.Estruct (fesl, inst'), _ ->
if not nullify_struct then (f None, Predicates.Estruct (fesl, inst'), typ, None)
else if fp_root then (
pp_error () ;
assert false )
else (
L.d_strln "WARNING: struct assignment treated as nondeterministic assignment" ;
(f None, Prop.create_strexp_of_type tenv Prop.Fld_init typ None inst, typ, None) )
| [], Sil.Earray _, _ ->
let offlist' = Sil.Off_index Exp.zero :: offlist in
| [], Predicates.Earray _, _ ->
let offlist' = Predicates.Off_index Exp.zero :: offlist in
apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst
lookup_inst
| Sil.Off_fld _ :: _, Sil.Earray _, _ ->
let offlist_new = Sil.Off_index Exp.zero :: offlist in
| Predicates.Off_fld _ :: _, Predicates.Earray _, _ ->
let offlist_new = Predicates.Off_index Exp.zero :: offlist in
apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst
lookup_inst
| Sil.Off_fld (fld, fld_typ) :: offlist', Sil.Estruct (fsel, inst'), Typ.Tstruct name -> (
| ( Predicates.Off_fld (fld, fld_typ) :: offlist'
, Predicates.Estruct (fsel, inst')
, Typ.Tstruct name ) -> (
match Tenv.lookup tenv name with
| Some ({fields} as struct_typ) -> (
let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in
let t' = unroll_type tenv typ (Predicates.Off_fld (fld, fld_typ)) in
match List.find ~f:(fun fse -> Typ.Fieldname.equal fld (fst fse)) fsel with
| Some (_, se') ->
let res_e', res_se', res_t', res_pred_insts_op' =
@ -115,7 +117,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
let replace_fse fse =
if Typ.Fieldname.equal fld (fst fse) then (fld, res_se') else fse
in
let res_se = Sil.Estruct (List.map ~f:replace_fse fsel, inst') in
let res_se = Predicates.Estruct (List.map ~f:replace_fse fsel, inst') in
let replace_fta (f, t, a) =
if Typ.Fieldname.equal fld f then (fld, res_t', a) else (f, t, a)
in
@ -130,11 +132,11 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
| None ->
pp_error () ;
assert false )
| Sil.Off_fld _ :: _, _, _ ->
| Predicates.Off_fld _ :: _, _, _ ->
pp_error () ;
assert false
| ( Sil.Off_index idx :: offlist'
, Sil.Earray (len, esel, inst1)
| ( Predicates.Off_index idx :: offlist'
, Predicates.Earray (len, esel, inst1)
, Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> (
let nidx = Prop.exp_normalize_prop tenv p idx in
match List.find ~f:(fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel with
@ -144,7 +146,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
lookup_inst
in
let replace_ese ese = if Exp.equal idx_ese' (fst ese) then (idx_ese', res_se') else ese in
let res_se = Sil.Earray (len, List.map ~f:replace_ese esel, inst1) in
let res_se = Predicates.Earray (len, List.map ~f:replace_ese esel, inst1) in
let res_t = Typ.mk_array ~default:typ res_t' ?length:len' ?stride:stride' in
(res_e', res_se, res_t, res_pred_insts_op')
| None ->
@ -154,7 +156,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
L.d_strln " not materialized -- returning nondeterministic value" ;
let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in
(res_e', strexp, typ, None) )
| Sil.Off_index _ :: _, _, _ ->
| Predicates.Off_index _ :: _, _, _ ->
(* This case should not happen. The rearrangement should
have materialized all the accessed cells. *)
pp_error () ;
@ -176,12 +178,16 @@ let ptsto_lookup pdesc tenv p (lexp, se, sizeof) offlist id =
let fp_root = match lexp with Exp.Var id -> Ident.is_footprint id | _ -> false in
let lookup_inst = ref None in
let e', se', typ', pred_insts_op' =
apply_offlist pdesc tenv p fp_root false (lexp, se, sizeof.Exp.typ) offlist f Sil.inst_lookup
lookup_inst
apply_offlist pdesc tenv p fp_root false (lexp, se, sizeof.Exp.typ) offlist f
Predicates.inst_lookup lookup_inst
in
let lookup_uninitialized =
(* true if we have looked up an uninitialized value *)
match !lookup_inst with Some (Sil.Iinitial | Sil.Ialloc | Sil.Ilookup) -> true | _ -> false
match !lookup_inst with
| Some (Predicates.Iinitial | Predicates.Ialloc | Predicates.Ilookup) ->
true
| _ ->
false
in
let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in
(e', ptsto', pred_insts_op', lookup_uninitialized)
@ -214,14 +220,14 @@ let update_iter iter pi sigma =
(** Precondition: se should not include hpara_psto that could mean nonempty heaps. *)
let rec execute_nullify_se = function
| Sil.Eexp _ ->
Sil.Eexp (Exp.zero, Sil.inst_nullify)
| Sil.Estruct (fsel, _) ->
| Predicates.Eexp _ ->
Predicates.Eexp (Exp.zero, Predicates.inst_nullify)
| Predicates.Estruct (fsel, _) ->
let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in
Sil.Estruct (fsel', Sil.inst_nullify)
| Sil.Earray (len, esel, _) ->
Predicates.Estruct (fsel', Predicates.inst_nullify)
| Predicates.Earray (len, esel, _) ->
let esel' = List.map ~f:(fun (idx, se) -> (idx, execute_nullify_se se)) esel in
Sil.Earray (len, esel', Sil.inst_nullify)
Predicates.Earray (len, esel', Predicates.inst_nullify)
(** Do pruning for conditional [if (e1 != e2)] if [positive] is true and [(if (e1 == e2)] if
@ -422,7 +428,7 @@ let check_arith_norm_exp tenv pname exp prop =
let check_already_dereferenced tenv pname cond prop =
let find_hpred lhs =
List.find
~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e lhs | _ -> false)
~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e lhs | _ -> false)
prop.Prop.sigma
in
let rec is_check_zero = function
@ -452,7 +458,7 @@ let check_already_dereferenced tenv pname cond prop =
match is_check_zero cond with
| Some id -> (
match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with
| Some (Sil.Hpointsto (_, se, _)) -> (
| Some (Predicates.Hpointsto (_, se, _)) -> (
match Tabulation.find_dereference_without_null_check_in_sexp se with
| Some n ->
Some (id, n)
@ -479,11 +485,11 @@ let check_already_dereferenced tenv pname cond prop =
exception in that case *)
let check_deallocate_static_memory prop_after =
let check_deallocated_attribute = function
| Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Lvar pv])
| Predicates.Apred (Aresource ({ra_kind= Rrelease} as ra), [Lvar pv])
when Pvar.is_local pv || Pvar.is_global pv ->
let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in
raise (Exceptions.Deallocate_stack_variable freed_desc)
| Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Const (Cstr s)]) ->
| Predicates.Apred (Aresource ({ra_kind= Rrelease} as ra), [Const (Cstr s)]) ->
let freed_desc = Errdesc.explain_deallocate_constant_string s ra in
raise (Exceptions.Deallocate_static_memory freed_desc)
| _ ->
@ -543,7 +549,7 @@ let resolve_typename prop receiver_exp =
let rec loop = function
| [] ->
None
| Sil.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp ->
| Predicates.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp ->
Some typexp
| _ :: hpreds ->
loop hpreds
@ -760,7 +766,7 @@ let receiver_self receiver prop =
List.exists
~f:(fun hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) ->
| Predicates.Hpointsto (Lvar pv, Eexp (e, _), _) ->
Exp.equal e receiver && Pvar.is_seed pv && Pvar.is_self pv
| _ ->
false )
@ -890,7 +896,7 @@ let add_strexp_to_footprint tenv strexp abduced_pv typ prop =
let add_to_footprint tenv abduced_pv typ prop =
let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let prop' =
add_strexp_to_footprint tenv (Sil.Eexp (fresh_fp_var, Sil.Inone)) abduced_pv typ prop
add_strexp_to_footprint tenv (Eexp (fresh_fp_var, Predicates.Inone)) abduced_pv typ prop
in
(prop', fresh_fp_var)
@ -900,7 +906,7 @@ let add_to_footprint tenv abduced_pv typ prop =
footprint. regular abduction just adds a fresh footprint value of the correct type to the
footprint. we can get rid of this special case if we fix the abduction on struct values *)
let add_struct_value_to_footprint tenv abduced_pv typ prop =
let struct_strexp = Prop.create_strexp_of_type tenv Prop.Fld_init typ None Sil.inst_none in
let struct_strexp = Prop.create_strexp_of_type tenv Prop.Fld_init typ None Predicates.inst_none in
let prop' = add_strexp_to_footprint tenv struct_strexp abduced_pv typ prop in
(prop', struct_strexp)
@ -918,7 +924,8 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal
List.find_map
~f:(fun hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (exp, _), _) when Pvar.equal pv abduced_ret_pv ->
| Predicates.Hpointsto (Exp.Lvar pv, Eexp (exp, _), _) when Pvar.equal pv abduced_ret_pv
->
Some exp
| _ ->
None )
@ -927,7 +934,7 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal
(* find an hpred [abduced] |-> A in [prop] and add [exp] = A to prop *)
let bind_exp_to_abduced_val exp_to_bind abduced prop =
let bind_exp prop = function
| Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (rhs, _), _) when Pvar.equal pv abduced ->
| Predicates.Hpointsto (Exp.Lvar pv, Eexp (rhs, _), _) when Pvar.equal pv abduced ->
Prop.conjoin_eq tenv exp_to_bind rhs prop
| _ ->
prop
@ -968,7 +975,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l
let iter_ren = Prop.prop_iter_make_id_primed tenv id iter in
let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in
match Prop.prop_iter_current tenv iter_ren with
| Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist -> (
| Predicates.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist -> (
let contents, new_ptsto, pred_insts_op, lookup_uninitialized =
ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id
in
@ -980,7 +987,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l
false
in
let update acc (pi, sigma) =
let pi' = Sil.Aeq (Exp.Var id, contents) :: pi in
let pi' = Predicates.Aeq (Exp.Var id, contents) :: pi in
let sigma' = new_ptsto :: sigma in
let iter' = update_iter iter_ren pi' sigma' in
let prop' = Prop.prop_iter_to_prop tenv iter' in
@ -997,7 +1004,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l
update acc_in ([], [])
| Some pred_insts ->
List.rev (List.fold ~f:update ~init:acc_in pred_insts) )
| Sil.Hpointsto _, _ ->
| Predicates.Hpointsto _, _ ->
Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@." ;
Prop.prop_iter_to_prop tenv iter_ren :: acc_in
| _ ->
@ -1043,7 +1050,7 @@ let execute_store ?(report_deref_errors = true) pname pdesc tenv lhs_exp typ rhs
let execute_store_ pdesc tenv rhs_exp acc_in iter =
let lexp, strexp, sizeof, offlist =
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist ->
| Predicates.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist ->
(lexp, strexp, sizeof, offlist)
| _ ->
assert false
@ -1154,7 +1161,7 @@ let declare_locals_and_ret tenv pdesc (prop_ : Prop.normal Prop.t) =
let ptsto =
(pvar, Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}, None)
in
Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_initial ptsto
Prop.mk_ptsto_lvar tenv Prop.Fld_init Predicates.inst_initial ptsto
in
let sigma_locals_and_ret () =
let pname = Procdesc.get_proc_name pdesc in
@ -1486,13 +1493,14 @@ let rec sym_exec exe_env tenv current_summary instr_ (prop_ : Prop.normal Prop.t
let eprop = Prop.expose prop_ in
match
List.partition_tf
~f:(function Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false)
~f:(function
| Predicates.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false )
eprop.Prop.sigma
with
| [Sil.Hpointsto (e, se, typ)], sigma' ->
| [Predicates.Hpointsto (e, se, typ)], sigma' ->
let sigma'' =
let se' = execute_nullify_se se in
Sil.Hpointsto (e, se', typ) :: sigma'
Predicates.Hpointsto (e, se', typ) :: sigma'
in
let eprop_res = Prop.set eprop ~sigma:sigma'' in
ret_old_path [Prop.normalize tenv eprop_res]
@ -1561,8 +1569,11 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
let already_has_abduced_retval p =
List.exists
~f:(fun hpred ->
match hpred with Sil.Hpointsto (Exp.Lvar pv, _, _) -> Pvar.equal pv abduced | _ -> false
)
match hpred with
| Predicates.Hpointsto (Exp.Lvar pv, _, _) ->
Pvar.equal pv abduced
| _ ->
false )
p.Prop.sigma_fp
in
(* prevent introducing multiple abduced retvals for a single call site in a loop *)
@ -1577,7 +1588,7 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
| Typ.Tptr (typ, _) ->
(* for pointer types passed by reference, do abduction directly on the pointer *)
let prop', fresh_fp_var = add_to_footprint tenv abduced typ prop in
(prop', Sil.Eexp (fresh_fp_var, Sil.Inone))
(prop', Predicates.Eexp (fresh_fp_var, Predicates.Inone))
| _ ->
L.(die InternalError)
"No need for abduction on non-pointer type %s" (Typ.to_string actual_typ)
@ -1585,8 +1596,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
let filtered_sigma =
List.map
~f:(function
| Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual ->
Sil.Hpointsto (lhs, abduced_strexp, typ_exp)
| Predicates.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual ->
Predicates.Hpointsto (lhs, abduced_strexp, typ_exp)
| hpred ->
hpred )
prop'.Prop.sigma
@ -1597,7 +1608,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
let prop' =
let filtered_sigma =
List.filter
~f:(function Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true)
~f:(function
| Predicates.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true )
prop.Prop.sigma
in
Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma)
@ -1605,8 +1617,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
List.fold
~f:(fun p hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced ->
let new_hpred = Sil.Hpointsto (actual, rhs, texp) in
| Predicates.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced ->
let new_hpred = Predicates.Hpointsto (actual, rhs, texp) in
Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma))
| _ ->
p )
@ -1638,7 +1650,7 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots
let do_exp p (e, _) =
let do_attribute q atom =
match atom with
| Sil.Apred ((Aresource {ra_res= Rfile} as res), _) ->
| Predicates.Apred ((Aresource {ra_res= Rfile} as res), _) ->
Attribute.remove_for_attr tenv q res
| _ ->
q
@ -1913,7 +1925,8 @@ and sym_exec_wrapper exe_env handle_exn tenv summary proc_cfg instr
List.map ~f:(fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed
in
let ren_sub =
Sil.subst_of_list (List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_primed_normal)
Predicates.subst_of_list
(List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_primed_normal)
in
let p' = Prop.normalize tenv (Prop.prop_sub ren_sub p) in
let fav_normal = List.map ~f:snd ids_primed_normal in

209
infer/src/biabduction/Tabulation.ml
Unescape View File

@ -15,12 +15,12 @@ open! IStd
module L = Logging
type splitting =
{ sub: Sil.subst
; frame: Sil.hpred list
; missing_pi: Sil.atom list
; missing_sigma: Sil.hpred list
; frame_fld: Sil.hpred list
; missing_fld: Sil.hpred list
{ sub: Predicates.subst
; frame: Predicates.hpred list
; missing_pi: Predicates.atom list
; missing_sigma: Predicates.hpred list
; frame_fld: Predicates.hpred list
; missing_fld: Predicates.hpred list
; frame_typ: (Exp.t * Exp.t) list
; missing_typ: (Exp.t * Exp.t) list }
@ -60,8 +60,8 @@ type invalid_res =
type valid_res =
{ incons_pre_missing: bool (** whether the actual pre is consistent with the missing part *)
; vr_pi: Sil.atom list (** missing pi *)
; vr_sigma: Sil.hpred list (** missing sigma *)
; vr_pi: Predicates.atom list (** missing pi *)
; vr_sigma: Predicates.hpred list (** missing sigma *)
; vr_cons_res: (Prop.normal Prop.t * Paths.Path.t) list (** consistent result props *)
; vr_incons_res: (Prop.normal Prop.t * Paths.Path.t) list (** inconsistent result props *) }
@ -144,7 +144,7 @@ let spec_rename_vars pname spec =
in
let ids = Ident.HashQueue.keys fav in
let ids' = List.map ~f:(fun i -> (i, Ident.create_fresh Ident.kprimed)) ids in
let ren_sub = Sil.subst_of_list (List.map ~f:(fun (i, i') -> (i, Exp.Var i')) ids') in
let ren_sub = Predicates.subst_of_list (List.map ~f:(fun (i, i') -> (i, Exp.Var i')) ids') in
let pre' = BiabductionSummary.Jprop.jprop_sub ren_sub spec.BiabductionSummary.pre in
let posts' =
List.map ~f:(fun (p, path) -> (Prop.prop_sub ren_sub p, path)) spec.BiabductionSummary.posts
@ -188,22 +188,22 @@ let spec_find_rename trace_call summary :
let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld
frame_typ missing_typ =
let hpred_has_only_footprint_vars hpred =
Sil.hpred_free_vars hpred |> Sequence.for_all ~f:Ident.is_footprint
Predicates.hpred_free_vars hpred |> Sequence.for_all ~f:Ident.is_footprint
in
let sub = Sil.sub_join sub1 sub2 in
let sub = Predicates.sub_join sub1 sub2 in
let sub1_inverse =
let sub1_list = Sil.sub_to_list sub1 in
let sub1_list = Predicates.sub_to_list sub1 in
let sub1_list' = List.filter ~f:(function _, Exp.Var _ -> true | _ -> false) sub1_list in
let sub1_inverse_list =
List.map ~f:(function id, Exp.Var id' -> (id', Exp.Var id) | _ -> assert false) sub1_list'
in
Sil.subst_of_list_duplicates sub1_inverse_list
Predicates.subst_of_list_duplicates sub1_inverse_list
in
let fav_actual_pre =
let fav_pre = Prop.free_vars actual_pre |> Ident.hashqueue_of_sequence in
let filter id = Int.equal (Ident.get_stamp id) (-1) in
(* vars which represent expansions of fields *)
Sil.sub_range sub2
Predicates.sub_range sub2
|> List.fold_left ~init:fav_pre ~f:(fun res e ->
Exp.free_vars e |> Sequence.filter ~f:filter |> Ident.hashqueue_of_sequence ~init:res )
in
@ -221,7 +221,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
Prop.sigma_sub sub missing_fld |> Prop.sigma_free_vars |> Ident.hashqueue_of_sequence
in
let map_var_to_pre_var_or_fresh id =
match Sil.exp_sub sub1_inverse (Exp.Var id) with
match Predicates.exp_sub sub1_inverse (Exp.Var id) with
| Exp.Var id' ->
if
Ident.HashQueue.mem fav_actual_pre id' || Ident.is_path id'
@ -231,7 +231,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
| _ ->
assert false
in
let sub_list = Sil.sub_to_list sub in
let sub_list = Predicates.sub_to_list sub in
let sub1 =
let f id =
if Ident.HashQueue.mem fav_actual_pre id then (id, Exp.Var id)
@ -239,10 +239,10 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
else if Ident.HashQueue.mem fav_missing_fld id then (id, Exp.Var id)
else if Ident.is_footprint id then (id, Exp.Var id)
else
let dom1 = Sil.sub_domain sub1 in
let rng1 = Sil.sub_range sub1 in
let dom2 = Sil.sub_domain sub2 in
let rng2 = Sil.sub_range sub2 in
let dom1 = Predicates.sub_domain sub1 in
let rng1 = Predicates.sub_range sub1 in
let dom2 = Predicates.sub_domain sub2 in
let rng2 = Predicates.sub_range sub2 in
let vars_actual_pre =
List.map ~f:(fun id -> Exp.Var id) (Ident.HashQueue.keys fav_actual_pre)
in
@ -271,41 +271,41 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
Exp.free_vars e |> Ident.hashqueue_of_sequence ~init:fav )
|> Ident.HashQueue.keys
in
Sil.subst_of_list (List.map ~f fav_sub_list)
Predicates.subst_of_list (List.map ~f fav_sub_list)
in
let sub2_list =
let f id = (id, Exp.Var (Ident.create_fresh Ident.kfootprint)) in
List.map ~f fav_missing_primed
in
let sub_list' = List.map ~f:(fun (id, e) -> (id, Sil.exp_sub sub1 e)) sub_list in
let sub' = Sil.subst_of_list (sub2_list @ sub_list') in
let sub_list' = List.map ~f:(fun (id, e) -> (id, Predicates.exp_sub sub1 e)) sub_list in
let sub' = Predicates.subst_of_list (sub2_list @ sub_list') in
(* normalize everything w.r.t sub' *)
let norm_missing_pi = Prop.pi_sub sub' missing_pi in
let norm_missing_sigma = Prop.sigma_sub sub' missing_sigma in
let norm_frame_fld = Prop.sigma_sub sub' frame_fld in
let norm_frame_typ =
List.map ~f:(fun (e, te) -> (Sil.exp_sub sub' e, Sil.exp_sub sub' te)) frame_typ
List.map ~f:(fun (e, te) -> (Predicates.exp_sub sub' e, Predicates.exp_sub sub' te)) frame_typ
in
let norm_missing_typ =
List.map ~f:(fun (e, te) -> (Sil.exp_sub sub' e, Sil.exp_sub sub' te)) missing_typ
List.map ~f:(fun (e, te) -> (Predicates.exp_sub sub' e, Predicates.exp_sub sub' te)) missing_typ
in
let norm_missing_fld =
let sigma = Prop.sigma_sub sub' missing_fld in
let filter hpred =
if not (hpred_has_only_footprint_vars hpred) then (
L.d_warning "Missing fields hpred has non-footprint vars: " ;
Sil.d_hpred hpred ;
Predicates.d_hpred hpred ;
L.d_ln () ;
false )
else
match hpred with
| Sil.Hpointsto (Exp.Var _, _, _) ->
| Predicates.Hpointsto (Exp.Var _, _, _) ->
true
| Sil.Hpointsto (Exp.Lvar pvar, _, _) ->
| Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
Pvar.is_global pvar
| _ ->
L.d_warning "Missing fields in complex pred: " ;
Sil.d_hpred hpred ;
Predicates.d_hpred hpred ;
L.d_ln () ;
false
in
@ -325,7 +325,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
(** Check whether an inst represents a dereference without null check,
and return the line number and path position *)
let find_dereference_without_null_check_in_inst = function
| Sil.Iupdate (Some true, _, n, pos) | Sil.Irearrange (Some true, _, n, pos) ->
| Predicates.Iupdate (Some true, _, n, pos) | Predicates.Irearrange (Some true, _, n, pos) ->
Some (n, pos)
| _ ->
None
@ -334,13 +334,13 @@ let find_dereference_without_null_check_in_inst = function
(** Check whether a sexp contains a dereference without null check,
and return the line number and path position *)
let rec find_dereference_without_null_check_in_sexp = function
| Sil.Eexp (_, inst) ->
| Predicates.Eexp (_, inst) ->
find_dereference_without_null_check_in_inst inst
| Sil.Estruct (fsel, inst) ->
| Predicates.Estruct (fsel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd fsel)
else res
| Sil.Earray (_, esel, inst) ->
| Predicates.Earray (_, esel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd esel)
else res
@ -361,7 +361,7 @@ and find_dereference_without_null_check_in_sexp_list = function
In case of dereference error, return [Some(deref_error, description)], otherwise [None] *)
let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in
let e_sub = Predicates.exp_sub sub e in
let desc use_buckets deref_str =
let error_desc =
Errdesc.explain_dereference_as_caller_expression caller_pname tenv ~use_buckets deref_str
@ -412,7 +412,7 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo
None )
in
let check_hpred = function
| Sil.Hpointsto (lexp, se, _) ->
| Predicates.Hpointsto (lexp, se, _) ->
check_dereference (Exp.root_of_lexp lexp) se
| _ ->
None
@ -441,9 +441,9 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo
Some deref_err )
let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list =
let map_inst inst = Sil.inst_new_loc loc inst in
let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in
let post_process_sigma tenv (sigma : Predicates.hpred list) loc : Predicates.hpred list =
let map_inst inst = Predicates.inst_new_loc loc inst in
let do_hpred (_, _, hpred) = Predicates.hpred_instmap map_inst hpred in
(* update the location of instrumentations *)
List.map ~f:(fun hpred -> do_hpred (Prover.expand_hpred_pointer tenv false hpred)) sigma
@ -452,7 +452,7 @@ let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list =
let check_path_errors_in_post tenv caller_pname post post_path =
let check_attr atom =
match atom with
| Sil.Apred (Adiv0 path_pos, [e]) ->
| Predicates.Apred (Adiv0 path_pos, [e]) ->
if Prover.check_zero tenv e then (
let desc =
Errdesc.explain_divide_by_zero tenv e (State.get_node_exn ()) (State.get_loc_exn ())
@ -485,14 +485,14 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre
false
in
let atom_update_alloc_attribute = function
| Sil.Apred (Aresource ra, [e])
| Predicates.Apred (Aresource ra, [e])
when not
( PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease
&& actual_pre_has_freed_attribute e ) ->
(* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find tenv post e in
let ra' = {ra with ra_pname= callee_pname; ra_loc= loc; ra_vpath= vpath} in
Sil.Apred (Aresource ra', [e])
Predicates.Apred (Aresource ra', [e])
| a ->
a
in
@ -506,24 +506,24 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre
let hpred_lhs_compare hpred1 hpred2 =
match (hpred1, hpred2) with
| Sil.Hpointsto (e1, _, _), Sil.Hpointsto (e2, _, _) ->
| Predicates.Hpointsto (e1, _, _), Predicates.Hpointsto (e2, _, _) ->
Exp.compare e1 e2
| Sil.Hpointsto _, _ ->
| Predicates.Hpointsto _, _ ->
-1
| _, Sil.Hpointsto _ ->
| _, Predicates.Hpointsto _ ->
1
| hpred1, hpred2 ->
Sil.compare_hpred hpred1 hpred2
Predicates.compare_hpred hpred1 hpred2
(** set the inst everywhere in a sexp *)
let rec sexp_set_inst inst = function
| Sil.Eexp (e, _) ->
Sil.Eexp (e, inst)
| Sil.Estruct (fsel, _) ->
Sil.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst)
| Sil.Earray (len, esel, _) ->
Sil.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst)
| Predicates.Eexp (e, _) ->
Predicates.Eexp (e, inst)
| Predicates.Estruct (fsel, _) ->
Predicates.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst)
| Predicates.Earray (len, esel, _) ->
Predicates.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst)
let rec fsel_star_fld fsel1 fsel2 =
@ -551,7 +551,7 @@ and esel_star_fld esel1 esel2 =
match (esel1, esel2) with
| [], esel2 ->
(* don't know whether element is read or written in fun call with array *)
List.map ~f:(fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2
List.map ~f:(fun (e, se) -> (e, sexp_set_inst Predicates.Inone se)) esel2
| esel1, [] ->
esel1
| (e1, se1) :: esel1', (e2, se2) :: esel2' -> (
@ -561,26 +561,26 @@ and 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
let se2' = sexp_set_inst Predicates.Inone se2 in
(* don't know whether element is read or written in fun call with array *)
(e2, se2') :: esel_star_fld esel1 esel2' )
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 (); *)
and sexp_star_fld se1 se2 : Predicates.strexp =
(* L.d_str "sexp_star_fld "; Predicates.d_sexp se1; L.d_str " "; Predicates.d_sexp se2; L.d_ln (); *)
match (se1, se2) with
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) ->
Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2)
| Sil.Earray (len1, esel1, _), Sil.Earray (_, esel2, inst2) ->
Sil.Earray (len1, esel_star_fld esel1 esel2, inst2)
| Sil.Eexp (_, inst1), Sil.Earray (len2, esel2, _) ->
| Predicates.Estruct (fsel1, _), Predicates.Estruct (fsel2, inst2) ->
Predicates.Estruct (fsel_star_fld fsel1 fsel2, inst2)
| Predicates.Earray (len1, esel1, _), Predicates.Earray (_, esel2, inst2) ->
Predicates.Earray (len1, esel_star_fld esel1 esel2, inst2)
| Predicates.Eexp (_, inst1), Predicates.Earray (len2, esel2, _) ->
let esel1 = [(Exp.zero, se1)] in
Sil.Earray (len2, esel_star_fld esel1 esel2, inst1)
Predicates.Earray (len2, esel_star_fld esel1 esel2, inst1)
| _ ->
L.d_str "cannot star " ;
Sil.d_sexp se1 ;
Predicates.d_sexp se1 ;
L.d_str " and " ;
Sil.d_sexp se2 ;
Predicates.d_sexp se2 ;
L.d_ln () ;
assert false
@ -619,22 +619,23 @@ let texp_star tenv texp1 texp2 =
texp1
let hpred_star_fld tenv (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred =
let hpred_star_fld tenv (hpred1 : Predicates.hpred) (hpred2 : Predicates.hpred) : Predicates.hpred =
match (hpred1, hpred2) with
| Sil.Hpointsto (e1, se1, t1), Sil.Hpointsto (_, se2, t2) ->
| Hpointsto (e1, se1, t1), 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 " 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 tenv t1 t2)
Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2)
| _ ->
assert false
(** Implementation of [*] for the field-splitting model *)
let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list =
let sigma_star_fld tenv (sigma1 : Predicates.hpred list) (sigma2 : Predicates.hpred list) :
Predicates.hpred list =
let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in
let sigma2 = List.stable_sort ~compare:hpred_lhs_compare sigma2 in
(* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *)
let rec star sg1 sg2 : Sil.hpred list =
let rec star sg1 sg2 : Predicates.hpred list =
match (sg1, sg2) with
| [], _ ->
[]
@ -660,19 +661,20 @@ let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Si
let hpred_typing_lhs_compare hpred1 (e2, _) =
match hpred1 with Sil.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1
match hpred1 with Predicates.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1
let hpred_star_typing (hpred1 : Sil.hpred) (_, te2) : Sil.hpred =
match hpred1 with Sil.Hpointsto (e1, se1, _) -> Sil.Hpointsto (e1, se1, te2) | _ -> assert false
let hpred_star_typing (hpred1 : Predicates.hpred) (_, te2) : Predicates.hpred =
match hpred1 with Hpointsto (e1, se1, _) -> Hpointsto (e1, se1, te2) | _ -> assert false
(** Implementation of [*] between predicates and typings *)
let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Exp.t * Exp.t) list) : Sil.hpred list =
let sigma_star_typ (sigma1 : Predicates.hpred list) (typings2 : (Exp.t * Exp.t) list) :
Predicates.hpred list =
let typing_lhs_compare (e1, _) (e2, _) = Exp.compare e1 e2 in
let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in
let typings2 = List.stable_sort ~compare:typing_lhs_compare typings2 in
let rec star sg1 typ2 : Sil.hpred list =
let rec star sg1 typ2 : Predicates.hpred list =
match (sg1, typ2) with
| [], _ ->
[]
@ -715,10 +717,11 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop : 'a Prop.t) pi_new sig
| [] ->
current_pi
| a :: new_pi' ->
if Sil.atom_free_vars a |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id)) then (
if Predicates.atom_free_vars a |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id))
then (
L.d_warning "dropping atom with non-footprint variable" ;
L.d_ln () ;
Sil.d_atom a ;
Predicates.d_atom a ;
L.d_ln () ;
extend_pi current_pi new_pi' )
else extend_pi (a :: current_pi) new_pi'
@ -770,7 +773,7 @@ let exp_is_exn = function Exp.Exn _ -> true | _ -> false
let prop_is_exn pname prop =
let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in
let is_exn = function
| Sil.Hpointsto (e1, Sil.Eexp (e2, _), _) when Exp.equal e1 ret_pvar ->
| Predicates.Hpointsto (e1, Predicates.Eexp (e2, _), _) when Exp.equal e1 ret_pvar ->
exp_is_exn e2
| _ ->
false
@ -784,7 +787,7 @@ let prop_get_exn_name pname prop =
let rec search_exn e = function
| [] ->
None
| Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}}) :: _ when Exp.equal e1 e ->
| Predicates.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}}) :: _ when Exp.equal e1 e ->
Some name
| _ :: tl ->
search_exn e tl
@ -792,7 +795,7 @@ let prop_get_exn_name pname prop =
let rec find_exn_name hpreds = function
| [] ->
None
| Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _) :: _ when Exp.equal e1 ret_pvar ->
| Predicates.Hpointsto (e1, Eexp (Exp.Exn e2, _), _) :: _ when Exp.equal e1 ret_pvar ->
search_exn e2 hpreds
| _ :: tl ->
find_exn_name hpreds tl
@ -806,8 +809,8 @@ let lookup_custom_errors prop =
let rec search_error = function
| [] ->
None
| Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _
when Pvar.equal var Sil.custom_error ->
| Predicates.Hpointsto (Exp.Lvar var, Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _
when Pvar.equal var Predicates.custom_error ->
Some error_str
| _ :: tl ->
search_error tl
@ -819,8 +822,8 @@ let lookup_custom_errors prop =
let prop_set_exn tenv pname prop se_exn =
let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in
let map_hpred = function
| Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar ->
Sil.Hpointsto (e, se_exn, t)
| Predicates.Hpointsto (e, _, t) when Exp.equal e ret_pvar ->
Predicates.Hpointsto (e, se_exn, t)
| hpred ->
hpred
in
@ -847,7 +850,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
if !BiabductionConfig.footprint && List.is_empty posts then
(* in case of divergence, produce a prop *)
(* with updated footprint and inconsistent current *)
[(Prop.set Prop.prop_emp ~pi:[Sil.Aneq (Exp.zero, Exp.zero)], path_pre)]
[(Prop.set Prop.prop_emp ~pi:[Predicates.Aneq (Exp.zero, Exp.zero)], path_pre)]
else
List.map
~f:(fun (p, path_post) ->
@ -896,7 +899,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
let handle_null_case_analysis sigma =
let id_assigned_to_null id =
let filter = function
| Sil.Aeq (Exp.Var id', Exp.Const (Const.Cint i)) ->
| Predicates.Aeq (Exp.Var id', Exp.Const (Const.Cint i)) ->
Ident.equal id id' && IntLit.isnull i
| _ ->
false
@ -906,12 +909,12 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
let f (e, inst_opt) =
match (e, inst_opt) with
| Exp.Var id, Some inst when id_assigned_to_null id ->
let inst' = Sil.inst_set_null_case_flag inst in
let inst' = Predicates.inst_set_null_case_flag inst in
(e, Some inst')
| _ ->
(e, inst_opt)
in
Sil.hpred_list_expmap f sigma
Predicates.hpred_list_expmap f sigma
in
let post_p2 =
let post_p1_sigma = post_p1.Prop.sigma in
@ -929,7 +932,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
post_p2
| Some iter -> (
let filter = function
| Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar ->
| Predicates.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar ->
Some ()
| _ ->
None
@ -939,14 +942,14 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
post_p2
| Some iter' -> (
match fst (Prop.prop_iter_current tenv iter') with
| Sil.Hpointsto (_, Sil.Eexp (e', inst), _) when exp_is_exn e' ->
| Predicates.Hpointsto (_, Eexp (e', inst), _) when exp_is_exn e' ->
(* resuls is an exception: set in caller *)
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
prop_set_exn tenv caller_pname p (Sil.Eexp (e', inst))
| Sil.Hpointsto (_, Sil.Eexp (e', _), _) ->
prop_set_exn tenv caller_pname p (Eexp (e', inst))
| Predicates.Hpointsto (_, Eexp (e', _), _) ->
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
Prop.conjoin_eq tenv e' (Exp.Var ret_id) p
| Sil.Hpointsto _ ->
| Predicates.Hpointsto _ ->
(* returning nothing or unexpected sexp, turning into nondet *)
Prop.prop_iter_remove_curr_then_to_prop tenv iter'
| _ ->
@ -998,7 +1001,7 @@ let mk_actual_precondition tenv prop actual_params formal_params =
in
let mk_instantiation (formal_var, (actual_e, actual_t)) =
Prop.mk_ptsto tenv (Exp.Lvar formal_var)
(Sil.Eexp (actual_e, Sil.inst_actual_precondition))
(Eexp (actual_e, Predicates.inst_actual_precondition))
(Exp.Sizeof {typ= actual_t; nbytes= None; dynamic_length= None; subtype= Subtype.exact})
in
let instantiated_formals = List.map ~f:mk_instantiation formals_actuals in
@ -1015,7 +1018,8 @@ let mk_posts tenv prop callee_pname posts =
let last_call_ret_non_null =
List.exists
~f:(function
| Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname ->
| Predicates.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname
->
Prover.check_disequal tenv prop exp Exp.zero
| _ ->
false )
@ -1025,7 +1029,7 @@ let mk_posts tenv prop callee_pname posts =
let returns_null prop =
List.exists
~f:(function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar ->
| Predicates.Hpointsto (Exp.Lvar pvar, Eexp (e, _), _) when Pvar.is_return pvar ->
Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero
| _ ->
false )
@ -1089,8 +1093,8 @@ let missing_sigma_need_adding_to_tenv tenv hpreds =
in
let missing_hpred_need_adding_to_tenv hpred =
match hpred with
| Sil.Hpointsto (_, Sil.Estruct (missing_fields, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}})
-> (
| Predicates.Hpointsto
(_, Estruct (missing_fields, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) -> (
match Tenv.lookup tenv name with
| Some struc ->
List.exists ~f:(field_is_missing struc) missing_fields
@ -1123,7 +1127,8 @@ let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hp
| Some callee_tenv ->
let add_field_in_hpred hpred =
match hpred with
| Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) -> (
| Predicates.Hpointsto (_, Estruct (_, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}})
-> (
match Tenv.lookup callee_tenv name with
| Some {fields} ->
List.iter ~f:(fun field -> Tenv.add_field caller_tenv name field) fields
@ -1172,7 +1177,7 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop
, missing_typ ) -> (
(* check if a missing_fld hpred is from a dyn language (ObjC) *)
let hpred_missing_objc_class = function
| Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) ->
| Predicates.Hpointsto (_, Estruct (_, _), Exp.Sizeof {typ}) ->
Typ.is_objc_class typ
| _ ->
false
@ -1250,7 +1255,7 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop
let remove_constant_string_class tenv prop =
let filter = function
| Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) ->
| Predicates.Hpointsto (Const (Cstr _ | Cclass _), _, _) ->
false
| _ ->
true
@ -1276,7 +1281,8 @@ let quantify_path_idents_remove_constant_strings tenv (prop : Prop.normal Prop.t
(** Strengthen the footprint by adding pure facts from the current part *)
let prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t =
let is_footprint_atom_not_attribute a =
(not (Attribute.is_pred a)) && Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint
(not (Attribute.is_pred a))
&& Predicates.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint
in
let pure = Prop.get_pure p in
let new_footprint_atoms = List.filter ~f:is_footprint_atom_not_attribute pure in
@ -1284,7 +1290,8 @@ let prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t =
else
(* add pure fact to footprint *)
let filtered_pi_fp =
List.filter (p.Prop.pi_fp @ new_footprint_atoms) ~f:(fun a -> not (Sil.atom_has_local_addr a))
List.filter (p.Prop.pi_fp @ new_footprint_atoms) ~f:(fun a ->
not (Predicates.atom_has_local_addr a) )
in
Prop.normalize tenv (Prop.set p ~pi_fp:filtered_pi_fp)

3
infer/src/biabduction/Tabulation.mli
Unescape View File

@ -34,7 +34,8 @@ val check_attr_dealloc_mismatch : PredSymb.t -> PredSymb.t -> unit
(** Check if the attribute change is a mismatch between a kind of allocation and a different kind of
deallocation *)
val find_dereference_without_null_check_in_sexp : Sil.strexp -> (int * PredSymb.path_pos) option
val find_dereference_without_null_check_in_sexp :
Predicates.strexp -> (int * PredSymb.path_pos) option
(** Check whether a sexp contains a dereference without null check, and return the line number and
path position *)

24
infer/src/biabduction/interproc.ml
Unescape View File

@ -292,8 +292,8 @@ let propagate_nodes_divergence tenv (proc_cfg : ProcCfg.Exceptional.t) (pset : P
let prop_incons =
let mk_incons prop =
let p_abs = Abs.abstract pname tenv prop in
let p_zero = Prop.set p_abs ~sub:Sil.sub_empty ~sigma:[] in
Prop.normalize tenv (Prop.set p_zero ~pi:[Sil.Aneq (Exp.zero, Exp.zero)])
let p_zero = Prop.set p_abs ~sub:Predicates.sub_empty ~sigma:[] in
Prop.normalize tenv (Prop.set p_zero ~pi:[Predicates.Aneq (Exp.zero, Exp.zero)])
in
Paths.PathSet.map mk_incons diverging_states
in
@ -581,7 +581,7 @@ let extract_specs tenv pdesc pathset : Prop.normal BiabductionSummary.spec list
|> Ident.HashQueue.keys
in
let sub_list = List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.knormal))) fav in
Sil.subst_of_list sub_list
Predicates.subst_of_list sub_list
in
let pre_post_visited_list =
let pplist = Paths.PathSet.elements pathset in
@ -679,8 +679,8 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * BiabductionSumma
let create_seed_vars sigma =
let hpred_add_seed sigma = function
| Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) ->
Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma
| Predicates.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) ->
Predicates.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma
| _ ->
sigma
in
@ -700,7 +700,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
| Java ->
Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
in
Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_formal (pv, texp, None)
Prop.mk_ptsto_lvar tenv Prop.Fld_init Predicates.inst_formal (pv, texp, None)
in
List.map ~f:do_formal new_formals
in
@ -723,7 +723,9 @@ let initial_prop tenv (curr_f : Procdesc.t) (prop : 'a Prop.t) ~add_formals : Pr
(* no new formals added *)
in
let prop1 =
Prop.prop_reset_inst (fun inst_old -> Sil.update_inst inst_old Sil.inst_formal) prop
Prop.prop_reset_inst
(fun inst_old -> Predicates.update_inst inst_old Predicates.inst_formal)
prop
in
let prop2 = prop_init_formals_seed tenv new_formals prop1 in
Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2)
@ -740,7 +742,7 @@ let initial_prop_from_pre tenv curr_f pre =
let sub_list =
List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.kfootprint))) vars
in
let sub = Sil.subst_of_list sub_list in
let sub = Predicates.subst_of_list sub_list in
let pre2 = Prop.prop_sub sub pre in
let pre3 = Prop.set pre2 ~pi_fp:(Prop.get_pure pre2) ~sigma_fp:pre2.Prop.sigma in
initial_prop tenv curr_f pre3 ~add_formals:false
@ -936,14 +938,14 @@ let custom_error_preconditions summary =
(* Remove the constrain of the form this != null which is true for all Java virtual calls *)
let remove_this_not_null tenv prop =
let collect_hpred (var_option, hpreds) = function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _)
| Predicates.Hpointsto (Exp.Lvar pvar, Eexp (Exp.Var var, _), _)
when Language.curr_language_is Java && Pvar.is_this pvar ->
(Some var, hpreds)
| hpred ->
(var_option, hpred :: hpreds)
in
let collect_atom var atoms = function
| Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null ->
| Predicates.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null ->
atoms
| a ->
a :: atoms
@ -1175,7 +1177,7 @@ let analyze_procedure_aux summary exe_env tenv : Summary.t =
let summary_compact =
match summaryre.Summary.payloads.biabduction with
| Some BiabductionSummary.({preposts} as biabduction) when Config.save_compact_summaries ->
let sharing_env = Sil.create_sharing_env () in
let sharing_env = Predicates.create_sharing_env () in
let compact_preposts =
List.map ~f:(BiabductionSummary.NormSpec.compact sharing_env) preposts
in

4
infer/src/bufferoverrun/bufferOverrunModels.ml
Unescape View File

@ -114,7 +114,7 @@ let fgets str_exp num_exp =
let malloc ~can_be_zero size_exp =
let exec ({pname; node_hash; location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem =
let size_exp = Prop.exp_normalize_noabs tenv Sil.sub_empty size_exp in
let size_exp = Prop.exp_normalize_noabs tenv Predicates.sub_empty size_exp in
let typ, stride, length0, dyn_length = get_malloc_info size_exp in
let length = Sem.eval integer_type_widths length0 mem in
let traces = Trace.(Set.add_elem location ArrayDeclaration) (Dom.Val.get_traces length) in
@ -263,7 +263,7 @@ let strcat dest_exp src_exp =
let realloc src_exp size_exp =
let exec ({location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem =
let size_exp = Prop.exp_normalize_noabs tenv Sil.sub_empty size_exp in
let size_exp = Prop.exp_normalize_noabs tenv Predicates.sub_empty size_exp in
let typ, _, length0, dyn_length = get_malloc_info size_exp in
let length = Sem.eval integer_type_widths length0 mem in
let v = Sem.eval integer_type_widths src_exp mem |> Dom.Val.set_array_length location ~length in

6
infer/src/topl/Topl.ml
Unescape View File

@ -161,16 +161,16 @@ let instrument tenv procdesc =
+ one cannot do boolean-conjunction on symbolic heaps; and
+ the prover fails to see that 0!=o.f * o|-f->0 is inconsistent *)
let lookup_static_var env (var : Exp.t) (prop : 'a Prop.t) : Exp.t option =
let from_strexp = function Sil.Eexp (e, _) -> Some e | _ -> None in
let from_strexp = function Predicates.Eexp (e, _) -> Some e | _ -> None in
let get_field field (f, e) = if Typ.Fieldname.equal field f then from_strexp e else None in
let get_strexp field = function
| Sil.Estruct (fs, _inst) ->
| Predicates.Estruct (fs, _inst) ->
List.find_map ~f:(get_field field) fs
| _ ->
None
in
let get_hpred obj field = function
| Sil.Hpointsto (obj', se, _typ) when Exp.equal obj obj' ->
| Predicates.Hpointsto (obj', se, _typ) when Exp.equal obj obj' ->
get_strexp field se
| _ ->
None

2
infer/src/topl/ToplMonitor.ml
Unescape View File

@ -120,7 +120,7 @@ let pure_exp e : Exp.t * Sil.instr list =
let es = List.dedup_and_sort ~compare:Exp.compare es in
let pairs = List.map ~f:(fun e -> (e, Ident.create_fresh Ident.knormal)) es in
let subst = List.map ~f:(function e, id -> (e, Exp.Var id)) pairs in
let e' = Sil.exp_replace_exp subst e in
let e' = Predicates.exp_replace_exp subst e in
let mk_load (e, id) =
Sil.Load
{id; e; root_typ= ToplUtils.any_type; typ= ToplUtils.any_type; loc= sourcefile_location ()}

Write Preview
Loading…
Cancel
Save