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 val instr_is_auxiliary : instr -> bool
(** Check if an instruction is auxiliary, or if it comes from source instructions. *) (** 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 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 (** 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) *) 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 val location_of_instr : instr -> Location.t
(** Get the location of the instruction *) (** 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 val d_instr : instr -> unit
(** Dump an instruction. *) (** 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 *) (** Check whether the hpred is a |-> representing a resource in the Racquire state *)
let hpred_is_open_resource tenv prop = function let hpred_is_open_resource tenv prop = function
| Sil.Hpointsto (e, _, _) -> ( | Predicates.Hpointsto (e, _, _) -> (
match Attribute.get_resource tenv prop e with match Attribute.get_resource tenv prop e with
| Some (Apred (Aresource {ra_kind= Racquire; ra_res= res}, _)) -> | Some (Apred (Aresource {ra_kind= Racquire; ra_res= res}, _)) ->
Some res Some res
@ -214,7 +214,7 @@ and exp_lv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option =
None ) None )
else else
let seen = Exp.Set.add e seen_ in 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 -> | Exp.Const c ->
if verbose then (L.d_str "exp_lv_dexp: constant " ; Exp.d_exp e ; L.d_ln ()) ; if verbose then (L.d_str "exp_lv_dexp: constant " ; Exp.d_exp e ; L.d_ln ()) ;
Some (DExp.Dderef (DExp.Dconst c)) 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 (** check whether the type of leaked [hpred] appears as a predicate
in an inductive predicate in [prop] *) in an inductive predicate in [prop] *)
let leak_from_list_abstraction hpred prop = let leak_from_list_abstraction hpred prop =
let hpred_type = function let hpred_type (hpred : Predicates.hpred) =
| Sil.Hpointsto (_, _, texp) -> match hpred with
| Hpointsto (_, _, texp) ->
Some texp Some texp
| Sil.Hlseg (_, {Sil.body= [Sil.Hpointsto (_, _, texp)]}, _, _, _) -> | Hlseg (_, {body= [Hpointsto (_, _, texp)]}, _, _, _) ->
Some texp Some texp
| Sil.Hdllseg (_, {Sil.body_dll= [Sil.Hpointsto (_, _, texp)]}, _, _, _, _, _) -> | Hdllseg (_, {body_dll= [Hpointsto (_, _, texp)]}, _, _, _, _, _) ->
Some texp Some texp
| _ -> | _ ->
None None
@ -421,12 +422,12 @@ let leak_from_list_abstraction hpred prop =
let check_hpred texp hp = let check_hpred texp hp =
match hpred_type hp with Some texp' when Exp.equal texp texp' -> found := true | _ -> () match hpred_type hp with Some texp' when Exp.equal texp texp' -> found := true | _ -> ()
in in
let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body 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.Sil.body_dll in let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Predicates.body_dll in
match hpred_type hpred with match hpred_type hpred with
| Some texp -> | Some texp ->
let env = Prop.prop_pred_env prop in 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 ( if !found then (
L.d_str "leak_from_list_abstraction of predicate of type " ; L.d_str "leak_from_list_abstraction of predicate of type " ;
Exp.d_texp_full texp ; Exp.d_texp_full texp ;
@ -437,13 +438,15 @@ let leak_from_list_abstraction hpred prop =
(** find the type of hpred, if any *) (** 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 *) (** find the type of pvar and remove the pointer, if any *)
let find_typ_without_ptr prop pvar = let find_typ_without_ptr prop pvar =
let res = ref None in let res = ref None in
let do_hpred = function 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 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 rec find sigma_acc sigma_todo exp =
let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) =
match se with 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 let sigma' = List.rev_append sigma_acc' sigma_todo' in
match lexp with match lexp with
| Exp.Lvar pv -> | Exp.Lvar pv ->
@ -604,7 +607,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
in in
let do_sexp sigma_acc' sigma_todo' lexp sexp texp = let do_sexp sigma_acc' sigma_todo' lexp sexp texp =
match sexp with 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 let sigma' = List.rev_append sigma_acc' sigma_todo' in
match lexp with match lexp with
| Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) -> | 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 ; Exp.d_exp lexp ;
L.d_ln () ) ; L.d_ln () ) ;
(None, None) ) (None, None) )
| Sil.Estruct (fsel, _) -> | Predicates.Estruct (fsel, _) ->
let res = ref (None, None) in let res = ref (None, None) in
List.iter ~f:(do_fse res sigma_acc' sigma_todo' lexp texp) fsel ; List.iter ~f:(do_fse res sigma_acc' sigma_todo' lexp texp) fsel ;
!res !res
@ -637,13 +640,13 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
| _ -> | _ ->
false false
in in
List.exists ~f:filter (Sil.sub_to_list prop.Prop.sub) List.exists ~f:filter (Predicates.sub_to_list prop.Prop.sub)
in in
function 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 -> when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv ->
do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp 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) -> when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) ->
do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp 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 = let access_opt ?(is_nullable = false) inst =
match inst with match (inst : Predicates.inst) with
| Sil.Iupdate (_, ncf, n, _) -> | Iupdate (_, ncf, n, _) ->
Some (Localise.Last_assigned (n, ncf)) Some (Localise.Last_assigned (n, ncf))
| Sil.Irearrange (_, _, n, _) -> | Irearrange (_, _, n, _) ->
Some (Localise.Last_accessed (n, is_nullable)) Some (Localise.Last_accessed (n, is_nullable))
| Sil.Ireturn_from_call n -> | Ireturn_from_call n ->
Some (Localise.Returned_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 Some Localise.Initialized_automatically
| inst -> | 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 None
@ -693,19 +697,19 @@ let explain_dexp_access prop dexp is_nullable =
let sexpo_to_inst = function let sexpo_to_inst = function
| None -> | None ->
None None
| Some (Sil.Eexp (_, inst)) -> | Some (Predicates.Eexp (_, inst)) ->
Some inst Some inst
| Some se -> | Some se ->
if verbose then ( if verbose then (
L.d_str "sexpo_to_inst: can't find inst " ; L.d_str "sexpo_to_inst: can't find inst " ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_ln () ) ; L.d_ln () ) ;
None None
in 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 res = ref None in
let do_hpred = function 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 res := Some se
| _ -> | _ ->
() ()
@ -731,28 +735,28 @@ let explain_dexp_access prop dexp is_nullable =
| (e1, se) :: esel' -> | (e1, se) :: esel' ->
if Exp.equal e1 e then Some se else lookup_esel esel' e if Exp.equal e1 e then Some se else lookup_esel esel' e
in in
let rec lookup : DExp.t -> Sil.strexp option = function let rec lookup : DExp.t -> Predicates.strexp option = function
| DExp.Dconst c -> | 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) -> ( | DExp.Darray (de1, de2) -> (
match (lookup de1, lookup de2) with match (lookup de1, lookup de2) with
| None, _ | _, None -> | None, _ | _, None ->
None None
| Some (Sil.Earray (_, esel, _)), Some (Sil.Eexp (e, _)) -> | Some (Predicates.Earray (_, esel, _)), Some (Predicates.Eexp (e, _)) ->
lookup_esel esel e lookup_esel esel e
| Some se1, Some se2 -> | Some se1, Some se2 ->
if verbose then ( if verbose then (
L.d_str "lookup: case not matched on Darray " ; L.d_str "lookup: case not matched on Darray " ;
Sil.d_sexp se1 ; Predicates.d_sexp se1 ;
L.d_str " " ; L.d_str " " ;
Sil.d_sexp se2 ; Predicates.d_sexp se2 ;
L.d_ln () ) ; L.d_ln () ) ;
None ) None )
| DExp.Darrow (DExp.Dpvaraddr pvar, f) -> ( | DExp.Darrow (DExp.Dpvaraddr pvar, f) -> (
match lookup (DExp.Dpvaraddr pvar) with match lookup (DExp.Dpvaraddr pvar) with
| None -> | None ->
None None
| Some (Sil.Estruct (fsel, _)) -> | Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f lookup_fld fsel f
| Some _ -> | Some _ ->
if verbose then L.d_strln "lookup: case not matched on Darrow" ; 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 match lookup (DExp.Dderef de1) with
| None -> | None ->
None None
| Some (Sil.Estruct (fsel, _)) -> | Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f lookup_fld fsel f
| Some _ -> | Some _ ->
if verbose then L.d_strln "lookup: case not matched on Darrow" ; 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 match lookup de1 with
| None -> | None ->
None None
| Some (Sil.Estruct (fsel, _)) -> | Some (Predicates.Estruct (fsel, _)) ->
lookup_fld fsel f lookup_fld fsel f
| Some (Sil.Eexp (Const (Cfun _), _) as fun_strexp) -> | Some (Predicates.Eexp (Const (Cfun _), _) as fun_strexp) ->
Some fun_strexp Some fun_strexp
| Some _ -> | Some _ ->
if verbose then L.d_strln "lookup: case not matched on Ddot" ; 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" ; if verbose then L.d_strln "lookup: found Dpvar" ;
find_ptsto (Exp.Lvar pvar) find_ptsto (Exp.Lvar pvar)
| DExp.Dderef de -> ( | 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 -> | DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de ->
if verbose then L.d_printfln "lookup: case )pvar + constant) %a" DExp.pp de ; if verbose then L.d_printfln "lookup: case )pvar + constant) %a" DExp.pp de ;
None None
@ -790,7 +800,7 @@ let explain_dexp_access prop dexp is_nullable =
match c with match c with
| Const.Cfun _ -> | Const.Cfun _ ->
(* Treat function as an update *) (* 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 ) None )
| DExp.Dpvaraddr pvar -> | 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)) if is_none !res then res := Some (pv, Fstruct (List.rev fld_lst))
in in
let rec search_struct pv fld_lst = function 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 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 List.iter ~f:(fun (f, se) -> search_struct pv (f :: fld_lst) se) fsel
| _ -> | _ ->
() ()
in in
let do_hpred_pointed_by_pvar pv e = function 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 if Exp.equal e e1 then search_struct pv [] se
| _ -> | _ ->
() ()
in in
let do_hpred = function 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 if Exp.equal e exp then found_in_pvar pv
else List.iter ~f:(do_hpred_pointed_by_pvar pv e) prop.Prop.sigma 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 (** find the dexp, if any, where the given value is stored also return the type of the value if
found *) 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 *) (** Check whether the hpred is a |-> representing a resource in the Racquire state *)
val find_normal_variable_funcall : val find_normal_variable_funcall :
@ -107,7 +107,7 @@ val explain_unary_minus_applied_to_unsigned_expression :
val explain_leak : val explain_leak :
Tenv.t Tenv.t
-> Sil.hpred -> Predicates.hpred
-> 'a Prop.t -> 'a Prop.t
-> PredSymb.t option -> PredSymb.t option
-> string 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 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_root: Match.hpred_pat
; r_sigma: Match.hpred_pat list ; r_sigma: Match.hpred_pat list
; (* sigma should be in a specific order *) ; (* sigma should be in a specific order *)
r_new_sigma: Sil.hpred list r_new_sigma: Predicates.hpred list
; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Sil.subst -> Sil.atom list ; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Predicates.subst -> Predicates.atom list
; r_condition: Prop.normal Prop.t -> Sil.subst -> bool } ; r_condition: Prop.normal Prop.t -> Predicates.subst -> bool }
let sigma_rewrite tenv p r : Prop.normal Prop.t option = 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 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_next = Ident.create_fresh Ident.kprimed in
let id_end = Ident.create_fresh Ident.kprimed in let id_end = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars in let svars = para.Predicates.svars in
let f _ = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars List.map ~f svars
in in
@ -56,15 +56,16 @@ let create_fresh_primeds_ls para =
(ids_tuple, exps_tuple) (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 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 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 inst_private, inst_public = Predicates.sub_domain_partition f inst in
let insts_of_public_ids = Sil.sub_range inst_public in let insts_of_public_ids = Predicates.sub_range inst_public in
let inst_of_base = 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 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) (insts_of_private_ids, insts_of_public_ids, inst_of_base)
in 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 ) 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 ids_tuple, exps_tuple = create_fresh_primeds_ls para in
let id_base, id_next, id_end, ids_shared = ids_tuple 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 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 para_fst_start, para_fst_rest =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in
match para_fst with 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 assert false
| hpred :: hpreds -> | hpred :: hpreds ->
let hpat = mark_impl_flag hpred in 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 in
let ids_exist_snd, para_snd = let ids_exist_snd, para_snd =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in 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 let para_body_hpats = List.map ~f:mark_impl_flag para_body in
(ids, para_body_hpats) (ids, para_body_hpats)
in in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in
create_condition_ls ids_private id_base 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 ids_tuple, exps_tuple = create_fresh_primeds_ls para in
let id_base, id_next, id_end, ids_shared = ids_tuple 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 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 = let para_inst_start, para_inst_rest =
match para_inst with 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 assert false
| hpred :: hpreds -> | hpred :: hpreds ->
let allow_impl hpred = {Match.hpred; Match.flag= impl_ok1} in 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 = let lseg_pat =
{Match.hpred= Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag= impl_ok2} {Match.hpred= Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag= impl_ok2}
in in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
let ids_private = id_next :: ids_exist in let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base 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} {Match.hpred= Prop.mk_lseg tenv k1 para exp_base exp_next exps_shared; Match.flag= impl_ok1}
in in
let ids_exist, para_inst_pat = 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 allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in
let para_body_pat = List.map ~f:allow_impl para_body in let para_body_pat = List.map ~f:allow_impl para_body in
(ids, para_body_pat) (ids, para_body_pat)
in in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
let ids_private = id_next :: ids_exist in let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base 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 } ; 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 match (k1, k2) with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE -> | Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_NE ->
Sil.Lseg_NE Lseg_NE
| Sil.Lseg_PE, Sil.Lseg_PE -> | Lseg_PE, Lseg_PE ->
Sil.Lseg_PE Lseg_PE
let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = 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 in
let k_res = lseg_kind_add k1 k2 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 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 = 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) (find id_base, find id_next, find id_end)
with Not_found -> assert false in with Not_found -> assert false in
let spooky_case _ = 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_allocatedness p_leftover inst_end)
&& ((check_disequal p_start inst_base inst_next) && ((check_disequal p_start inst_base inst_next)
|| (check_disequal p_start inst_next inst_end)) in || (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 } ; 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 if not Config.nelseg then
let pts_pts = mk_rule_ptspts_ls tenv true true para in 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 pts_pels = mk_rule_ptsls_ls tenv Lseg_PE true false para in
let pels_pts = mk_rule_lspts_ls tenv Sil.Lseg_PE false true para in let pels_pts = mk_rule_lspts_ls tenv 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 pels_nels = mk_rule_lsls_ls tenv Lseg_PE 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 nels_pels = mk_rule_lsls_ls tenv Lseg_NE 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 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] [pts_pts; pts_pels; pels_pts; pels_nels; nels_pels; pels_pels]
else else
let pts_pts = mk_rule_ptspts_ls tenv true true para in 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 pts_nels = mk_rule_ptsls_ls tenv Lseg_NE true false para in
let nels_pts = mk_rule_lspts_ls tenv Sil.Lseg_NE false true para in let nels_pts = mk_rule_lspts_ls tenv 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 nels_nels = mk_rule_lsls_ls tenv Lseg_NE Lseg_NE false false para in
[pts_pts; pts_nels; nels_pts; nels_nels] [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_oB = Ident.create_fresh Ident.kprimed in
let id_oF = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared = 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 let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars List.map ~f svars
in 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_oB = Exp.Var id_oB in
let exp_oF = Exp.Var id_oF in let exp_oF = Exp.Var id_oF in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared 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 para_fst_start, para_fst_rest =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in
match para_fst with 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 assert false
| hpred :: hpreds -> | hpred :: hpreds ->
let hpat = mark_impl_flag hpred in let hpat = mark_impl_flag hpred in
@ -290,12 +294,12 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para =
in in
let ids_exist_snd, para_snd = let ids_exist_snd, para_snd =
let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in 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 let para_body_hpats = List.map ~f:mark_impl_flag para_body in
(ids, para_body_hpats) (ids, para_body_hpats)
in in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared 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 _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
(* for the case of ptspts since iF'=iB therefore iF' cannot be private*) (* for the case of ptspts since iF'=iB therefore iF' cannot be private*)
let ids_private = ids_exist_fst @ ids_exist_snd in 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_oF = Ident.create_fresh Ident.kprimed in
let id_iB = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared = 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 let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars List.map ~f svars
in 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_oF = Exp.Var id_oF in
let exp_iB = Exp.Var id_iB in let exp_iB = Exp.Var id_iB in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared 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 = let para_inst_start, para_inst_rest =
match para_inst with 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.hpred= Prop.mk_dllseg tenv k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared
; Match.flag= impl_ok2 } ; Match.flag= impl_ok2 }
in in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared 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 _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
let ids_private = id_iF' :: ids_exist in let ids_private = id_iF' :: ids_exist in
create_condition_dll ids_private id_iF 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_oB' = Ident.create_fresh Ident.kprimed in
let id_oF = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared = 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 let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars List.map ~f svars
in 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_oB' = Exp.Var id_oB' in
let exp_oF = Exp.Var id_oF in let exp_oF = Exp.Var id_oF in
let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared 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 para_inst_pat =
let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in
List.map ~f:allow_impl para_inst 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.hpred= Prop.mk_dllseg tenv k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared
; Match.flag= impl_ok1 } ; Match.flag= impl_ok1 }
in in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared 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 _ _ (_ : Sil.subst) = [] in let gen_pi_res _ _ (_ : Predicates.subst) = [] in
let condition = let condition =
let ids_private = id_oB' :: ids_exist in let ids_private = id_oB' :: ids_exist in
create_condition_dll ids_private id_iF 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_oF = Ident.create_fresh Ident.kprimed in
let id_iB = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared = 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 let f _ = Ident.create_fresh Ident.kprimed in
List.map ~f svars List.map ~f svars
in in
@ -428,7 +436,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para =
in in
let k_res = lseg_kind_add k1 k2 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 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 condition =
let ids_private = [id_iF'; id_oB'] in let ids_private = [id_iF'; id_oB'] in
create_condition_dll ids_private id_iF 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 } ; 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 if not Config.nelseg then
let pts_pts = mk_rule_ptspts_dll tenv true true para in 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 pts_pedll = mk_rule_ptsdll_dll tenv Lseg_PE true false para in
let pedll_pts = mk_rule_dllpts_dll tenv Sil.Lseg_PE false true para in let pedll_pts = mk_rule_dllpts_dll tenv 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 pedll_nedll = mk_rule_dlldll_dll tenv Lseg_PE 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 nedll_pedll = mk_rule_dlldll_dll tenv Lseg_NE 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 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] [pts_pts; pts_pedll; pedll_pts; pedll_nedll; nedll_pedll; pedll_pedll]
else else
let ptspts_dll = mk_rule_ptspts_dll tenv true true para in 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 ptsdll_dll = mk_rule_ptsdll_dll tenv Lseg_NE true false para in
let dllpts_dll = mk_rule_dllpts_dll tenv Sil.Lseg_NE false true para in let dllpts_dll = mk_rule_dllpts_dll tenv 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 dlldll_dll = mk_rule_dlldll_dll tenv Lseg_NE Lseg_NE false false para in
[ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll] [ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll]
@ -493,7 +501,7 @@ let typ_get_recursive_flds tenv typ_exp =
assert false 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_arg1 = Exp.equal root1 next1 in
let eq_arg2 = Exp.equal root2 next2 in let eq_arg2 = Exp.equal root2 next2 in
let precondition_check = (not eq_arg1) && not eq_arg2 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 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 blink1 in
let eq_arg1' = Exp.equal root1 flink1 in let eq_arg1' = Exp.equal root1 flink1 in
let eq_arg2 = Exp.equal root2 blink2 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 get_edges_strexp rec_flds root se =
let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in
match se with 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 fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let process (_, nextse) = 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 in
List.iter ~f:process fsel' List.iter ~f:process fsel'
in in
let rec get_edges_sigma = function 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 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 let rec_flds = typ_get_recursive_flds tenv te in
get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest
in in
@ -577,12 +586,12 @@ let discover_para_dll_candidates tenv p =
let get_edges_strexp rec_flds root se = let get_edges_strexp rec_flds root se =
let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in
match se with 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 fsel' = List.rev_filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let convert_to_exp acc (_, se) = 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 in
let links = List.fold ~f:convert_to_exp ~init:[] fsel' in let links = List.fold ~f:convert_to_exp ~init:[] fsel' in
let rec iter_pairs = function let rec iter_pairs = function
@ -597,9 +606,9 @@ let discover_para_dll_candidates tenv p =
let rec get_edges_sigma = function 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 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 let rec_flds = typ_get_recursive_flds tenv te in
get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest
in in
@ -659,7 +668,7 @@ let discover_para_dll tenv p =
(****************** Start of the ADT abs_rules ******************) (****************** Start of the ADT abs_rules ******************)
(** Type of parameter for abstraction 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 *) (** Rule set: a list of rules of a given type *)
type rule_set = para_ty * rule list 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 reset_current_rules () = Global.current_rules := []
let eqs_sub subst eqs = 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 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 = let do_default id e eqs_rest =
if not (List.exists ~f:(fun id' -> Ident.equal id id') ids_in) then None if not (List.exists ~f:(fun id' -> Ident.equal id id') ids_in) then None
else else
let sub' = let sub' =
match Sil.extend_sub sub id e with match Predicates.extend_sub sub id e with
| None -> | None ->
L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ; L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ;
assert false assert false
@ -714,32 +723,36 @@ let eqs_solve ids_in eqs_in =
None None
in in
let compute_ids sub = 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 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 let filter id = not (List.exists ~f:(fun id' -> Ident.equal id id') sub_dom) in
List.filter ~f:filter ids_in List.filter ~f:filter ids_in
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 sigma_special_cases_eqs sigma =
let rec f ids_acc eqs_acc sigma_acc = function let rec f ids_acc eqs_acc sigma_acc = function
| [] -> | [] ->
[(List.rev ids_acc, List.rev eqs_acc, List.rev sigma_acc)] [(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 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 empty_case = f ids_acc ((e1, e2) :: eqs_acc) sigma_acc sigma_rest in
let pointsto_case = 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) f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest)
in in
let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in
empty_case @ pointsto_case @ general_case 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 empty_case = f ids_acc ((e1, e3) :: (e2, e4) :: eqs_acc) sigma_acc sigma_rest in
let pointsto_case = 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) f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest)
in in
let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) 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 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_eqs = sigma_special_cases_eqs sigma in
let special_cases_rev = let special_cases_rev =
let f acc (eids_cur, eqs_cur, sigma_cur) = 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 -> | None ->
acc acc
| Some (ids_res, sub) -> | 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 in
List.fold ~f ~init:[] special_cases_eqs List.fold ~f ~init:[] special_cases_eqs
in in
List.rev special_cases_rev List.rev special_cases_rev
let hpara_special_cases hpara : Sil.hpara list = let hpara_special_cases hpara : Predicates.hpara list =
let update_para (evars', body') = {hpara with Sil.evars= evars'; Sil.body= body'} in let update_para (evars', body') = {hpara with Predicates.evars= evars'; Predicates.body= body'} in
let special_cases = sigma_special_cases hpara.Sil.evars hpara.Sil.body in let special_cases = sigma_special_cases hpara.Predicates.evars hpara.Predicates.body in
List.map ~f:update_para special_cases List.map ~f:update_para special_cases
let hpara_special_cases_dll hpara : Sil.hpara_dll list = let hpara_special_cases_dll hpara : Predicates.hpara_dll list =
let update_para (evars', body') = {hpara with Sil.evars_dll= evars'; Sil.body_dll= body'} in let update_para (evars', body') =
let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in {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 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 let fav_nonpure = Prop.non_pure_free_vars p |> Ident.set_of_sequence in
(* vars in current and footprint sigma *) (* vars in current and footprint sigma *)
let filter atom = let filter atom =
Sil.atom_free_vars atom Predicates.atom_free_vars atom
|> Sequence.for_all ~f:(fun id -> |> Sequence.for_all ~f:(fun id ->
if Ident.is_primed id then Ident.Set.mem id fav_sigma 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 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 = let new_pure =
List.fold List.fold
~f:(fun pi a -> ~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. *) (* 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, _, _)) | Aeq (Const (Cint i), BinOp (Lt, _, _))
| Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const (Const.Cint i)) | Aeq (BinOp (Lt, _, _), Const (Cint i))
| Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, _, _)) | Aeq (Const (Cint i), BinOp (Le, _, _))
| Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const (Const.Cint i)) | Aeq (BinOp (Le, _, _), Const (Cint i))
when IntLit.isone i -> when IntLit.isone i ->
a :: pi a :: pi
| Sil.Aeq (Exp.Var name, e) when not (Ident.is_primed name) -> ( | Aeq (Var name, e) when not (Ident.is_primed name) -> (
match e with Exp.Var _ | Exp.Const _ -> a :: pi | _ -> pi ) match e with Var _ | Const _ -> a :: pi | _ -> pi )
| Sil.Aneq (Var _, _) | Sil.Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) -> | Aneq (Var _, _) | Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) ->
a :: pi a :: pi
| Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> | Aeq _ | Aneq _ | Apred _ | Anpred _ ->
pi ) pi )
~init:[] pi_filtered ~init:[] pi_filtered
in in
List.rev new_pure List.rev new_pure
in in
let new_pure = do_pure (Prop.get_pure p) 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'' = let eprop'' =
if !BiabductionConfig.footprint && not from_abstract_footprint then if !BiabductionConfig.footprint && not from_abstract_footprint then
let new_pi_footprint = do_pure p.Prop.pi_fp in 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) Sequence.exists fav_seq ~f:(fun id -> Ident.Set.mem id fav_p_without_pi)
in in
let strong_filter = function 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) check (Exp.free_vars e1) && check (Exp.free_vars e2)
| (Sil.Apred _ | Anpred _) as a -> | (Predicates.Apred _ | Anpred _) as a ->
check (Sil.atom_free_vars a) check (Predicates.atom_free_vars a)
in in
let new_pi = List.filter ~f:strong_filter pi in let new_pi = List.filter ~f:strong_filter pi in
let prop = Prop.normalize tenv (Prop.set p ~pi:new_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 reach_set = ref root_fav in
let edges = ref [] in let edges = ref [] in
let do_hpred hpred = 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 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 in
List.iter ~f:do_hpred sigma ; List.iter ~f:do_hpred sigma ;
let edge_fires (e, _) = let edge_fires (e, _) =
@ -962,7 +977,7 @@ let sigma_reachable root_fav sigma =
in in
find_fixpoint !edges ; find_fixpoint !edges ;
(* L.d_str "reachable: "; (* 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 (); *) L.d_ln (); *)
!reach_set !reach_set
@ -1015,7 +1030,7 @@ let check_junk pname tenv prop =
| [] -> | [] ->
List.rev sigma_done List.rev sigma_done
| hpred :: sigma_todo' -> | hpred :: sigma_todo' ->
let entries = Sil.hpred_entries hpred in let entries = Predicates.hpred_entries hpred in
if should_remove_hpred entries then ( if should_remove_hpred entries then (
let part = if fp_part then "footprint" else "normal" in let part = if fp_part then "footprint" else "normal" in
L.d_printfln ".... Prop with garbage in %s part ...." part ; 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' else remove_junk fp_part fav_root sigma'
in in
let sigma_new = 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 = let fav_sub_sigmafp =
Prop.sigma_free_vars prop.Prop.sigma_fp |> Ident.set_of_sequence ~init:fav_sub Prop.sigma_free_vars prop.Prop.sigma_fp |> Ident.set_of_sequence ~init:fav_sub
in in
@ -1164,9 +1179,9 @@ let remove_pure_garbage tenv ?(count = fun _ -> 0) prop =
let changed = ref false in let changed = ref false in
let rec go prop = let rec go prop =
let propcount = prop |> Prop.free_vars |> Ident.counts_of_sequence in 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 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 pi = List.filter ~f:keep prop.Prop.pi in
let dropped = List.length pi < List.length prop.Prop.pi in let dropped = List.length pi < List.length prop.Prop.pi in
changed := !changed || dropped ; 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 a disequality. As a workaround, here we drop pure facts from the consequent that are known to
be true. *) be true. *)
let module AtomSet = Caml.Set.Make (struct 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 end) in
let pre_pure = let pre_pure =
let pre = Jprop.to_prop spec.pre in 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 get_local_stack cur_sigma init_sigma =
let filter_stack = function let filter_stack = function
| Sil.Hpointsto (Exp.Lvar _, _, _) -> | Predicates.Hpointsto (Exp.Lvar _, _, _) ->
true true
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
false false
in in
let get_stack_var = function let get_stack_var = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> | Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
pvar pvar
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
assert false assert false
in in
let filter_local_stack olds = function let filter_local_stack olds = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> | Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
not (List.exists ~f:(Pvar.equal pvar) olds) not (List.exists ~f:(Pvar.equal pvar) olds)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
false false
in in
let init_stack = List.filter ~f:filter_stack init_sigma 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 remove_local_stack sigma pvars =
let filter_non_stack = function let filter_non_stack = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> | Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
not (List.exists ~f:(Pvar.equal pvar) pvars) not (List.exists ~f:(Pvar.equal pvar) pvars)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
true true
in in
List.filter ~f:filter_non_stack sigma 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 *) (** Abstraction for Arrays *)
type sigma = Sil.hpred list type sigma = Predicates.hpred list
(** Matcher for the sigma part specialized to strexps *) (** Matcher for the sigma part specialized to strexps *)
module StrexpMatch : sig module StrexpMatch : sig
@ -39,11 +39,11 @@ module StrexpMatch : sig
val path_to_exps : path -> Exp.t list val path_to_exps : path -> Exp.t list
(** convert a path into a list of expressions *) (** 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 *) (** create a path from a root and a list of offsets *)
(** path to the root, length, elements and type of a new_array *) (** 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 *) (** sigma with info about a current array *)
type t type t
@ -57,7 +57,7 @@ module StrexpMatch : sig
val get_data : Tenv.t -> t -> strexp_data val get_data : Tenv.t -> t -> strexp_data
(** Get the array *) (** 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 *) (** Replace the strexp at a given position by a new strexp *)
val replace_index : Tenv.t -> bool -> t -> Exp.t -> Exp.t -> sigma val replace_index : Tenv.t -> bool -> t -> Exp.t -> Exp.t -> sigma
@ -74,7 +74,7 @@ end = struct
let fail () = let fail () =
L.d_strln "Failure of get_strexp_at_syn_offsets" ; L.d_strln "Failure of get_strexp_at_syn_offsets" ;
L.d_str "se: " ; L.d_str "se: " ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_ln () ; L.d_ln () ;
L.d_str "t: " ; L.d_str "t: " ;
Typ.d_full t ; Typ.d_full t ;
@ -84,7 +84,7 @@ end = struct
match (se, t.desc, syn_offs) with match (se, t.desc, syn_offs) with
| _, _, [] -> | _, _, [] ->
(se, t) (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 match Tenv.lookup tenv name with
| Some {fields} -> | Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in 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' get_strexp_at_syn_offsets tenv se' t' syn_offs'
| None -> | None ->
fail () ) 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 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' get_strexp_at_syn_offsets tenv se' t' syn_offs'
| _ -> | _ ->
@ -104,7 +104,7 @@ end = struct
match (se, t.desc, syn_offs) with match (se, t.desc, syn_offs) with
| _, _, [] -> | _, _, [] ->
update se 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 match Tenv.lookup tenv name with
| Some {fields} -> | Some {fields} ->
let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in 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'') ) if Typ.Fieldname.equal f'' fld then (fld, se_mod) else (f'', se'') )
fsel fsel
in in
Sil.Estruct (fsel', inst) Predicates.Estruct (fsel', inst)
| None -> | None ->
assert false ) 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' = 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 se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let esel' = let esel' =
List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel
in in
Sil.Earray (len, esel', inst) Predicates.Earray (len, esel', inst)
| _ -> | _ ->
assert false assert false
@ -151,9 +151,9 @@ end = struct
(** create a path from a root and a list of offsets *) (** create a path from a root and a list of offsets *)
let path_from_exp_offsets root offs = let path_from_exp_offsets root offs =
let offset_to_syn_offset = function let offset_to_syn_offset = function
| Sil.Off_fld (fld, typ) -> | Predicates.Off_fld (fld, typ) ->
Field (fld, typ) Field (fld, typ)
| Sil.Off_index idx -> | Predicates.Off_index idx ->
Index idx Index idx
in in
let syn_offs = List.map ~f:offset_to_syn_offset offs 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 *) (** 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 *) (** 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] *) (** Find an array at the given path. Can raise [Not_found] *)
let find_path sigma (root, syn_offs) : t = 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 let hpred = List.find_exn ~f:filter sigma in
(sigma, hpred, syn_offs) (sigma, hpred, syn_offs)
@ -182,13 +182,13 @@ end = struct
if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found
else else
match (se, typ.desc) with match (se, typ.desc) with
| Sil.Estruct (fsel, _), Tstruct name -> ( | Predicates.Estruct (fsel, _), Tstruct name -> (
match Tenv.lookup tenv name with match Tenv.lookup tenv name with
| Some {fields} -> | Some {fields} ->
find_offset_fsel sigma_other hpred root offs fsel fields typ find_offset_fsel sigma_other hpred root offs fsel fields typ
| None -> | None ->
() ) () )
| Sil.Earray (_, esel, _), Tarray {elt} -> | Predicates.Earray (_, esel, _), Tarray {elt} ->
find_offset_esel sigma_other hpred root offs esel elt find_offset_esel sigma_other hpred root offs esel elt
| _ -> | _ ->
() ()
@ -216,7 +216,7 @@ end = struct
() ()
| hpred :: sigma_rest -> | hpred :: sigma_rest ->
( match hpred with ( match hpred with
| Sil.Hpointsto (root, se, te) -> | Predicates.Hpointsto (root, se, te) ->
let sigma_other = sigma_seen @ sigma_rest in let sigma_other = sigma_seen @ sigma_rest in
find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te) find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te)
| _ -> | _ ->
@ -229,7 +229,7 @@ end = struct
(** Get the matched strexp *) (** Get the matched strexp *)
let get_data tenv ((_, hpred, syn_offs) : t) = let get_data tenv ((_, hpred, syn_offs) : t) =
match hpred with match hpred with
| Sil.Hpointsto (root, se, te) -> | Predicates.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in let t = Exp.texp_to_typ None te in
let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in
let path' = (root, syn_offs) in let path' = (root, syn_offs) in
@ -248,22 +248,22 @@ end = struct
let update se' = let update se' =
let se_in = update se' in let se_in = update se' in
match (se', se_in) with 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 orig_indices = List.map ~f:fst esel in
let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in
let process_index idx = let process_index idx =
if index_is_not_new idx then idx else array_clean_new_index footprint_part idx if index_is_not_new idx then idx else array_clean_new_index footprint_part idx
in in
let esel_in' = List.map ~f:(fun (idx, se) -> (process_index idx, se)) esel_in 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 se_in
in in
match hpred with match hpred with
| Sil.Hpointsto (root, se, te) -> | Predicates.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in let t = Exp.texp_to_typ None te in
let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update 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 assert false
@ -280,13 +280,13 @@ end = struct
(index' : Exp.t) = (index' : Exp.t) =
let update se' = let update se' =
match se' with match se' with
| Sil.Earray (len, esel, inst) -> | Predicates.Earray (len, esel, inst) ->
let esel' = let esel' =
List.map List.map
~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se')) ~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se'))
esel esel
in in
Sil.Earray (len, esel', inst) Predicates.Earray (len, esel', inst)
| _ -> | _ ->
assert false assert false
in in
@ -407,7 +407,7 @@ let index_is_pointed_to tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path)
in in
let pointers = List.concat_map ~f:add_index_to_paths indices in let pointers = List.concat_map ~f:add_index_to_paths indices in
let filter = function let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) -> | Predicates.Hpointsto (_, Predicates.Eexp (e, _), _) ->
List.exists ~f:(Exp.equal e) pointers List.exists ~f:(Exp.equal e) pointers
| _ -> | _ ->
false 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 matched = StrexpMatch.find_path sigma path in
let _, se, _ = StrexpMatch.get_data tenv matched in let _, se, _ = StrexpMatch.get_data tenv matched in
match se with match se with
| Sil.Earray (len, esel, inst) -> | Predicates.Earray (len, esel, inst) ->
let esel', esel_leftover' = let esel', esel_leftover' =
List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel
in in
if List.is_empty esel_leftover' then (sigma, false) if List.is_empty esel_leftover' then (sigma, false)
else 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 let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in
(sigma', true) (sigma', true)
| _ -> | _ ->
@ -493,7 +493,7 @@ let array_typ_can_abstract {Typ.desc} =
let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool = let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool =
let can_abstract_se = let can_abstract_se =
match se with match se with
| Sil.Earray (_, esel, _) -> | Predicates.Earray (_, esel, _) ->
let len = List.length esel in let len = List.length esel in
len > 1 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 partition_abstract should_keep abstract esel default_indices
in in
let do_footprint () = 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 in
let filter_abstract d_keys should_keep abstract ksel default_keys = let filter_abstract d_keys should_keep abstract ksel default_keys =
let keep_ksel = List.filter ~f:should_keep ksel in 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 [] filter_abstract Exp.d_list should_keep abstract esel []
in in
let do_reexecution () = 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 in
if !BiabductionConfig.footprint then do_footprint () else do_reexecution () 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) else not (Exp.free_vars ind |> Sequence.exists ~f:Ident.is_primed)
in in
let rec check_se root offs typ = function 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 *) (* check that no more than 2 elements are in the array *)
let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in 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.length esel > 2 && array_typ_can_abstract typ then
if List.for_all ~f:(check_index root offs) esel then () else report_error prop if List.for_all ~f:(check_index root offs) esel then () else report_error prop
else else
List.iter 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 esel
| Sil.Estruct (fsel, _) -> | Predicates.Estruct (fsel, _) ->
List.iter List.iter
~f:(fun (f, se) -> ~f:(fun (f, se) ->
let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in 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 fsel
in in
let check_hpred = function 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 let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in
check_se root [] typ se check_se root [] typ se
| Sil.Hlseg _ | Sil.Hdllseg _ -> | Predicates.Hlseg _ | Predicates.Hdllseg _ ->
() ()
in in
let check_sigma sigma = List.iter ~f:check_hpred sigma 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 occurs_at_most_once : Ident.t -> bool =
let fav_curr = let fav_curr =
let ( @@@ ) = Sequence.append in 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 @@@ Prop.sigma_free_vars prop.Prop.sigma
in in
let fav_foot = let fav_foot =
@ -657,34 +662,34 @@ let remove_redundant_elements tenv prop =
L.d_strln "kill_redundant: removing " ; L.d_strln "kill_redundant: removing " ;
Exp.d_exp e ; Exp.d_exp e ;
L.d_str " " ; L.d_str " " ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_ln () ; L.d_ln () ;
array_abstraction_performed := true ; array_abstraction_performed := true ;
modified := true ; modified := true ;
false false
in in
match (e, se) with 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) when ((not fp_part) || IntLit.iszero i)
&& (not (Ident.is_normal id)) && (not (Ident.is_normal id))
&& occurs_at_most_once id -> && occurs_at_most_once id ->
remove () (* unknown value can be removed in re-execution mode or if the index is zero *) 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 *) remove () (* index unknown can be removed *)
| _ -> | _ ->
true true
in in
let remove_redundant_se fp_part = function 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 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 ->
se se
in in
let remove_redundant_hpred fp_part = function 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 let se' = remove_redundant_se fp_part se in
Sil.Hpointsto (e, se', te) Predicates.Hpointsto (e, se', te)
| hpred -> | hpred ->
hpred hpred
in in

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

@ -11,12 +11,12 @@ open! IStd
(** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *) (** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *)
(** Check whether an atom is used to mark an attribute *) (** 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 *) (** Add an attribute associated to the argument expressions *)
let add tenv ?(footprint = false) ?(polarity = true) prop attr args = let add tenv ?(footprint = false) ?(polarity = true) prop attr args =
Prop.prop_atom_and tenv ~footprint prop 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 = 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 *) (** Replace an attribute associated to the expression *)
let add_or_replace_check_changed tenv check_attribute_change prop atom = let add_or_replace_check_changed tenv check_attribute_change prop atom =
match atom with 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 pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in
let _, nexp = List.hd_exn pairs in let _, nexp = List.hd_exn pairs in
(* len exps0 > 0 by match *) (* len exps0 > 0 by match *)
let atom_map = function 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 -> when Exp.equal nexp exp && attributes_in_same_category att att0 ->
check_attribute_change att att0 ; atom check_attribute_change att att0 ; atom
| atom' -> | atom' ->
atom' atom'
in in
let pi = prop.Prop.pi 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 if phys_equal pi pi' then Prop.prop_atom_and tenv prop atom
else Prop.normalize tenv (Prop.set prop ~pi:pi') 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 nexp = Prop.exp_normalize_prop tenv prop exp in
let atom_get_attr attributes atom = let atom_get_attr attributes atom =
match atom with 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 atom :: attributes
| _ -> | _ ->
attributes attributes
@ -77,7 +77,7 @@ let get tenv prop exp category =
let atts = get_for_exp tenv prop exp in let atts = get_for_exp tenv prop exp in
List.find List.find
~f:(function ~f:(function
| Sil.Apred (att, _) | Anpred (att, _) -> | Predicates.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category PredSymb.equal_category (PredSymb.to_category att) category
| _ -> | _ ->
false ) false )
@ -97,7 +97,7 @@ let get_wontleak tenv prop exp = get tenv prop exp ACwontleak
let has_dangling_uninit tenv prop exp = let has_dangling_uninit tenv prop exp =
let la = get_for_exp tenv prop exp in let la = get_for_exp tenv prop exp in
List.exists 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 la
@ -110,7 +110,7 @@ let filter_atoms tenv ~f prop =
let remove tenv prop atom = let remove tenv prop atom =
if is_pred atom then if is_pred atom then
let natom = Prop.atom_normalize_prop tenv prop atom in 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 filter_atoms tenv ~f prop
else prop else prop
@ -118,7 +118,7 @@ let remove tenv prop atom =
(** Remove an attribute from all the atoms in the heap *) (** Remove an attribute from all the atoms in the heap *)
let remove_for_attr tenv prop att0 = let remove_for_attr tenv prop att0 =
let f = function let f = function
| Sil.Apred (att, _) | Anpred (att, _) -> | Predicates.Apred (att, _) | Anpred (att, _) ->
not (PredSymb.equal att0 att) not (PredSymb.equal att0 att)
| _ -> | _ ->
true true
@ -128,7 +128,7 @@ let remove_for_attr tenv prop att0 =
let remove_resource tenv ra_kind ra_res = let remove_resource tenv ra_kind ra_res =
let f = function 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_res_act_kind res_action.ra_kind ra_kind <> 0
|| PredSymb.compare_resource res_action.ra_res ra_res <> 0 || PredSymb.compare_resource res_action.ra_res ra_res <> 0
| _ -> | _ ->
@ -146,15 +146,15 @@ let map_resource tenv prop f =
att att
in in
let atom_map = function let atom_map = function
| Sil.Apred (att, ([e] as es)) -> | Predicates.Apred (att, ([e] as es)) ->
Sil.Apred (attribute_map e att, es) Predicates.Apred (attribute_map e att, es)
| Sil.Anpred (att, ([e] as es)) -> | Predicates.Anpred (att, ([e] as es)) ->
Sil.Anpred (attribute_map e att, es) Predicates.Anpred (attribute_map e att, es)
| atom -> | atom ->
atom atom
in in
let pi0 = prop.Prop.pi 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) 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 _ -> | Some atom, Exp.Var _ ->
let prop = remove tenv prop atom in let prop = remove tenv prop atom in
let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop 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 add_or_replace tenv prop natom
| _ -> | _ ->
prop 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. *) of stack variables whose address was still present after deallocation. *)
let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
let filter = function let filter = function
| Sil.Hpointsto (Exp.Lvar v, _, _) -> | Predicates.Hpointsto (Exp.Lvar v, _, _) ->
List.exists ~f:(Pvar.equal v) pvars List.exists ~f:(Pvar.equal v) pvars
| _ -> | _ ->
false false
@ -294,7 +294,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
let exp_replace = let exp_replace =
List.map List.map
~f:(function ~f:(function
| Sil.Hpointsto (Exp.Lvar v, _, _) -> | Predicates.Hpointsto (Exp.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars ; fresh_address_vars := (v, freshv) :: !fresh_address_vars ;
(Exp.Lvar v, Exp.Var freshv) (Exp.Lvar v, Exp.Var freshv)
@ -302,11 +302,14 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
assert false ) assert false )
sigma_stack sigma_stack
in in
let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in let pi1 =
let pi = List.map ~f:(Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in 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' = let p' =
Prop.normalize tenv 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 in
let p'' = let p'' =
let res = ref p' in 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 *) (* the address of a de-allocated stack var in in the post *)
if Ident.Set.mem freshv p'_fav then ( if Ident.Set.mem freshv p'_fav then (
stack_vars_address_in_post := v :: !stack_vars_address_in_post ; 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 ) res := add_or_replace tenv !res pred )
in in
List.iter ~f:do_var !fresh_address_vars ; 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'' *) (* Filter out local addresses in p'' *)
let filtered_pi, changed = let filtered_pi, changed =
List.fold_right p''.pi ~init:([], false) ~f:(fun a (filtered, 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 in
(* Avoid normalization when p'' does not change *) (* Avoid normalization when p'' does not change *)
let p''' = if changed then Prop.normalize tenv (Prop.set p'' ~pi:filtered_pi) else p'' in 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 = let rec find_in_sigma e seen_hpreds =
List.fold_right List.fold_right
~f:(fun hpred res -> ~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 else
let seen_hpreds = hpred :: seen_hpreds in let seen_hpreds = hpred :: seen_hpreds in
match res with match res with
| Some _ -> | Some _ ->
res res
| None -> ( | None -> (
match hpred with match (hpred : Predicates.hpred) with
| Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _) | Hpointsto (Exp.Lvar pvar1, Eexp (exp2, Predicates.Iformal (_, _)), _)
when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) -> when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) ->
Some (Exp.Lvar pvar1) Some (Exp.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> | Hpointsto (exp1, Estruct (fields, _), _) ->
List.fold_right List.fold_right
~f:(fun (field, strexp) res -> ~f:(fun (field, strexp) res ->
match res with match res with
@ -358,7 +361,7 @@ let find_equal_formal_path tenv e prop =
res res
| None -> ( | None -> (
match strexp with 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 match find_in_sigma exp1 seen_hpreds with
| Some vfs -> | Some vfs ->
Some (Exp.Lfield (vfs, field, Typ.mk Tvoid)) 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) *) (** 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 *) (** Check whether an atom is used to mark an attribute *)
val add : val add :
@ -23,43 +23,43 @@ val add :
-> Prop.normal Prop.t -> Prop.normal Prop.t
(** Add an attribute associated to the argument expressions *) (** 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 *) (** Replace an attribute associated to the expression *)
val add_or_replace_check_changed : val add_or_replace_check_changed :
Tenv.t Tenv.t
-> (PredSymb.t -> PredSymb.t -> unit) -> (PredSymb.t -> PredSymb.t -> unit)
-> Prop.normal Prop.t -> Prop.normal Prop.t
-> Sil.atom -> Predicates.atom
-> Prop.normal Prop.t -> Prop.normal Prop.t
(** Replace an attribute associated to the expression, and call the given function with new and old (** Replace an attribute associated to the expression, and call the given function with new and old
attributes if they changed. *) 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 *) (** 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 *) (** 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 *) (** 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 *) (** 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 *) (** 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 *) (** 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 *) (** Get the wontleak attribute associated to the expression, if any *)
val has_dangling_uninit : Tenv.t -> 'a Prop.t -> Exp.t -> bool val has_dangling_uninit : Tenv.t -> 'a Prop.t -> Exp.t -> bool
(** Test for existence of an Adangling DAuninit attribute associated to the exp *) (** 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 *) (** Remove an attribute *)
val remove_for_attr : Tenv.t -> Prop.normal Prop.t -> PredSymb.t -> Prop.normal Prop.t 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 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 *) (** Return a compact representation of the spec *)
val tospec : t -> Prop.normal 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 idlist = free_vars tenv spec |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in
let count = ref 0 in let count = ref 0 in
let sub = let sub =
Sil.subst_of_list Predicates.subst_of_list
(List.map (List.map
~f:(fun id -> ~f:(fun id ->
incr count ; 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 applies it to the subparts if the result is [None]. Returns the most absract results which
pass [filter]. *) 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 *) (** apply a substitution to a jprop *)
val map : ('a Prop.t -> 'b Prop.t) -> 'a t -> 'b t 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 module NormSpec : sig
type t type t
val compact : Sil.sharing_env -> t -> t val compact : Predicates.sharing_env -> t -> t
(** Return a compact representation of the spec *) (** Return a compact representation of the spec *)
val erase_join_info_pre : Tenv.t -> t -> t 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__) 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 (* 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 it requires that the function is called with the array allocated. If not infer
return a null pointer deref *) return a null pointer deref *)
let mk_empty_array_rearranged len = 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 = 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 n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let hpred_opt = let hpred_opt =
List.find 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 prop.Prop.sigma
in in
match hpred_opt with match hpred_opt with
| Some (Sil.Hpointsto (_, Sil.Earray (len, _, _), _)) -> | Some (Predicates.Hpointsto (_, Predicates.Earray (len, _, _), _)) ->
Some (len, prop) Some (len, prop)
| Some _ -> | Some _ ->
None (* e points to something but not an array *) 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 n_len, prop = check_arith_norm_exp tenv pname len prop__ in
let hpred, sigma' = let hpred, sigma' =
List.partition_tf 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 prop.Prop.sigma
in in
match hpred with match hpred with
| [Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t)] -> | [Predicates.Hpointsto (e, Earray (_, esel, inst), t)] ->
let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in let hpred' = Predicates.Hpointsto (e, Earray (n_len, esel, inst), t) in
let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in
[(Prop.normalize tenv prop', path)] [(Prop.normalize tenv prop', path)]
| _ -> | _ ->
@ -160,7 +161,7 @@ let create_type tenv n_lexp typ prop =
let prop_type = let prop_type =
match match
List.find 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 prop.Prop.sigma
with with
| Some _ -> | Some _ ->
@ -169,7 +170,7 @@ let create_type tenv n_lexp typ prop =
let mhpred = let mhpred =
match typ.Typ.desc with match typ.Typ.desc with
| Typ.Tptr (typ', _) -> | Typ.Tptr (typ', _) ->
let sexp = Sil.Estruct ([], Sil.inst_none) in let sexp = Predicates.Estruct ([], Predicates.inst_none) in
let texp = let texp =
Exp.Sizeof {typ= typ'; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} Exp.Sizeof {typ= typ'; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
in in
@ -222,7 +223,8 @@ let execute___get_type_of {Builtin.summary; tenv; prop_; path; ret_id_typ; args}
let hpred_opt = let hpred_opt =
List.find_map List.find_map
~f:(function ~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 prop.Prop.sigma
in in
match hpred_opt with match hpred_opt with
@ -241,12 +243,12 @@ let replace_ptsto_texp tenv prop root_e texp =
let process_sigma sigma = let process_sigma sigma =
let sigma1, sigma2 = let sigma1, sigma2 =
List.partition_tf 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 sigma
in in
match sigma1 with match sigma1 with
| [Sil.Hpointsto (e, se, _)] -> | [Predicates.Hpointsto (e, se, _)] ->
Sil.Hpointsto (e, se, texp) :: sigma2 Predicates.Hpointsto (e, se, texp) :: sigma2
| _ -> | _ ->
sigma sigma
in in
@ -278,10 +280,10 @@ let execute___instanceof_cast ~instof {Builtin.summary; tenv; prop_; path; ret_i
else else
let res_opt = let res_opt =
List.find 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 prop.Prop.sigma
|> Option.map ~f:(function |> Option.map ~f:(function
| Sil.Hpointsto (_, _, texp1) -> ( | Predicates.Hpointsto (_, _, texp1) -> (
let pos_type_opt, neg_type_opt = let pos_type_opt, neg_type_opt =
Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2
in 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 = let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter =
match Prop.prop_iter_current tenv iter with 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 let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
if mark_as_freed then if mark_as_freed then
let pname = PredSymb.mem_dealloc_pname mk in 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 in
p_res :: acc p_res :: acc
else prop :: acc else prop :: acc
| Sil.Hpointsto _, _ :: _ -> | Predicates.Hpointsto _, _ :: _ ->
assert false (* alignment error *) assert false (* alignment error *)
| _ -> | _ ->
assert false assert false
@ -581,7 +583,7 @@ let execute_alloc mk can_return_null {Builtin.summary; tenv; prop_; path; ret_id
in in
let id_new = Ident.create_fresh Ident.kprimed in let id_new = Ident.create_fresh Ident.kprimed in
let exp_new = Exp.Var id_new 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_plus_ptsto =
let prop' = Prop.normalize tenv (Prop.prop_sigma_star prop [ptsto_new]) in let prop' = Prop.normalize tenv (Prop.prop_sigma_star prop [ptsto_new]) in
let ra = 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 n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let typ = let typ =
List.find 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 prop.Prop.sigma
|> Option.value_map |> Option.value_map
~f:(function Sil.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_) ~f:(function Predicates.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_)
~default:typ_ ~default:typ_
in in
let typ_string = Typ.to_string 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 in
let set_instr = let set_instr =
Sil.Store Sil.Store
{ e1= Exp.Lvar Sil.custom_error { e1= Exp.Lvar Predicates.custom_error
; root_typ= Typ.mk Tvoid ; root_typ= Typ.mk Tvoid
; typ= Typ.mk Tvoid ; typ= Typ.mk Tvoid
; e2= Exp.Const (Const.Cstr error_str) ; 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 in
let set_instr = let set_instr =
Sil.Store Sil.Store
{ e1= Exp.Lvar Sil.custom_error { e1= Exp.Lvar Predicates.custom_error
; root_typ= Typ.mk Tvoid ; root_typ= Typ.mk Tvoid
; typ= Typ.mk Tvoid ; typ= Typ.mk Tvoid
; e2= Exp.Const (Const.Cstr error_str) ; 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(coo,e,c): basic memory cell box for expression e at coordinate coo and color c *)
| Dotpointsto of coordinate * Exp.t * string | 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(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*) (* 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 *) (* 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(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*) (* 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 | 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} 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 = let rec strexp_to_string pe coo f se =
match se with match (se : Predicates.strexp) with
| Sil.Eexp (Exp.Lvar pvar, _) -> | Eexp (Exp.Lvar pvar, _) ->
(Pvar.pp pe) f 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 () 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 '_' 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 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 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 = and get_contents_sexp pe coo f se =
match se with match (se : Predicates.strexp) with
| Sil.Eexp (e', _) -> | Eexp (e', _) ->
(Exp.pp_diff pe) f e' (Exp.pp_diff pe) f e'
| Sil.Estruct (se', _) -> | Estruct (se', _) ->
F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) 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' 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 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 (strexp_to_string pe coo) a (get_contents pe coo) linner
@ -257,7 +264,7 @@ let color_to_str (c : Pp.color) =
"red" "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) = let exp_color hpred (exp : Exp.t) =
if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) 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 let n = !dotty_state_count in
incr dotty_state_count ; incr dotty_state_count ;
let coo = mk_coordinate n lambda in let coo = mk_coordinate n lambda in
match hpred with match (hpred : Predicates.hpred) with
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop -> | 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 let e_color_str = color_to_str (exp_color hpred e) in
[Dotdangling (coo, e, e_color_str)] [Dotdangling (coo, e, e_color_str)]
| Sil.Hlseg (_, _, _, 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 let e2_color_str = color_to_str (exp_color hpred e2) in
[Dotdangling (coo, e2, e2_color_str)] [Dotdangling (coo, e2, e2_color_str)]
| Sil.Hdllseg (_, _, _, e2, e3, _, _) -> | Hdllseg (_, _, _, e2, e3, _, _) ->
let e2_color_str = color_to_str (exp_color hpred e2) in let e2_color_str = color_to_str (exp_color hpred e2) in
let e3_color_str = color_to_str (exp_color hpred e3) in let e3_color_str = color_to_str (exp_color hpred e3) in
let ll = let ll =
if not (Exp.equal e2 Exp.zero) then [Dotdangling (coo, e2, e2_color_str)] else [] if not (Exp.equal e2 Exp.zero) then [Dotdangling (coo, e2, e2_color_str)] else []
in in
if not (Exp.equal e3 Exp.zero) then Dotdangling (coo, e3, e3_color_str) :: ll else ll 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*) (* arrays and struct do not give danglings*)
in 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 rec dotty_mk_node pe sigma =
let n = !dotty_state_count in let n = !dotty_state_count in
incr dotty_state_count ; incr dotty_state_count ;
let do_hpred_lambda exp_color = function let do_hpred_lambda exp_color (hpred : Predicates.hpred) lambda =
| ( Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}}) match (hpred, lambda) with
, lambda ) -> | Hpointsto (e, Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}}), lambda ->
incr dotty_state_count ; incr dotty_state_count ;
(* increment once more n+1 is the box for the array *) (* 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
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) [ Dotpointsto (mk_coordinate n lambda, e, e_color_str)
; Dotarray (mk_coordinate (n + 1) lambda, e, e', l, t, 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 ; incr dotty_state_count ;
(* increment once more n+1 is the box for the struct *) (* increment once more n+1 is the box for the struct *)
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, l, true, e_color_str)] *) (* [Dotpointsto((mk_coordinate n lambda), e, l, true, e_color_str)] *)
[ Dotpointsto (mk_coordinate n lambda, e, e_color_str) [ Dotpointsto (mk_coordinate n lambda, e, e_color_str)
; Dotstruct (mk_coordinate (n + 1) lambda, e, l, e_color_str, te) ] ; 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 let e_color_str = color_to_str (exp_color e) in
if List.mem ~equal:Exp.equal !struct_exp_nodes e then [] if List.mem ~equal:Exp.equal !struct_exp_nodes e then []
else [Dotpointsto (mk_coordinate n lambda, e, e_color_str)] 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 ; incr dotty_state_count ;
(* increment once more n+1 is the box for last element of the list *) (* 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 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)] [Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.body, eq_color_str)]
| Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda -> | Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda ->
let e1_color_str = color_to_str (exp_color e1) in let e1_color_str = color_to_str (exp_color e1) in
incr dotty_state_count ; incr dotty_state_count ;
(* increment once more n+1 is the box for e4 *) (* 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 in
match sigma with 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 if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) else pe.Pp.cmap_norm (Obj.repr exp)
in 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 set_exps_neq_zero pi =
let f = function 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 exps_neq_zero := e :: !exps_neq_zero
| _ -> | _ ->
() ()
@ -403,19 +410,19 @@ let make_nil_node lambda =
let compute_fields_struct sigma = let compute_fields_struct sigma =
fields_structs := [] ; fields_structs := [] ;
let rec do_strexp se in_struct = let rec do_strexp se in_struct =
match se with match (se : Predicates.strexp) with
| Sil.Eexp (e, _) -> | Eexp (e, _) ->
if in_struct then fields_structs := e :: !fields_structs else () 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)) 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)) List.iter ~f:(fun e -> do_strexp e false) (snd (List.unzip l))
in in
let rec fs s = let rec fs s =
match s with match s with
| [] -> | [] ->
() ()
| Sil.Hpointsto (_, se, _) :: s' -> | Predicates.Hpointsto (_, se, _) :: s' ->
do_strexp se false ; fs s' do_strexp se false ; fs s'
| _ :: s' -> | _ :: s' ->
fs s' fs s'
@ -429,7 +436,7 @@ let compute_struct_exp_nodes sigma =
match s with match s with
| [] -> | [] ->
() ()
| Sil.Hpointsto (e, Sil.Estruct _, _) :: s' -> | Predicates.Hpointsto (e, Estruct _, _) :: s' ->
struct_exp_nodes := e :: !struct_exp_nodes ; struct_exp_nodes := e :: !struct_exp_nodes ;
sen s' sen s'
| _ :: s' -> | _ :: s' ->
@ -449,7 +456,7 @@ let in_cycle cycle edge =
| Some cycle' -> | Some cycle' ->
let fn, se = edge in let fn, se = edge in
List.exists 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' cycle'
| _ -> | _ ->
false 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) *) (* 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 rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
let find_target_one_fld (fn, se) = let find_target_one_fld (fn, se) =
match se with match (se : Predicates.strexp) with
| Sil.Eexp (e, _) -> ( | Eexp (e, _) -> (
if is_nil e p then if is_nil e p then
let n' = make_nil_node lambda in let n' = make_nil_node lambda in
if !print_full_prop then [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] else [] 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*) (* by construction there must be at most 2 nodes for an expression*)
L.internal_error "@\n Too many nodes! Error! @\n@." ; L.internal_error "@\n Too many nodes! Error! @\n@." ;
assert false ) assert false )
| Sil.Estruct (_, _) -> | Estruct (_, _) ->
[] (* inner struct are printed by print_struc function *) [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ -> | Earray _ ->
[] []
(* inner arrays are printed by print_array function *) (* inner arrays are printed by print_array function *)
in 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) *) (* 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 rec compute_target_array_elements dotnodes list_elements p f lambda =
let find_target_one_element (idx, se) = let find_target_one_element (idx, se) =
match se with match (se : Predicates.strexp) with
| Sil.Eexp (e, _) -> ( | Eexp (e, _) -> (
if is_nil e p then if is_nil e p then
let n' = make_nil_node lambda in let n' = make_nil_node lambda in
[(LinkArrayToExp, Exp.to_string idx, n', "")] [(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*) (* by construction there must be at most 2 nodes for an expression*)
L.internal_error "@\nToo many nodes! Error!@\n@." ; L.internal_error "@\nToo many nodes! Error!@\n@." ;
assert false ) assert false )
| Sil.Estruct (_, _) -> | Estruct (_, _) ->
[] (* inner struct are printed by print_struc function *) [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ -> | Earray _ ->
[] []
(* inner arrays are printed by print_array function *) (* inner arrays are printed by print_array function *)
in in
@ -595,9 +602,9 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
match sigma with 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' 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 let src = look_up dotnodes e lambda in
match src with match src with
| [] -> | [] ->
@ -630,7 +637,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
in in
lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle 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 let src = look_up dotnodes e lambda in
match src with 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 let ll = List.concat_map ~f:ff nl in
ll @ dotty_mk_set_links dotnodes sigma' p f cycle ll @ dotty_mk_set_links dotnodes sigma' p f cycle
else 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 let src = look_up dotnodes e1 lambda in
match src with 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 mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab
in in
lnk :: dotty_mk_set_links dotnodes sigma' p f cycle ) 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 let src = look_up dotnodes e1 lambda in
match src with match src with
| [] -> | [] ->
@ -856,11 +863,11 @@ and print_sll f pe nesting k e1 coo =
let lambda = coo.lambda in let lambda = coo.lambda in
let n' = !dotty_state_count in let n' = !dotty_state_count in
incr dotty_state_count ; incr dotty_state_count ;
( match k with ( match (k : Predicates.lseg_kind) with
| Sil.Lseg_NE -> | Lseg_NE ->
F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";" F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";"
n' lambda "style=filled; color=lightgrey;" n' lambda "style=filled; color=lightgrey;"
| Sil.Lseg_PE -> | Lseg_PE ->
F.fprintf f F.fprintf f
"subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n' "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n'
lambda "style=filled; color=lightgrey;" ) ; 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 lambda = coo.lambda in
let n' = !dotty_state_count in let n' = !dotty_state_count in
incr dotty_state_count ; incr dotty_state_count ;
( match k with ( match (k : Predicates.lseg_kind) with
| Sil.Lseg_NE -> | Lseg_NE ->
F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' 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" 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' 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" ) ; 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 ; 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 print_struct f pe e1 te l' coo c
| Dotarray (coo, e1, e2, l, _, c) when !print_full_prop -> | Dotarray (coo, e1, e2, l, _, c) when !print_full_prop ->
print_array f pe e1 e2 l coo c print_array f pe e1 e2 l coo c
| Dotlseg (coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop -> | Dotlseg (coo, e1, _, Lseg_NE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_NE e1 coo print_sll f pe nesting Predicates.Lseg_NE e1 coo
| Dotlseg (coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop -> | Dotlseg (coo, e1, _, Lseg_PE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_PE e1 coo print_sll f pe nesting Predicates.Lseg_PE e1 coo
| Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop -> | Dotdllseg (coo, e1, _, _, e4, Lseg_NE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_NE e1 e4 coo print_dll f pe nesting Predicates.Lseg_NE e1 e4 coo
| Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop -> | Dotdllseg (coo, e1, _, _, e4, Lseg_PE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_PE e1 e4 coo 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 (** 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 *) 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 (** Checks [e1 = e2\[sub ++ sub'\]] for some [sub'] with [dom(sub') subseteq vars]. Returns
[(sub ++ sub', vars - dom(sub'))]. *) [(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 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 if Exp.equal e1 e2_inst then Some (sub, vars) else None
in in
match (e1, e2) with match (e1, e2) with
| _, Exp.Var id2 when Ident.is_primed id2 && mem_idlist id2 vars -> | _, 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 vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in
let sub_new = let sub_new =
match Sil.extend_sub sub id2 e1 with match Predicates.extend_sub sub id2 e1 with
| None -> | None ->
assert false (* happens when vars contains the same variable twice. *) assert false (* happens when vars contains the same variable twice. *)
| Some sub_new -> | 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 (** 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 [(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. *) 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 match (sexp1, sexp2) with
| Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> | Eexp (exp1, _), Eexp (exp2, _) ->
exp_match exp1 sub vars exp2 exp_match exp1 sub vars exp2
| Sil.Eexp _, _ | _, Sil.Eexp _ -> | Eexp _, _ | _, Eexp _ ->
None None
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> | Estruct (fsel1, _), Estruct (fsel2, _) ->
fsel_match fsel1 sub vars fsel2 fsel_match fsel1 sub vars fsel2
| Sil.Estruct _, _ | _, Sil.Estruct _ -> | Estruct _, _ | _, Estruct _ ->
None None
| Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> ( | Earray (len1, isel1, _), Earray (len2, isel2, _) -> (
match exp_match len1 sub vars len2 with match exp_match len1 sub vars len2 with
| Some (sub', vars') -> | Some (sub', vars') ->
isel_match isel1 sub' vars' isel2 isel_match isel1 sub' vars' isel2
@ -148,15 +149,15 @@ and isel_match isel1 sub vars isel2 =
| [], _ | _, [] -> | [], _ | _, [] ->
None None
| (idx1, se1') :: isel1', (idx2, se2') :: isel2' -> | (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 let sanity_check = not (List.exists ~f:(fun id -> Exp.ident_mem idx2 id) vars) in
if not sanity_check then ( if not sanity_check then (
let pe = Pp.text in let pe = Pp.text in
L.internal_error "@[.... Sanity Check Failure while Matching Index-Strexps ....@\n" ; 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) L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Exp.pp_diff pe) idx1
se1' ; (Predicates.pp_sexp pe) se1' ;
L.internal_error "@[<4> IDX2: %a, STREXP2: %a@\n@." (Exp.pp_diff pe) idx2 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 ) assert false )
else if Exp.equal idx1 idx2 then else if Exp.equal idx1 idx2 then
match strexp_match se1' sub vars se2' with 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 *) (* 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 f id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in
let renaming_for_vars = Sil.subst_of_list (List.map ~f vars) in let renaming_for_vars = Predicates.subst_of_list (List.map ~f vars) in
Sil.sub_join sub renaming_for_vars 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 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 ) 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 if condition p sub then Some (sub, p) else None
| hpat :: hpats -> ( | hpat :: hpats -> (
if not hpat.flag then None if not hpat.flag then None
else else
match hpat.hpred with match (hpat.hpred : Predicates.hpred) with
| Sil.Hpointsto _ | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) ->
| Sil.Hlseg (Sil.Lseg_NE, _, _, _, _)
| Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) ->
None None
| Sil.Hlseg (_, _, e1, e2, _) -> ( | Hlseg (_, _, e1, e2, _) -> (
let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem e1 id) vars) in let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem e1 id) vars) in
if not fully_instantiated then None if not fully_instantiated then None
else 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 match exp_match e1' sub vars e2 with
| None -> | None ->
None None
| Some (sub_new, vars_leftover) -> | Some (sub_new, vars_leftover) ->
instantiate_to_emp p condition sub_new vars_leftover hpats ) instantiate_to_emp p condition sub_new vars_leftover hpats )
| Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> ( | Hdllseg (_, _, iF, oB, oF, iB, _) -> (
let fully_instantiated = let fully_instantiated =
not (List.exists ~f:(fun id -> Exp.ident_mem iF id || Exp.ident_mem oB id) vars) not (List.exists ~f:(fun id -> Exp.ident_mem iF id || Exp.ident_mem oB id) vars)
in in
if not fully_instantiated then None if not fully_instantiated then None
else else
let iF' = Sil.exp_sub sub iF in let iF' = Predicates.exp_sub sub iF in
let oB' = Sil.exp_sub sub oB in let oB' = Predicates.exp_sub sub oB in
match exp_list_match [iF'; oB'] sub vars [oF; iB] with match exp_list_match [iF'; oB'] sub vars [oF; iB] with
| None -> | None ->
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 prop_match_with_impl_sub tenv p_rest condition sub_new vars_leftover hpat_next hpats_rest
in in
let gen_filter_pointsto lexp2 strexp2 te2 = function 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 match exp_match lexp1 sub vars lexp2 with
| None -> | None ->
None None
@ -277,15 +276,16 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| _ -> | _ ->
None None
in in
let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function let gen_filter_lseg (k2 : Predicates.lseg_kind) para2 e_start2 e_end2 es_shared2 hpred =
| Sil.Hpointsto _ -> match (hpred : Predicates.hpred) with
| Hpointsto _ ->
None None
| Sil.Hlseg (k1, para1, e_start1, e_end1, es_shared1) -> | Hlseg (k1, para1, e_start1, e_end1, es_shared1) ->
let do_kinds_match = let do_kinds_match =
match (k1, k2) with 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 true
| Sil.Lseg_PE, Sil.Lseg_NE -> | Lseg_PE, Lseg_NE ->
false false
in in
(* let do_paras_match = hpara_match_with_impl tenv hpat.flag para1 para2 *) (* 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 es1 = [e_start1; e_end1] @ es_shared1 in
let es2 = [e_start2; e_end2] @ es_shared2 in let es2 = [e_start2; e_end2] @ es_shared2 in
exp_list_match es1 sub vars es2 exp_list_match es1 sub vars es2
| Sil.Hdllseg _ -> | Hdllseg _ ->
None None
in in
let gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 = function let gen_filter_dllseg (k2 : Predicates.lseg_kind) para2 iF2 oB2 oF2 iB2 es_shared2 hpred =
| Sil.Hpointsto _ | Sil.Hlseg _ -> match (hpred : Predicates.hpred) with
| Hpointsto _ | Hlseg _ ->
None None
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) -> | Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) ->
let do_kinds_match = let do_kinds_match =
match (k1, k2) with 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 true
| Sil.Lseg_PE, Sil.Lseg_NE -> | Lseg_PE, Lseg_NE ->
false false
in in
(* let do_paras_match = hpara_dll_match_with_impl tenv hpat.flag para1 para2 *) (* 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 exp_list_match es1 sub vars es2
in in
match hpat.hpred with match hpat.hpred with
| Sil.Hpointsto (lexp2, strexp2, te2) -> ( | Hpointsto (lexp2, strexp2, te2) -> (
let filter = gen_filter_pointsto lexp2 strexp2 te2 in let filter = gen_filter_pointsto lexp2 strexp2 te2 in
match (Prop.prop_iter_find iter filter, hpats) with match (Prop.prop_iter_find iter filter, hpats) with
| None, _ -> | None, _ ->
@ -327,7 +328,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
do_empty_hpats iter_cur () do_empty_hpats iter_cur ()
| Some iter_cur, _ -> | Some iter_cur, _ ->
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next 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 filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in
let do_emp_lseg _ = let do_emp_lseg _ =
let fully_instantiated_start2 = let fully_instantiated_start2 =
@ -335,7 +336,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in in
if not fully_instantiated_start2 then None if not fully_instantiated_start2 then None
else 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 match (exp_match e_start2' sub vars e_end2, hpats) with
| None, _ -> | 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 prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest
in in
let do_para_lseg _ = 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=hpred; flag=hpat.flag} in *)
let allow_impl hpred = {hpred; flag= true} in let allow_impl hpred = {hpred; flag= true} in
let para2_hpat, para2_hpats = 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 = let not_in_para2_exist_vars id =
not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars)
in 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 (sub_res', p_leftover)
| Some _ -> | Some _ ->
None None
@ -382,7 +385,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| None, _ when not hpat.flag -> | None, _ when not hpat.flag ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
None None
| None, _ when Sil.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@."; *) (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
do_para_lseg () do_para_lseg ()
| None, _ -> | None, _ ->
@ -394,7 +397,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
| Some iter_cur, _ -> | Some iter_cur, _ ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] )
| 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 filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in
let do_emp_dllseg _ = let do_emp_dllseg _ =
let fully_instantiated_iFoB2 = let fully_instantiated_iFoB2 =
@ -402,8 +405,8 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in in
if not fully_instantiated_iFoB2 then None if not fully_instantiated_iFoB2 then None
else else
let iF2' = Sil.exp_sub sub iF2 in let iF2' = Predicates.exp_sub sub iF2 in
let oB2' = Sil.exp_sub sub oB2 in let oB2' = Predicates.exp_sub sub oB2 in
match (exp_list_match [iF2'; oB2'] sub vars [oF2; iB2], hpats) with match (exp_list_match [iF2'; oB2'] sub vars [oF2; iB2], hpats) with
| None, _ -> | None, _ ->
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 let fully_instantiated_iF2 = not (List.exists ~f:(fun id -> Exp.ident_mem iF2 id) vars) in
if not fully_instantiated_iF2 then None if not fully_instantiated_iF2 then None
else 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 match exp_match iF2' sub vars iB2 with
| None -> | None ->
None None
| Some (sub_new, vars_leftover) -> ( | Some (sub_new, vars_leftover) -> (
let para2_exist_vars, para2_inst = 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 in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *) (* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
let allow_impl hpred = {hpred; flag= true} 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 = let not_in_para2_exist_vars id =
not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars)
in 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 (sub_res', p_leftover)
| Some _ -> | Some _ ->
None ) 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 match (Prop.prop_iter_find iter filter, hpats) with
| None, _ when not hpat.flag -> | None, _ when not hpat.flag ->
None None
| None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE -> | None, _ when Predicates.equal_lseg_kind k2 Lseg_NE ->
do_para_dllseg () do_para_dllseg ()
| None, _ -> | None, _ ->
execute_with_backtracking [do_emp_dllseg; do_para_dllseg] 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 let sub_eids = List.map ~f:(fun (id2, id1) -> (id2, Exp.Var id1)) ren_eids in
(sub_eids, eids_fresh) (sub_eids, eids_fresh)
in 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 match sigma2 with
| [] -> | [] ->
if List.is_empty sigma1 then true else false if List.is_empty sigma1 then true else false
| hpred2 :: sigma2 -> ( | hpred2 :: sigma2 -> (
let hpat2, hpats2 = 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 let allow_impl hpred = {hpred; flag= impl_ok} in
(allow_impl hpred2_ren, List.map ~f:allow_impl sigma2_ren) (allow_impl hpred2_ren, List.map ~f:allow_impl sigma2_ren)
in in
let condition _ _ = true in let condition _ _ = true in
let p1 = Prop.normalize tenv (Prop.from_sigma sigma1) 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 -> | None ->
false false
| Some (_, p1') when Prop.prop_is_emp p1' -> | 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 with Invalid_argument _ -> false
and hpara_match_with_impl tenv impl_ok para1 para2 : bool = and hpara_match_with_impl tenv impl_ok (para1 : Predicates.hpara) (para2 : Predicates.hpara) =
(* let ids1 = para1.root :: para1.next :: para1.svars in
L.out "@[.... hpara_match_with_impl_sub ....@."; let ids2 = para2.root :: para2.next :: para2.svars in
L.out "@[<4> HPARA1: %a@\n@." pp_hpara para1; let eids2 = para2.evars in
L.out "@[<4> HPARA2: %a@\n@." pp_hpara para2; hpara_common_match_with_impl tenv impl_ok ids1 para1.body eids2 ids2 para2.body
*)
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_dll_match_with_impl tenv impl_ok para1 para2 : bool = and hpara_dll_match_with_impl tenv impl_ok (para1 : Predicates.hpara_dll)
(* (para2 : Predicates.hpara_dll) =
L.out "@[.... hpara_dll_match_with_impl_sub ....@."; let ids1 = para1.cell :: para1.blink :: para1.flink :: para1.svars_dll in
L.out "@[<4> HPARA1: %a@\n@." pp_hpara_dll para1; let ids2 = para2.cell :: para2.blink :: para2.flink :: para2.svars_dll in
L.out "@[<4> HPARA2: %a@\n@." pp_hpara_dll para2; let eids2 = para2.evars_dll in
*) hpara_common_match_with_impl tenv impl_ok ids1 para1.body_dll eids2 ids2 para2.body_dll
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
(** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that (** [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 + [p |- (hpat.hpred * hpats.hpred)\[subst\] * p_leftover]. Using the flag [field], we can
control the strength of |-. *) control the strength of |-. *)
let prop_match_with_impl tenv p condition vars hpat hpats = 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 sigma_remove_hpred eq sigma e =
let filter = function let filter hpred =
| Sil.Hpointsto (root, _, _) match (hpred : Predicates.hpred) with
| Sil.Hlseg (_, _, root, _, _) | Hpointsto (root, _, _) | Hlseg (_, _, root, _, _) | Hdllseg (_, _, root, _, _, _, _) ->
| Sil.Hdllseg (_, _, root, _, _, _, _) ->
eq root e eq root e
in in
let sigma_e, sigma_no_e = List.partition_tf ~f:filter sigma 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 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 match (sexp1, sexp2) with
| Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> | Eexp (exp1, _), Eexp (exp2, _) ->
let new_todos = (exp1, exp2) :: todos in let new_todos = (exp1, exp2) :: todos in
Some new_todos Some new_todos
| Sil.Eexp _, _ -> | Eexp _, _ ->
None None
| Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> | Estruct (fel1, _), Estruct (fel2, _) ->
(* assume sorted w.r.t. fields *) (* assume sorted w.r.t. fields *)
if List.length fel1 <> List.length fel2 && equal_iso_mode mode Exact then None if List.length fel1 <> List.length fel2 && equal_iso_mode mode Exact then None
else generate_todos_from_fel mode todos fel1 fel2 else generate_todos_from_fel mode todos fel1 fel2
| Sil.Estruct _, _ -> | Estruct _, _ ->
None 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 if (not (Exp.equal len1 len2)) || List.length iel1 <> List.length iel2 then None
else generate_todos_from_iel mode todos iel1 iel2 else generate_todos_from_iel mode todos iel1 iel2
| Sil.Earray _, _ -> | Earray _, _ ->
None 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 ) generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo )
| None, _ | _, None -> | None, _ | _, 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) -> when not (Exp.equal te1 te2) ->
None 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 match generate_todos_from_strexp mode [] se1 se2 with
| None -> | None ->
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 let new_todos = todos'' @ todos' in
generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos
new_sigma_todo ) new_sigma_todo )
| ( Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1) | ( Some (Predicates.Hlseg (k1, para1, root1, next1, shared1) as hpred1)
, Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> ( , Some (Predicates.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> (
if k1 <> k2 || not (hpara_iso tenv para1 para2) then None if k1 <> k2 || not (hpara_iso tenv para1 para2) then None
else else
try 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 generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos
new_sigma_todo new_sigma_todo
with Invalid_argument _ -> None ) with Invalid_argument _ -> None )
| ( Some (Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1) | ( Some (Predicates.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 (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) -> (
if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None
else else
try try
@ -794,14 +793,14 @@ let find_partial_iso tenv eq corres todos sigma =
(** Lift the kind of list segment predicates to PE *) (** 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 match hpred with
| Sil.Hpointsto _ -> | Hpointsto _ ->
hpred hpred
| Sil.Hlseg (_, para, root, next, shared) -> | Hlseg (_, para, root, next, shared) ->
Sil.Hlseg (Sil.Lseg_PE, para, root, next, shared) Hlseg (Lseg_PE, para, root, next, shared)
| Sil.Hdllseg (_, para, iF, oB, oF, iB, shared) -> | Hdllseg (_, para, iF, oB, oF, iB, shared) ->
Sil.Hdllseg (Sil.Lseg_PE, 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 *) (** 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_root = get_id1 root1 in
let id_next = get_id1 next1 in let id_next = get_id1 next1 in
let hpara = 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 in
(hpara, es_shared) (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_blink = get_id1 blink1 in
let id_flink = get_id1 flink1 in let id_flink = get_id1 flink1 in
let hpara_dll = let hpara_dll =
{ Sil.cell= id_root { Predicates.cell= id_root
; Sil.blink= id_blink ; blink= id_blink
; Sil.flink= id_flink ; flink= id_flink
; Sil.svars_dll= ids_shared ; svars_dll= ids_shared
; Sil.evars_dll= ids_exists ; evars_dll= ids_exists
; Sil.body_dll= body } ; body_dll= body }
in in
(hpara_dll, es_shared) (hpara_dll, es_shared)

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

@ -17,15 +17,16 @@ open! IStd
(* TODO: missing documentation *) (* 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 (** 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. *) 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 : val prop_match_with_impl :
Tenv.t Tenv.t
@ -34,7 +35,7 @@ val prop_match_with_impl :
-> Ident.t list -> Ident.t list
-> hpred_pat -> hpred_pat
-> hpred_pat list -> 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 (** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that
+ [dom(subst) = vars] + [dom(subst) = vars]
@ -47,22 +48,28 @@ val find_partial_iso :
-> (Exp.t -> Exp.t -> bool) -> (Exp.t -> Exp.t -> bool)
-> (Exp.t * Exp.t) list -> (Exp.t * Exp.t) list
-> (Exp.t * Exp.t) list -> (Exp.t * Exp.t) list
-> Sil.hpred list -> Predicates.hpred list
-> ((Exp.t * Exp.t) list * Sil.hpred list * Sil.hpred list * Sil.hpred list) option -> ((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 (** [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 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 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 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. *) 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. *) (** [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. *) (** [hpara_dll_iso] soundly checks whether two hpara_dlls are isomorphic. *)
val hpara_create : 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 (** [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 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. *) passed as arguments to hpara. Both of them are returned as a result. *)
@ -70,11 +77,11 @@ val hpara_create :
val hpara_dll_create : val hpara_dll_create :
Tenv.t Tenv.t
-> (Exp.t * Exp.t) list -> (Exp.t * Exp.t) list
-> Sil.hpred list -> Predicates.hpred list
-> Exp.t -> Exp.t
-> Exp.t -> 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 (** [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 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. *) 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! IStd
open Predicates
(** Functions for Propositions (i.e., Symbolic Heaps) *) (** Functions for Propositions (i.e., Symbolic Heaps) *)
open Sil
(** kind for normal props, i.e. normalized *) (** kind for normal props, i.e. normalized *)
type normal type normal
@ -23,14 +22,14 @@ type sorted
(** Proposition. *) (** 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] *) (** the kind 'a should range over [normal] and [exposed] *)
type 'a t = private type 'a t = private
{ sigma: sigma (** spatial part *) { sigma: sigma (** spatial part *)
; sub: Sil.subst (** substitution *) ; sub: subst (** substitution *)
; pi: pi (** pure part *) ; pi: pi (** pure part *)
; sigma_fp: sigma (** abduced spatial part *) ; sigma_fp: sigma (** abduced spatial part *)
; pi_fp: pi (** abduced pure 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 val pp_prop : Pp.env -> Format.formatter -> 'a t -> unit
(** Pretty print a proposition. *) (** 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 *) (** Create a predicate environment for a prop *)
val d_prop : 'a t -> unit 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} *) (** {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 *) (** 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 *) (** 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] *) (** 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] *) (** If the atom is [n<e] return [n,e] *)
val exp_normalize_prop : ?destructive:bool -> Tenv.t -> 'a t -> Exp.t -> Exp.t 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 If [destructive] is true then normalize more aggressively, which may lose some useful structure
or types. *) 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 *) (** Normalize the expression without abstracting complex subexpressions *)
val exp_collapse_consecutive_indices_prop : Typ.t -> Exp.t -> Exp.t 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 val mk_npred : Tenv.t -> PredSymb.t -> Exp.t list -> atom
(** Construct a negative pred. *) (** Construct a negative pred. *)
val create_strexp_of_type : val create_strexp_of_type : Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> inst -> strexp
Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> Sil.inst -> Sil.strexp
(** create a strexp of the given type, populating the structures if [expand_structs] is true *) (** 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 val mk_ptsto : Tenv.t -> Exp.t -> strexp -> Exp.t -> hpred
(** Construct a pointsto. *) (** 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 (** Construct a points-to predicate for an expression using either the provided expression [name] as
base for fresh identifiers. *) 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, (** Construct a points-to predicate for a single program variable. If [expand_structs] is true,
initialize the fields of structs with fresh variables. *) initialize the fields of structs with fresh variables. *)
@ -209,7 +207,7 @@ val mk_dllseg :
val prop_emp : normal t val prop_emp : normal t
(** Proposition [true /\ emp]. *) (** 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 *) (** Reset every inst in the prop using the given map *)
val prop_hpred_star : 'a t -> hpred -> exposed t 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 val from_sigma : sigma -> exposed t
(** Build an exposed prop from sigma *) (** Build an exposed prop from sigma *)
val set : val set : ?sub:subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t
?sub:Sil.subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t
(** Set individual fields of the prop. *) (** Set individual fields of the prop. *)
(** {2 Prop iterators} *) (** {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 in
let hpred_local_static hpred = let hpred_local_static hpred =
match hpred with Sil.Hpointsto (e, _, _) -> [local_static e] | _ -> [] match hpred with Predicates.Hpointsto (e, _, _) -> [local_static e] | _ -> []
in in
let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in
List.concat (List.concat vars_sigma) 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] | _ -> [] match e with Exp.Lvar pvar when Pvar.is_block_pvar pvar -> [pvar] | _ -> []
in in
let hpred_local_blocks hpred = let hpred_local_blocks hpred =
match hpred with Sil.Hpointsto (e, _, _) -> [local_blocks e] | _ -> [] match hpred with Predicates.Hpointsto (e, _, _) -> [local_blocks e] | _ -> []
in in
let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in
List.concat (List.concat vars_sigma) 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] *) (* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *)
let compute_reachable p seed_exps = let compute_reachable p seed_exps =
let sigma, pi = (p.Prop.sigma, p.Prop.pi) in let sigma, pi = (p.Prop.sigma, p.Prop.pi) in
let rec collect_exps exps = function let rec collect_exps exps (sexp : Predicates.strexp) =
| Sil.Eexp (Exp.Exn e, _) -> match sexp with
| Eexp (Exp.Exn e, _) ->
Exp.Set.add e exps Exp.Set.add e exps
| Sil.Eexp (e, _) -> | Eexp (e, _) ->
Exp.Set.add e exps Exp.Set.add e exps
| Sil.Estruct (flds, _) -> | Estruct (flds, _) ->
List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps 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 List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems
in in
let rec compute_reachable_hpreds_rec sigma (reach, exps) = let rec compute_reachable_hpreds_rec sigma (reach, exps) =
let add_hpred_if_reachable (reach, exps) = function let add_hpred_if_reachable (reach, exps) (hpred : Predicates.hpred) =
| Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps -> match hpred with
let reach' = Sil.HpredSet.add hpred reach in | 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 let exps' = collect_exps exps rhs in
(reach', exps') (reach', exps')
| Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred -> | Hlseg (_, _, exp1, exp2, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in let reach' = Predicates.HpredSet.add hpred reach in
let exps' = let exps' =
List.fold List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
~init:exps (exp1 :: exp2 :: exp_l) ~init:exps (exp1 :: exp2 :: exp_l)
in in
(reach', exps') (reach', exps')
| Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred -> | Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred ->
let reach' = Sil.HpredSet.add hpred reach in let reach' = Predicates.HpredSet.add hpred reach in
let exps' = let exps' =
List.fold List.fold
~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc)
@ -82,11 +84,12 @@ let remove_abduced_retvars tenv p =
(reach, exps) (reach, exps)
in in
let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma 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') else compute_reachable_hpreds_rec sigma (reach', exps')
in in
let reach_hpreds, reach_exps = 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 in
(* filter away the pure atoms without reachable exps *) (* filter away the pure atoms without reachable exps *)
let reach_pi = let reach_pi =
@ -102,20 +105,20 @@ let remove_abduced_retvars tenv p =
in in
List.filter List.filter
~f:(function ~f:(function
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> | Predicates.Aeq (lhs, rhs) | Predicates.Aneq (lhs, rhs) ->
exp_contains lhs || exp_contains 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 ) List.exists ~f:exp_contains es )
pi pi
in in
(Sil.HpredSet.elements reach_hpreds, reach_pi) (Predicates.HpredSet.elements reach_hpreds, reach_pi)
in in
(* separate the abduced pvars from the normal ones, deallocate the abduced ones*) (* separate the abduced pvars from the normal ones, deallocate the abduced ones*)
let abduceds, normal_pvars = let abduceds, normal_pvars =
List.fold List.fold
~f:(fun pvars hpred -> ~f:(fun pvars hpred ->
match hpred with match hpred with
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> | Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
let abduceds, normal_pvars = pvars in let abduceds, normal_pvars = pvars in
if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars) if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars)
else (abduceds, pvar :: 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 *) (** remove seed vars from a prop *)
let remove_seed_vars tenv (prop : 'a Prop.t) : Prop.normal Prop.t = let remove_seed_vars tenv (prop : 'a Prop.t) : Prop.normal Prop.t =
let hpred_not_seed = function let hpred_not_seed = function
| Sil.Hpointsto (Exp.Lvar pv, _, _) -> | Predicates.Hpointsto (Exp.Lvar pv, _, _) ->
not (Pvar.is_seed pv) not (Pvar.is_seed pv)
| _ -> | _ ->
true 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 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 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 *) (** Return the source of the edge *)
let edge_get_source = function let edge_get_source = function
| Ehpred (Sil.Hpointsto (e, _, _)) -> | Ehpred (Hpointsto (e, _, _)) ->
Some e Some e
| Ehpred (Sil.Hlseg (_, _, e, _, _)) -> | Ehpred (Hlseg (_, _, e, _, _)) ->
Some e Some e
| Ehpred (Sil.Hdllseg (_, _, e1, _, _, _, _)) -> | Ehpred (Hdllseg (_, _, e1, _, _, _, _)) ->
Some e1 (* only one direction supported for now *) Some e1 (* only one direction supported for now *)
| Eatom (Sil.Aeq (e1, _)) -> | Eatom (Aeq (e1, _)) ->
Some e1 Some e1
| Eatom (Sil.Aneq (e1, _)) -> | Eatom (Aneq (e1, _)) ->
Some e1 Some e1
| Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) -> | Eatom (Apred (_, e :: _) | Anpred (_, e :: _)) ->
Some e Some e
| Eatom (Sil.Apred (_, []) | Anpred (_, [])) -> | Eatom (Apred (_, []) | Anpred (_, [])) ->
None None
| Esub_entry (x, _) -> | Esub_entry (x, _) ->
Some (Exp.Var 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_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 (** [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] [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 = let edge_equal e1 e2 =
match (e1, e2) with match (e1, e2) with
| Ehpred hp1, Ehpred hp2 -> | Ehpred hp1, Ehpred hp2 ->
Sil.equal_hpred hp1 hp2 Predicates.equal_hpred hp1 hp2
| Eatom a1, Eatom a2 -> | Eatom a1, Eatom a2 ->
Sil.equal_atom a1 a2 Predicates.equal_atom a1 a2
| Esub_entry (x1, e1), Esub_entry (x2, e2) -> | Esub_entry (x1, e1), Esub_entry (x2, e2) ->
Ident.equal x1 x2 && Exp.equal e1 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] *) (** 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 match (se1, se2) with
| Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> | Eexp (e1, _), Eexp (e2, _) ->
if Exp.equal e1 e2 then [] else [Obj.repr se2] 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 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 compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2
| _ -> | _ ->
[Obj.repr se2] [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] *) (** Compute the subobjects in [newedge] which are different from those in [oldedge] *)
let compute_edge_diff (oldedge : edge) (newedge : edge) : Obj.t list = let compute_edge_diff (oldedge : edge) (newedge : edge) : Obj.t list =
match (oldedge, newedge) with 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 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 compute_exp_diff e1 e2
| Eatom (Sil.Aneq (_, e1)), Eatom (Sil.Aneq (_, e2)) -> | Eatom (Aneq (_, e1)), Eatom (Aneq (_, e2)) ->
compute_exp_diff e1 e2 compute_exp_diff e1 e2
| Eatom (Sil.Apred (_, es1)), Eatom (Sil.Apred (_, es2)) | Eatom (Apred (_, es1)), Eatom (Apred (_, es2))
| Eatom (Sil.Anpred (_, es1)), Eatom (Sil.Anpred (_, es2)) -> | Eatom (Anpred (_, es1)), Eatom (Anpred (_, es2)) ->
List.concat (try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> []) List.concat (try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> [])
| Esub_entry (_, e1), Esub_entry (_, e2) -> | Esub_entry (_, e1), Esub_entry (_, e2) ->
compute_exp_diff e1 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 *) (** 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 *) (** Negate an atom *)
(** {2 Ordinary Theorem Proving} *) (** {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 [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. *) [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 (** [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] Lfield or Lindex or ptr+off. Return [(changed, calc_index_frame', hpred')] where [changed]
indicates whether the predicate has changed. *) indicates whether the predicate has changed. *)
@ -70,13 +70,13 @@ val d_typings : (Exp.t * Exp.t) list -> unit
type implication_result = type implication_result =
| ImplOK of | ImplOK of
( check list ( check list
* Sil.subst * subst
* Sil.subst * subst
* Sil.hpred list * hpred list
* Sil.atom list * atom list
* Sil.hpred list * hpred list
* Sil.hpred list * hpred list
* Sil.hpred list * hpred list
* (Exp.t * Exp.t) list * (Exp.t * Exp.t) list
* (Exp.t * Exp.t) list ) * (Exp.t * Exp.t) list )
| ImplFail of check 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} *) (** {2 Cover: minimum set of pi's whose disjunction is equivalent to true} *)
val find_minimum_pure_cover : val find_minimum_pure_cover : Tenv.t -> (atom list * 'a) list -> (atom list * 'a) list option
Tenv.t -> (Sil.atom list * 'a) list -> (Sil.atom list * 'a) list option
(** Find minimum set of pi's in [cases] whose disjunction covers true *) (** Find minimum set of pi's in [cases] whose disjunction covers true *)
(** {2 Subtype checking} *) (** {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) 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 ( if Config.trace_rearrange then (
L.d_increase_indent () ; L.d_increase_indent () ;
L.d_strln "entering create_struct_values" ; 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 ; Typ.d_full t ;
L.d_ln () ; L.d_ln () ;
L.d_str "off: " ; L.d_str "off: " ;
Sil.d_offset_list off ; Predicates.d_offset_list off ;
L.d_ln () ; L.d_ln () ;
L.d_ln () ) ; L.d_ln () ) ;
let new_id () = incr max_stamp ; Ident.create kind !max_stamp in 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:" ; L.d_str "create_struct_values type:" ;
Typ.d_full t ; Typ.d_full t ;
L.d_str " off: " ; L.d_str " off: " ;
Sil.d_offset_list off ; Predicates.d_offset_list off ;
L.d_ln () ; L.d_ln () ;
raise (Exceptions.Bad_footprint pos) raise (Exceptions.Bad_footprint pos)
in in
match (t.desc, off) with match (t.desc, off) with
| Tstruct _, [] -> | Tstruct _, [] ->
([], Sil.Estruct ([], inst), t) ([], Predicates.Estruct ([], inst), t)
| Tstruct name, Off_fld (f, _) :: off' -> ( | Tstruct name, Off_fld (f, _) :: off' -> (
match Tenv.lookup tenv name with match Tenv.lookup tenv name with
| Some ({fields; statics} as struct_typ) -> ( | 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' = let atoms', se', res_t' =
create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in 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') = let replace_typ_of_f (f', t', a') =
if Typ.Fieldname.equal f f' then (f, res_t', a') else (f', t', a') if Typ.Fieldname.equal f f' then (f, res_t', a') else (f', t', a')
in in
@ -129,30 +129,30 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
in in
let e' = Absarray.array_clean_new_index footprint_part e in let e' = Absarray.array_clean_new_index footprint_part e in
let len = Exp.Var (new_id ()) 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 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 -> ( | Tarray {elt= t'; length; stride}, off -> (
let len = let len =
match length with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len) match length with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len)
in in
match off with match off with
| [] -> | [] ->
([], Sil.Earray (len, [], inst), t) ([], Predicates.Earray (len, [], inst), t)
| Sil.Off_index e :: off' -> | Predicates.Off_index e :: off' ->
bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ; bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ;
let atoms', se', res_t' = let atoms', se', res_t' =
create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in in
let e' = Absarray.array_clean_new_index footprint_part e 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 let res_t = Typ.mk_array ~default:t res_t' ?length ?stride in
(Sil.Aeq (e, e') :: atoms', se, res_t) (Predicates.Aeq (e, e') :: atoms', se, res_t)
| Sil.Off_fld _ :: _ -> | Predicates.Off_fld _ :: _ ->
assert false ) assert false )
| Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun, [] | Tptr _, [] | TVar _, [] -> | Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun, [] | Tptr _, [] | TVar _, [] ->
let id = new_id () in 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' -> | (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _ | TVar _), Off_index e :: off' ->
(* In this case, we lift t to the t array. *) (* In this case, we lift t to the t array. *)
let t', mk_typ_f = 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 create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst
in in
let e' = Absarray.array_clean_new_index footprint_part e 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 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 _, _ -> | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun, _ | Tptr _, _ | TVar _, _ ->
fail t off __POS__ fail t off __POS__
in in
if Config.trace_rearrange then ( if Config.trace_rearrange then (
let _, se, _ = res in let _, se, _ = res in
L.d_strln "exiting create_struct_values, returning" ; L.d_strln "exiting create_struct_values, returning" ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_decrease_indent () ; L.d_decrease_indent () ;
L.d_ln () ; L.d_ln () ;
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, If we want to implement the checks for array bounds errors,
we need to change this function. *) we need to change this function. *)
let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se (typ : Typ.t) 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 let new_id () = incr max_stamp ; Ident.create kind !max_stamp in
match (off, se, typ.desc) with match (off, se, typ.desc) with
| [], Sil.Eexp _, _ | [], Sil.Estruct _, _ -> | [], Predicates.Eexp _, _ | [], Predicates.Estruct _, _ ->
[([], se, typ)] [([], se, typ)]
| [], Sil.Earray _, _ -> | [], Predicates.Earray _, _ ->
let off_new = Sil.Off_index Exp.zero :: off in 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 strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
| Off_fld _ :: _, Sil.Earray _, Tarray _ -> | Off_fld _ :: _, Predicates.Earray _, Tarray _ ->
let off_new = Sil.Off_index Exp.zero :: off in 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 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 match Tenv.lookup tenv name with
| Some ({fields; statics} as struct_typ) -> ( | Some ({fields; statics} as struct_typ) -> (
match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with 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 if Typ.Fieldname.equal f1 f then (f1, res_se') else ft1
in in
let res_fsel' = 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) (List.map ~f:replace_fse fsel)
in in
let replace_fta ((f1, _, a1) as fta1) = 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) List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields)
in in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; 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 in
List.fold ~f:replace ~init:[] atoms_se_typ_list' List.fold ~f:replace ~init:[] atoms_se_typ_list'
| None -> | 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 create_struct_values pname tenv orig_prop footprint_part kind max_stamp typ' off' inst
in in
let res_fsel' = 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 in
let replace_fta (f', t', a') = let replace_fta (f', t', a') =
if Typ.Fieldname.equal f' f then (f, res_typ', a') else (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) List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields)
in in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; 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 -> | None ->
raise (Exceptions.Missing_fld (f, __POS__)) ) raise (Exceptions.Missing_fld (f, __POS__)) )
| None -> | None ->
raise (Exceptions.Missing_fld (f, __POS__)) ) raise (Exceptions.Missing_fld (f, __POS__)) )
| Off_fld _ :: _, _, _ -> | Off_fld _ :: _, _, _ ->
raise (Exceptions.Bad_footprint __POS__) raise (Exceptions.Bad_footprint __POS__)
| Off_index _ :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _) | Off_index _ :: _, Predicates.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _)
| Off_index _ :: _, Sil.Estruct _, Tstruct _ -> | Off_index _ :: _, Predicates.Estruct _, Tstruct _ ->
(* L.d_strln ~color:Orange "turn into an array"; *) (* L.d_strln ~color:Orange "turn into an array"; *)
let len = let len =
match se with match se with
| Sil.Eexp (_, Sil.Ialloc) -> | Predicates.Eexp (_, Predicates.Ialloc) ->
Exp.one (* if allocated explicitly, we know len is 1 *) Exp.one (* if allocated explicitly, we know len is 1 *)
| _ -> | _ ->
if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *) if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *)
else Exp.Var (new_id ()) else Exp.Var (new_id ())
in 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 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 strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off
inst inst
| ( Off_index e :: off' | ( Off_index e :: off'
, Sil.Earray (len, esel, inst_arr) , Predicates.Earray (len, esel, inst_arr)
, Tarray {elt= typ'; length= len_for_typ'; stride} ) -> ( , Tarray {elt= typ'; length= len_for_typ'; stride} ) -> (
bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ; bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ;
match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with 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 let res_esel' = List.map ~f:replace_ise esel in
if Typ.equal res_typ' typ' || Int.equal (List.length res_esel') 1 then if Typ.equal res_typ' typ' || Int.equal (List.length res_esel') 1 then
( res_atoms' ( 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 ) , Typ.mk_array ~default:typ res_typ' ?length:len_for_typ' ?stride )
:: acc :: acc
else raise (Exceptions.Bad_footprint __POS__) 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 false
in in
if index_in_array then 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 let typ_default = Typ.mk_array ~default:typ_array typ_cont ?length:typ_array_len in
[([], array_default, typ_default)] [([], array_default, typ_default)]
else if !BiabductionConfig.footprint then ( else if !BiabductionConfig.footprint then (
@ -319,9 +319,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
in in
check_sound elem_typ ; check_sound elem_typ ;
let cont_new = 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 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 let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in
[(atoms, array_new, typ_new)] ) [(atoms, array_new, typ_new)] )
else else
@ -333,9 +333,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
in in
check_sound elem_typ ; check_sound elem_typ ;
let cont_new = 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 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 let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in
[(atoms, array_new, typ_new)] [(atoms, array_new, typ_new)]
in in
@ -351,9 +351,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp
List.fold List.fold
~f:(fun acc' (atoms', se', typ') -> ~f:(fun acc' (atoms', se', typ') ->
check_sound 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 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 let typ_new = Typ.mk_array ~default:typ_array typ' ?length:typ_array_len in
(atoms_new, array_new, typ_new) :: acc' ) (atoms_new, array_new, typ_new) :: acc' )
~init:[] atoms_se_typ_list ~init:[] atoms_se_typ_list
@ -372,10 +372,10 @@ let laundry_offset_for_footprint max_stamp offs_in =
match offs with match offs with
| [] -> | [] ->
(List.rev offs_seen, List.rev eqs) (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 let offs_seen' = off :: offs_seen in
laundry offs_seen' eqs offs' 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 if exp_has_only_footprint_ids idx then
let offs_seen' = off :: offs_seen in let offs_seen' = off :: offs_seen in
laundry offs_seen' eqs offs' laundry offs_seen' eqs offs'
@ -383,7 +383,7 @@ let laundry_offset_for_footprint max_stamp offs_in =
let () = incr max_stamp in let () = incr max_stamp in
let fid_new = Ident.create Ident.kfootprint !max_stamp in let fid_new = Ident.create Ident.kfootprint !max_stamp in
let exp_new = Exp.Var fid_new 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 offs_seen' = off_new :: offs_seen in
let eqs' = (fid_new, idx) :: eqs in let eqs' = (fid_new, idx) :: eqs in
laundry offs_seen' eqs' offs' 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 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 typ = Exp.texp_to_typ None te in
let off', laundry_atoms = let off', laundry_atoms =
let off', eqs = laundry_offset_for_footprint max_stamp off in 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 in
if Config.trace_rearrange then ( if Config.trace_rearrange then (
L.d_str "entering strexp_extend_values se: " ; L.d_str "entering strexp_extend_values se: " ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_str " typ: " ; L.d_str " typ: " ;
Typ.d_full typ ; Typ.d_full typ ;
L.d_str " off': " ; L.d_str " off': " ;
Sil.d_offset_list off' ; Predicates.d_offset_list off' ;
L.d_strln (if footprint_part then " FP" else " RE") ) ; L.d_strln (if footprint_part then " FP" else " RE") ) ;
let atoms_se_typ_list = let atoms_se_typ_list =
strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off' inst 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 collect_root_offset exp =
let root = Exp.root_of_lexp exp in 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) (root, offsets)
(** Exp.Construct a points-to predicate for an expression, to add to a footprint. *) (** 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 : 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 let root, off = collect_root_offset lexp in
if not (exp_has_only_footprint_ids root) then if not (exp_has_only_footprint_ids root) then
if 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 let fun_exp = Exp.Const (Const.Cfun fun_name) in
( [] ( []
, Prop.mk_ptsto tenv root , Prop.mk_ptsto tenv root
(Sil.Eexp (fun_exp, inst)) (Predicates.Eexp (fun_exp, inst))
(Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) ) (Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) )
| _, [], Typ.Tfun -> | _, [], Typ.Tfun ->
let atoms, se, typ = let atoms, se, typ =
@ -483,8 +483,8 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst :
) )
in in
let atoms, ptsto_foot = create_ptsto true off_foot in let atoms, ptsto_foot = create_ptsto true off_foot in
let sub = Sil.subst_of_list eqs in let sub = Predicates.subst_of_list eqs in
let ptsto = Sil.hpred_sub sub ptsto_foot 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 let atoms' = List.map ~f:(fun (id, e) -> Prop.mk_eq tenv (Exp.Var id) e) eqs in
(ptsto, ptsto_foot, atoms @ atoms') (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. (** Check if the path in exp exists already in the current ptsto predicate.
If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *)
let prop_iter_check_fields_ptsto_shallow tenv iter lexp = 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, _ = let _, se, _ =
match Prop.prop_iter_current tenv iter with match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, t), _ -> | Predicates.Hpointsto (e, se, t), _ ->
(e, se, t) (e, se, t)
| _ -> | _ ->
assert false assert false
@ -503,9 +503,9 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
let rec check_offset se = function let rec check_offset se = function
| [] -> | [] ->
None None
| Sil.Off_fld (fld, _) :: off' -> ( | Predicates.Off_fld (fld, _) :: off' -> (
match se with match se with
| Sil.Estruct (fsel, _) -> ( | Predicates.Estruct (fsel, _) -> (
match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with
| Some (_, se') -> | Some (_, se') ->
check_offset se' off' check_offset se' off'
@ -513,7 +513,7 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
Some fld ) Some fld )
| _ -> | _ ->
Some fld ) Some fld )
| Sil.Off_index _ :: _ -> | Predicates.Off_index _ :: _ ->
None None
in in
check_offset se offset 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: " ; L.d_str "entering prop_iter_extend_ptsto lexp: " ;
Exp.d_exp lexp ; Exp.d_exp lexp ;
L.d_ln () ) ; 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 max_stamp = Prop.prop_iter_max_stamp iter in
let extend_footprint_pred = function let extend_footprint_pred = function
| Sil.Hpointsto (e, se, te) -> | Predicates.Hpointsto (e, se, te) ->
let atoms_se_te_list = let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se te strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se te
offset inst offset inst
in in
List.map 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 atoms_se_te_list
| Sil.Hlseg (k, hpara, e1, e2, el) -> ( | Predicates.Hlseg (k, hpara, e1, e2, el) -> (
match hpara.Sil.body with match hpara.Predicates.body with
| Sil.Hpointsto (e', se', te') :: body_rest -> | Predicates.Hpointsto (e', se', te') :: body_rest ->
let atoms_se_te_list = let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se' te' strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se' te'
offset inst offset inst
in in
let atoms_body_list = let atoms_body_list =
List.map 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 atoms_se_te_list
in in
let atoms_hpara_list = let atoms_hpara_list =
List.map 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 atoms_body_list
in in
List.map 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 atoms_hpara_list
| _ -> | _ ->
assert false ) assert false )
@ -568,7 +569,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let iter' = let iter' =
List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms
in in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se, te)) Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se, te))
in in
let do_extend e se te = let do_extend e se te =
if Config.trace_rearrange then ( 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: " ; L.d_str "e: " ;
Exp.d_exp e ; Exp.d_exp e ;
L.d_str " se : " ; L.d_str " se : " ;
Sil.d_sexp se ; Predicates.d_sexp se ;
L.d_str " te: " ; L.d_str " te: " ;
Exp.d_texp_full te ; Exp.d_texp_full te ;
L.d_ln () ; L.d_ln () ;
@ -608,11 +609,11 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let sigma_pto, sigma_rest = let sigma_pto, sigma_rest =
List.partition_tf List.partition_tf
~f:(function ~f:(function
| Sil.Hpointsto (e', _, _) -> | Predicates.Hpointsto (e', _, _) ->
Exp.equal e e' Exp.equal e e'
| Sil.Hlseg (_, _, e1, _, _) -> | Predicates.Hlseg (_, _, e1, _, _) ->
Exp.equal e 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 ) Exp.equal e e_iF || Exp.equal e e_iB )
footprint_sigma footprint_sigma
in in
@ -630,7 +631,8 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
[([], footprint_sigma)] [([], footprint_sigma)]
in in
List.map 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 atoms_sigma_list
in in
let iter_atoms_fp_sigma_list = list_product iter_list atoms_fp_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 res_iter_list
in in
match Prop.prop_iter_current tenv iter with match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, te), _ -> | Predicates.Hpointsto (e, se, te), _ ->
do_extend e se te do_extend e se te
| _ -> | _ ->
assert false assert false
@ -695,7 +697,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
| Some iter -> | Some iter ->
Prop.prop_iter_prev_then_insert iter ptsto Prop.prop_iter_prev_then_insert iter ptsto
in 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 Prop.prop_iter_set_state iter offsets_default
@ -817,10 +819,10 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
false false
in in
match get_fld_strexp_and_typ typ typ_matches_guarded_by flds with 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 List.find_map
~f:(function ~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 -> when Exp.equal lhs_exp matching_exp ->
get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds 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 -> ~f:(fun hpred ->
(* FIXME: silenced warning may be legit *) (* FIXME: silenced warning may be legit *)
match[@warning "-57"] hpred with match[@warning "-57"] hpred with
| Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ}) | Predicates.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
(_, 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) -> when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) ->
Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) Some (Predicates.Eexp (lhs_exp, Predicates.inst_none), typ)
| Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> ( | Predicates.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> (
(* first, try to find a field that exactly matches the guarded-by string *) (* 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 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 -> | 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 match_on_field_type typ flds
| Some _ as res_opt -> | Some _ as res_opt ->
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 when ( guarded_by_str_is_current_class_this guarded_by_str0 pname
|| guarded_by_str_is_super_class_this guarded_by_str0 pname ) || guarded_by_str_is_super_class_this guarded_by_str0 pname )
&& Pvar.is_this pvar -> && Pvar.is_this pvar ->
@ -915,7 +918,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
false ) false )
|| (* or the prop says we already have the lock *) || (* or the prop says we already have the lock *)
List.exists 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) (Attribute.get_for_exp tenv prop guarded_by_exp)
in in
let guardedby_is_self_referential = 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 = let is_accessible_through_local_ref exp =
List.exists List.exists
~f:(function ~f:(function
| Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> | Predicates.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) ->
Exp.equal exp rhs_exp Exp.equal exp rhs_exp
| Sil.Hpointsto (_, Estruct (flds, _), _) -> | Predicates.Hpointsto (_, Estruct (flds, _), _) ->
List.exists List.exists
~f:(fun (fld, strexp) -> ~f:(fun (fld, strexp) ->
match strexp with match strexp with
| Sil.Eexp (rhs_exp, _) -> | Predicates.Eexp (rhs_exp, _) ->
Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld)
| _ -> | _ ->
false ) false )
@ -965,7 +968,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
&& not (proc_has_suppress_guarded_by_annot pdesc) && not (proc_has_suppress_guarded_by_annot pdesc)
in in
match find_guarded_by_exp guarded_by_str prop.Prop.sigma with 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 if is_read_write_lock typ then
(* TODO: model/understand read-write locks rather than ignoring them *) (* TODO: model/understand read-write locks rather than ignoring them *)
prop prop
@ -1006,13 +1009,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
in in
let check_fld_locks typ prop_acc (fld, strexp) = let check_fld_locks typ prop_acc (fld, strexp) =
match strexp with 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 enforce_guarded_access fld typ prop_acc
| _ -> | _ ->
prop_acc prop_acc
in in
let hpred_check_flds prop_acc = function 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 List.fold ~f:(check_fld_locks typ) ~init:prop_acc flds
| _ -> | _ ->
prop_acc 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 List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter_foot atoms
in in
let iter' = Prop.prop_iter_replace_footprint_sigma iter_foot_atoms sigma_fp 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 Prop.prop_iter_set_state iter' offsets_default
@ -1117,7 +1120,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
else ( else (
check_field_splitting () ; check_field_splitting () ;
match Prop.prop_iter_current tenv iter with 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 max_stamp = Prop.prop_iter_max_stamp iter in
let atoms_se_te_list = let atoms_se_te_list =
strexp_extend_values pname tenv orig_prop false Ident.kprimed (ref max_stamp) se te 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' = let iter' =
List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms' List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms'
in in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se', te')) Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se', te'))
in in
let filter it = let filter it =
let p = Prop.prop_iter_to_prop tenv it in 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 if Config.nelseg then
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in let _, para_inst1 = Predicates.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 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 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_base_case = 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 Prop.prop_iter_update_current_by_list iter para_inst
in in
recurse_on_iters [iter_inductive_case; iter_base_case] recurse_on_iters [iter_inductive_case; iter_base_case]
else else
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in let _, para_inst1 = Predicates.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 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 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
recurse_on_iters [iter_inductive_case] 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_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in 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 _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll n' e1 e3 e4 elist] in
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll n' e1 e3 e4 elist]
in
Prop.prop_iter_update_current_by_list iter hpred_list1 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_base_case = 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 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.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' 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_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in 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 _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll e1 e2 e4 n' elist] in
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll e1 e2 e4 n' elist]
in
Prop.prop_iter_update_current_by_list iter hpred_list1 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_base_case = 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 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.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' 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_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist =
let iter_nonemp_case = let iter_nonemp_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in let _, para_inst1 = Predicates.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 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 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_subcases = let iter_subcases =
@ -1236,10 +1235,8 @@ let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter
elist = elist =
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in 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 _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll n' e1 e3 e4 elist] in
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll n' e1 e3 e4 elist]
in
Prop.prop_iter_update_current_by_list iter hpred_list1 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_subcases = let iter_subcases =
@ -1261,10 +1258,8 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p
elist = elist =
let iter_inductive_case = let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in 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 _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll e1 e2 e4 n' elist] in
para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll e1 e2 e4 n' elist]
in
Prop.prop_iter_update_current_by_list iter hpred_list1 Prop.prop_iter_update_current_by_list iter hpred_list1
in in
let iter_subcases = 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 *) (** find the type at the offset from the given type expression, if any *)
let type_at_offset tenv texp off = 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 match (off, typ.desc) with
| [], _ -> | [], _ ->
Some typ 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 = let check_type_size tenv pname prop texp off typ_from_instr =
L.d_strln ~color:Orange "check_type_size" ; L.d_strln ~color:Orange "check_type_size" ;
L.d_str "off: " ; L.d_str "off: " ;
Sil.d_offset_list off ; Predicates.d_offset_list off ;
L.d_ln () ; L.d_ln () ;
L.d_str "typ_from_instr: " ; L.d_str "typ_from_instr: " ;
Typ.d_full 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 * that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *) * new iters in the result. *)
let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : 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 let rec root_typ_of_offsets = function
| Sil.Off_fld (f, fld_typ) :: _ -> ( | Predicates.Off_fld (f, fld_typ) :: _ -> (
match fld_typ.desc with match fld_typ.desc with
| Tstruct _ -> | Tstruct _ ->
(* access through field: get the struct type from the field *) (* 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 fld_typ
| _ -> | _ ->
typ_from_instr ) typ_from_instr )
| Sil.Off_index _ :: off -> | Predicates.Off_index _ :: off ->
Typ.mk_array (root_typ_of_offsets off) Typ.mk_array (root_typ_of_offsets off)
| _ -> | _ ->
typ_from_instr typ_from_instr
in 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 ( if Config.trace_rearrange then (
L.d_increase_indent () ; L.d_increase_indent () ;
L.d_strln "entering iter_rearrange" ; 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 f_many_iters [] iters
in in
let filter = function let filter = function
| Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) -> | Predicates.Hpointsto (base, _, _) | Predicates.Hlseg (_, _, base, _, _) ->
Prover.is_root tenv prop base lexp 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 let result_first = Prover.is_root tenv prop first lexp in
match result_first with match result_first with
| None -> | None ->
@ -1430,14 +1425,14 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst :
[default_case_iter iter] [default_case_iter iter]
| Some iter -> ( | Some iter -> (
match Prop.prop_iter_current tenv iter with 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 ; 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 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 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 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 match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with
| None, None -> | None, None ->
assert false 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 iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist
| _, Some _ -> | _, Some _ ->
iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist ) 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 match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with
| None, None -> | None, None ->
assert false 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 is_annotation tenv prop exp =
let attr_has_annot = function 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 -> when is_annotation ret_attr ->
Some (Typ.Procname.to_string pname) 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 false
in in
match strexp with 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 let has_annot = fld_has_annot fld in
if has_annot then obj_str := Some (Typ.Fieldname.to_simplified_string fld) ; if has_annot then obj_str := Some (Typ.Fieldname.to_simplified_string fld) ;
has_annot 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 obj_str = ref None in
let is_pt_by_fld_or_param_with_annot hpred = let is_pt_by_fld_or_param_with_annot hpred =
match hpred with 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 -> when Exp.equal exp deref_exp ->
let var_has_annotation = Pvar.is_seed pvar && var_has_annotation pdesc is_annotation pvar in 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) ; 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 ; 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 *) (* 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 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 List.for_all ~f:(is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp) flds
| _ -> | _ ->
true true
@ -1648,7 +1643,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc =
let get_exp_called () = let get_exp_called () =
(* Exp called in the block's function call*) (* Exp called in the block's function call*)
match State.get_instr () with 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 Errdesc.find_ident_assignment (State.get_node_exn ()) id
| _ -> | _ ->
None 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 It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *)
let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc : 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 = let nlexp =
match Prop.exp_normalize_prop tenv prop lexp with match Prop.exp_normalize_prop tenv prop lexp with
| Exp.BinOp (Binop.PlusPI, ep, e) -> | Exp.BinOp (Binop.PlusPI, ep, e) ->
@ -1718,7 +1713,7 @@ let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc :
e e
in in
let ptr_tested_for_zero = Prover.check_disequal tenv prop (Exp.root_of_lexp nlexp) Exp.zero 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_strln ".... Rearrangement Start ...." ;
L.d_str "Exp: " ; L.d_str "Exp: " ;
Exp.d_exp nlexp ; Exp.d_exp nlexp ;

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

@ -32,7 +32,7 @@ val rearrange :
-> Typ.t -> Typ.t
-> Prop.normal Prop.t -> Prop.normal Prop.t
-> Location.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 (** [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 iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which
leads to [lexp] as the iterator state. *) 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 sigma = prop.Prop.sigma in
let check_weak_alias hpred = let check_weak_alias hpred =
match hpred with match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e', _), Sizeof {typ}) -> ( | Predicates.Hpointsto (_, Eexp (e', _), Sizeof {typ}) -> (
match typ.Typ.desc with match typ.Typ.desc with
| (Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained)) | (Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained))
when Exp.equal e' e -> when Exp.equal e' e ->
@ -154,7 +154,8 @@ let get_cycles found_cycles root tenv prop =
let sigma = prop.Prop.sigma in let sigma = prop.Prop.sigma in
let get_points_to e = let get_points_to e =
List.find 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 sigma
in in
(* Perform a dfs of a graph stopping when e_root is reached. Returns the set of cycles reached. *) (* 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 match fields with
| [] -> | [] ->
found_cycles 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 rc_field = {rc_field_name= field; rc_field_inst= f_inst} in
let obj_edge = {rc_from= from_node; rc_field} in let obj_edge = {rc_from= from_node; rc_field} in
let edge = Object obj_edge 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 match get_points_to f_exp with
| None -> | None ->
found_cycles 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 -> when edge_is_strong tenv obj_edge ->
let rc_to = {rc_node_exp= f_exp; rc_node_typ= te} in 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) 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 found_cycles
in in
match root with 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 let se_root = {rc_node_exp= e_root; rc_node_typ= te} in
(* start dfs with empty path and expr pointing to root *) (* 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:[] 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_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} 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 = let is_inst_rearrange node =
match node with match node with
| Object obj -> ( | 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 _ -> | Block _ ->
false 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) = 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) = 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_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} 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 subst =
let count = ref Int.min_value in let count = ref Int.min_value in
let gensym id = incr count ; Ident.set_stamp id !count 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 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 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 get_inst_update pos =
let loc = get_loc_exn () in let loc = get_loc_exn () in
Sil.inst_update loc pos Predicates.inst_update loc pos
let get_path () = let get_path () =
@ -191,7 +191,7 @@ let extract_pre p tenv pdesc abstract_fun =
let sub = let sub =
let idlist = Prop.free_vars p |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let idlist = Prop.free_vars p |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in
let count = ref 0 in let count = ref 0 in
Sil.subst_of_list Predicates.subst_of_list
(List.map (List.map
~f:(fun id -> ~f:(fun id ->
incr count ; 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 val get_diverging_states_proc : unit -> Paths.PathSet.t
(** Get the diverging states for the procedure *) (** 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 *) (** Get update instrumentation for the current loc *)
val get_instr : unit -> Sil.instr option 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 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 = let fail pp_fld fld =
L.d_strln ".... Invalid Field Access ...." ; L.d_strln ".... Invalid Field Access ...." ;
L.d_printfln "Fld : %a" pp_fld fld ; 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 -> | _, Off_index (Const (Cint i)) when IntLit.iszero i ->
typ 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 (** 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 () = let pp_error () =
L.d_strln ".... Invalid Field ...." ; L.d_strln ".... Invalid Field ...." ;
L.d_str "strexp : " ; L.d_str "strexp : " ;
Sil.d_sexp strexp ; Predicates.d_sexp strexp ;
L.d_ln () ; L.d_ln () ;
L.d_str "offlist : " ; L.d_str "offlist : " ;
Sil.d_offset_list offlist ; Predicates.d_offset_list offlist ;
L.d_ln () ; L.d_ln () ;
L.d_str "type : " ; L.d_str "type : " ;
Typ.d_full typ ; 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 () L.d_ln ()
in in
match (offlist, strexp, typ.Typ.desc) with match (offlist, strexp, typ.Typ.desc) with
| [], Sil.Eexp (e, inst_curr), _ -> | [], Predicates.Eexp (e, inst_curr), _ ->
let inst_new = let inst_new =
match inst with match inst with
| Sil.Ilookup -> | Predicates.Ilookup ->
(* a lookup does not change an inst unless it is inst_initial *) (* a lookup does not change an inst unless it is inst_initial *)
lookup_inst := Some inst_curr ; lookup_inst := Some inst_curr ;
inst_curr inst_curr
| _ -> | _ ->
Sil.update_inst inst_curr inst Predicates.update_inst inst_curr inst
in in
let e' = f (Some e) in let e' = f (Some e) in
(e', Sil.Eexp (e', inst_new), typ, None) (e', Predicates.Eexp (e', inst_new), typ, None)
| [], Sil.Estruct (fesl, inst'), _ -> | [], Predicates.Estruct (fesl, inst'), _ ->
if not nullify_struct then (f None, Sil.Estruct (fesl, inst'), typ, None) if not nullify_struct then (f None, Predicates.Estruct (fesl, inst'), typ, None)
else if fp_root then ( else if fp_root then (
pp_error () ; pp_error () ;
assert false ) assert false )
else ( else (
L.d_strln "WARNING: struct assignment treated as nondeterministic assignment" ; 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) ) (f None, Prop.create_strexp_of_type tenv Prop.Fld_init typ None inst, typ, None) )
| [], Sil.Earray _, _ -> | [], Predicates.Earray _, _ ->
let offlist' = Sil.Off_index Exp.zero :: offlist in 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 apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst
lookup_inst lookup_inst
| Sil.Off_fld _ :: _, Sil.Earray _, _ -> | Predicates.Off_fld _ :: _, Predicates.Earray _, _ ->
let offlist_new = Sil.Off_index Exp.zero :: offlist in 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 apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst
lookup_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 match Tenv.lookup tenv name with
| Some ({fields} as struct_typ) -> ( | 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 match List.find ~f:(fun fse -> Typ.Fieldname.equal fld (fst fse)) fsel with
| Some (_, se') -> | Some (_, se') ->
let res_e', res_se', res_t', res_pred_insts_op' = 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 = let replace_fse fse =
if Typ.Fieldname.equal fld (fst fse) then (fld, res_se') else fse if Typ.Fieldname.equal fld (fst fse) then (fld, res_se') else fse
in 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) = let replace_fta (f, t, a) =
if Typ.Fieldname.equal fld f then (fld, res_t', a) else (f, t, a) if Typ.Fieldname.equal fld f then (fld, res_t', a) else (f, t, a)
in in
@ -130,11 +132,11 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty
| None -> | None ->
pp_error () ; pp_error () ;
assert false ) assert false )
| Sil.Off_fld _ :: _, _, _ -> | Predicates.Off_fld _ :: _, _, _ ->
pp_error () ; pp_error () ;
assert false assert false
| ( Sil.Off_index idx :: offlist' | ( Predicates.Off_index idx :: offlist'
, Sil.Earray (len, esel, inst1) , Predicates.Earray (len, esel, inst1)
, Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> ( , Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> (
let nidx = Prop.exp_normalize_prop tenv p idx in 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 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 lookup_inst
in in
let replace_ese ese = if Exp.equal idx_ese' (fst ese) then (idx_ese', res_se') else ese 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 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') (res_e', res_se, res_t, res_pred_insts_op')
| None -> | 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" ; L.d_strln " not materialized -- returning nondeterministic value" ;
let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in
(res_e', strexp, typ, None) ) (res_e', strexp, typ, None) )
| Sil.Off_index _ :: _, _, _ -> | Predicates.Off_index _ :: _, _, _ ->
(* This case should not happen. The rearrangement should (* This case should not happen. The rearrangement should
have materialized all the accessed cells. *) have materialized all the accessed cells. *)
pp_error () ; 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 fp_root = match lexp with Exp.Var id -> Ident.is_footprint id | _ -> false in
let lookup_inst = ref None in let lookup_inst = ref None in
let e', se', typ', pred_insts_op' = 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 apply_offlist pdesc tenv p fp_root false (lexp, se, sizeof.Exp.typ) offlist f
lookup_inst Predicates.inst_lookup lookup_inst
in in
let lookup_uninitialized = let lookup_uninitialized =
(* true if we have looked up an uninitialized value *) (* 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 in
let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in
(e', ptsto', pred_insts_op', lookup_uninitialized) (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. *) (** Precondition: se should not include hpara_psto that could mean nonempty heaps. *)
let rec execute_nullify_se = function let rec execute_nullify_se = function
| Sil.Eexp _ -> | Predicates.Eexp _ ->
Sil.Eexp (Exp.zero, Sil.inst_nullify) Predicates.Eexp (Exp.zero, Predicates.inst_nullify)
| Sil.Estruct (fsel, _) -> | Predicates.Estruct (fsel, _) ->
let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in
Sil.Estruct (fsel', Sil.inst_nullify) Predicates.Estruct (fsel', Predicates.inst_nullify)
| Sil.Earray (len, esel, _) -> | Predicates.Earray (len, esel, _) ->
let esel' = List.map ~f:(fun (idx, se) -> (idx, execute_nullify_se se)) esel in 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 (** 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 check_already_dereferenced tenv pname cond prop =
let find_hpred lhs = let find_hpred lhs =
List.find 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 prop.Prop.sigma
in in
let rec is_check_zero = function let rec is_check_zero = function
@ -452,7 +458,7 @@ let check_already_dereferenced tenv pname cond prop =
match is_check_zero cond with match is_check_zero cond with
| Some id -> ( | Some id -> (
match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with 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 match Tabulation.find_dereference_without_null_check_in_sexp se with
| Some n -> | Some n ->
Some (id, n) Some (id, n)
@ -479,11 +485,11 @@ let check_already_dereferenced tenv pname cond prop =
exception in that case *) exception in that case *)
let check_deallocate_static_memory prop_after = let check_deallocate_static_memory prop_after =
let check_deallocated_attribute = function 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 -> when Pvar.is_local pv || Pvar.is_global pv ->
let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in
raise (Exceptions.Deallocate_stack_variable freed_desc) 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 let freed_desc = Errdesc.explain_deallocate_constant_string s ra in
raise (Exceptions.Deallocate_static_memory freed_desc) raise (Exceptions.Deallocate_static_memory freed_desc)
| _ -> | _ ->
@ -543,7 +549,7 @@ let resolve_typename prop receiver_exp =
let rec loop = function let rec loop = function
| [] -> | [] ->
None None
| Sil.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp -> | Predicates.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp ->
Some typexp Some typexp
| _ :: hpreds -> | _ :: hpreds ->
loop hpreds loop hpreds
@ -760,7 +766,7 @@ let receiver_self receiver prop =
List.exists List.exists
~f:(fun hpred -> ~f:(fun hpred ->
match hpred with 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 Exp.equal e receiver && Pvar.is_seed pv && Pvar.is_self pv
| _ -> | _ ->
false ) 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 add_to_footprint tenv abduced_pv typ prop =
let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let prop' = 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 in
(prop', fresh_fp_var) (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. 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 *) 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 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 let prop' = add_strexp_to_footprint tenv struct_strexp abduced_pv typ prop in
(prop', struct_strexp) (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 List.find_map
~f:(fun hpred -> ~f:(fun hpred ->
match hpred with 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 Some exp
| _ -> | _ ->
None ) 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 *) (* 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_to_abduced_val exp_to_bind abduced prop =
let bind_exp prop = function 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.conjoin_eq tenv exp_to_bind rhs prop
| _ -> | _ ->
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 iter_ren = Prop.prop_iter_make_id_primed tenv id iter in
let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in
match Prop.prop_iter_current tenv iter_ren with 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 = let contents, new_ptsto, pred_insts_op, lookup_uninitialized =
ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id
in in
@ -980,7 +987,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l
false false
in in
let update acc (pi, sigma) = 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 sigma' = new_ptsto :: sigma in
let iter' = update_iter iter_ren pi' sigma' in let iter' = update_iter iter_ren pi' sigma' in
let prop' = Prop.prop_iter_to_prop tenv iter' 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 ([], []) update acc_in ([], [])
| Some pred_insts -> | Some pred_insts ->
List.rev (List.fold ~f:update ~init:acc_in 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@." ; Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@." ;
Prop.prop_iter_to_prop tenv iter_ren :: acc_in 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 execute_store_ pdesc tenv rhs_exp acc_in iter =
let lexp, strexp, sizeof, offlist = let lexp, strexp, sizeof, offlist =
match Prop.prop_iter_current tenv iter with 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) (lexp, strexp, sizeof, offlist)
| _ -> | _ ->
assert false assert false
@ -1154,7 +1161,7 @@ let declare_locals_and_ret tenv pdesc (prop_ : Prop.normal Prop.t) =
let ptsto = let ptsto =
(pvar, Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}, None) (pvar, Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}, None)
in 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 in
let sigma_locals_and_ret () = let sigma_locals_and_ret () =
let pname = Procdesc.get_proc_name pdesc in 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 let eprop = Prop.expose prop_ in
match match
List.partition_tf 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 eprop.Prop.sigma
with with
| [Sil.Hpointsto (e, se, typ)], sigma' -> | [Predicates.Hpointsto (e, se, typ)], sigma' ->
let sigma'' = let sigma'' =
let se' = execute_nullify_se se in let se' = execute_nullify_se se in
Sil.Hpointsto (e, se', typ) :: sigma' Predicates.Hpointsto (e, se', typ) :: sigma'
in in
let eprop_res = Prop.set eprop ~sigma:sigma'' in let eprop_res = Prop.set eprop ~sigma:sigma'' in
ret_old_path [Prop.normalize tenv eprop_res] 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 = let already_has_abduced_retval p =
List.exists List.exists
~f:(fun hpred -> ~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 p.Prop.sigma_fp
in in
(* prevent introducing multiple abduced retvals for a single call site in a loop *) (* 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, _) -> | Typ.Tptr (typ, _) ->
(* for pointer types passed by reference, do abduction directly on the pointer *) (* 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 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) L.(die InternalError)
"No need for abduction on non-pointer type %s" (Typ.to_string actual_typ) "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 = let filtered_sigma =
List.map List.map
~f:(function ~f:(function
| Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> | Predicates.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual ->
Sil.Hpointsto (lhs, abduced_strexp, typ_exp) Predicates.Hpointsto (lhs, abduced_strexp, typ_exp)
| hpred -> | hpred ->
hpred ) hpred )
prop'.Prop.sigma 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 prop' =
let filtered_sigma = let filtered_sigma =
List.filter 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 prop.Prop.sigma
in in
Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma) 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 List.fold
~f:(fun p hpred -> ~f:(fun p hpred ->
match hpred with match hpred with
| Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced -> | Predicates.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced ->
let new_hpred = Sil.Hpointsto (actual, rhs, texp) in let new_hpred = Predicates.Hpointsto (actual, rhs, texp) in
Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma)) Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma))
| _ -> | _ ->
p ) p )
@ -1638,7 +1650,7 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots
let do_exp p (e, _) = let do_exp p (e, _) =
let do_attribute q atom = let do_attribute q atom =
match atom with 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 Attribute.remove_for_attr tenv q res
| _ -> | _ ->
q 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 List.map ~f:(fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed
in in
let ren_sub = 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 in
let p' = Prop.normalize tenv (Prop.prop_sub ren_sub p) in let p' = Prop.normalize tenv (Prop.prop_sub ren_sub p) in
let fav_normal = List.map ~f:snd ids_primed_normal 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 module L = Logging
type splitting = type splitting =
{ sub: Sil.subst { sub: Predicates.subst
; frame: Sil.hpred list ; frame: Predicates.hpred list
; missing_pi: Sil.atom list ; missing_pi: Predicates.atom list
; missing_sigma: Sil.hpred list ; missing_sigma: Predicates.hpred list
; frame_fld: Sil.hpred list ; frame_fld: Predicates.hpred list
; missing_fld: Sil.hpred list ; missing_fld: Predicates.hpred list
; frame_typ: (Exp.t * Exp.t) list ; frame_typ: (Exp.t * Exp.t) list
; missing_typ: (Exp.t * Exp.t) list } ; missing_typ: (Exp.t * Exp.t) list }
@ -60,8 +60,8 @@ type invalid_res =
type valid_res = type valid_res =
{ incons_pre_missing: bool (** whether the actual pre is consistent with the missing part *) { incons_pre_missing: bool (** whether the actual pre is consistent with the missing part *)
; vr_pi: Sil.atom list (** missing pi *) ; vr_pi: Predicates.atom list (** missing pi *)
; vr_sigma: Sil.hpred list (** missing sigma *) ; vr_sigma: Predicates.hpred list (** missing sigma *)
; vr_cons_res: (Prop.normal Prop.t * Paths.Path.t) list (** consistent result props *) ; 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 *) } ; 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 in
let ids = Ident.HashQueue.keys fav in let ids = Ident.HashQueue.keys fav in
let ids' = List.map ~f:(fun i -> (i, Ident.create_fresh Ident.kprimed)) ids 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 pre' = BiabductionSummary.Jprop.jprop_sub ren_sub spec.BiabductionSummary.pre in
let posts' = let posts' =
List.map ~f:(fun (p, path) -> (Prop.prop_sub ren_sub p, path)) spec.BiabductionSummary.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 let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld
frame_typ missing_typ = frame_typ missing_typ =
let hpred_has_only_footprint_vars hpred = 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 in
let sub = Sil.sub_join sub1 sub2 in let sub = Predicates.sub_join sub1 sub2 in
let sub1_inverse = 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_list' = List.filter ~f:(function _, Exp.Var _ -> true | _ -> false) sub1_list in
let sub1_inverse_list = let sub1_inverse_list =
List.map ~f:(function id, Exp.Var id' -> (id', Exp.Var id) | _ -> assert false) sub1_list' List.map ~f:(function id, Exp.Var id' -> (id', Exp.Var id) | _ -> assert false) sub1_list'
in in
Sil.subst_of_list_duplicates sub1_inverse_list Predicates.subst_of_list_duplicates sub1_inverse_list
in in
let fav_actual_pre = let fav_actual_pre =
let fav_pre = Prop.free_vars actual_pre |> Ident.hashqueue_of_sequence in let fav_pre = Prop.free_vars actual_pre |> Ident.hashqueue_of_sequence in
let filter id = Int.equal (Ident.get_stamp id) (-1) in let filter id = Int.equal (Ident.get_stamp id) (-1) in
(* vars which represent expansions of fields *) (* vars which represent expansions of fields *)
Sil.sub_range sub2 Predicates.sub_range sub2
|> List.fold_left ~init:fav_pre ~f:(fun res e -> |> List.fold_left ~init:fav_pre ~f:(fun res e ->
Exp.free_vars e |> Sequence.filter ~f:filter |> Ident.hashqueue_of_sequence ~init:res ) Exp.free_vars e |> Sequence.filter ~f:filter |> Ident.hashqueue_of_sequence ~init:res )
in 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 Prop.sigma_sub sub missing_fld |> Prop.sigma_free_vars |> Ident.hashqueue_of_sequence
in in
let map_var_to_pre_var_or_fresh id = 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' -> | Exp.Var id' ->
if if
Ident.HashQueue.mem fav_actual_pre id' || Ident.is_path id' 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 assert false
in in
let sub_list = Sil.sub_to_list sub in let sub_list = Predicates.sub_to_list sub in
let sub1 = let sub1 =
let f id = let f id =
if Ident.HashQueue.mem fav_actual_pre id then (id, Exp.Var 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.HashQueue.mem fav_missing_fld id then (id, Exp.Var id)
else if Ident.is_footprint id then (id, Exp.Var id) else if Ident.is_footprint id then (id, Exp.Var id)
else else
let dom1 = Sil.sub_domain sub1 in let dom1 = Predicates.sub_domain sub1 in
let rng1 = Sil.sub_range sub1 in let rng1 = Predicates.sub_range sub1 in
let dom2 = Sil.sub_domain sub2 in let dom2 = Predicates.sub_domain sub2 in
let rng2 = Sil.sub_range sub2 in let rng2 = Predicates.sub_range sub2 in
let vars_actual_pre = let vars_actual_pre =
List.map ~f:(fun id -> Exp.Var id) (Ident.HashQueue.keys fav_actual_pre) List.map ~f:(fun id -> Exp.Var id) (Ident.HashQueue.keys fav_actual_pre)
in 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 ) Exp.free_vars e |> Ident.hashqueue_of_sequence ~init:fav )
|> Ident.HashQueue.keys |> Ident.HashQueue.keys
in in
Sil.subst_of_list (List.map ~f fav_sub_list) Predicates.subst_of_list (List.map ~f fav_sub_list)
in in
let sub2_list = let sub2_list =
let f id = (id, Exp.Var (Ident.create_fresh Ident.kfootprint)) in let f id = (id, Exp.Var (Ident.create_fresh Ident.kfootprint)) in
List.map ~f fav_missing_primed List.map ~f fav_missing_primed
in in
let sub_list' = List.map ~f:(fun (id, e) -> (id, Sil.exp_sub sub1 e)) sub_list in let sub_list' = List.map ~f:(fun (id, e) -> (id, Predicates.exp_sub sub1 e)) sub_list in
let sub' = Sil.subst_of_list (sub2_list @ sub_list') in let sub' = Predicates.subst_of_list (sub2_list @ sub_list') in
(* normalize everything w.r.t sub' *) (* normalize everything w.r.t sub' *)
let norm_missing_pi = Prop.pi_sub sub' missing_pi in let norm_missing_pi = Prop.pi_sub sub' missing_pi in
let norm_missing_sigma = Prop.sigma_sub sub' missing_sigma 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_fld = Prop.sigma_sub sub' frame_fld in
let norm_frame_typ = 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 in
let norm_missing_typ = 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 in
let norm_missing_fld = let norm_missing_fld =
let sigma = Prop.sigma_sub sub' missing_fld in let sigma = Prop.sigma_sub sub' missing_fld in
let filter hpred = let filter hpred =
if not (hpred_has_only_footprint_vars hpred) then ( if not (hpred_has_only_footprint_vars hpred) then (
L.d_warning "Missing fields hpred has non-footprint vars: " ; L.d_warning "Missing fields hpred has non-footprint vars: " ;
Sil.d_hpred hpred ; Predicates.d_hpred hpred ;
L.d_ln () ; L.d_ln () ;
false ) false )
else else
match hpred with match hpred with
| Sil.Hpointsto (Exp.Var _, _, _) -> | Predicates.Hpointsto (Exp.Var _, _, _) ->
true true
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> | Predicates.Hpointsto (Exp.Lvar pvar, _, _) ->
Pvar.is_global pvar Pvar.is_global pvar
| _ -> | _ ->
L.d_warning "Missing fields in complex pred: " ; L.d_warning "Missing fields in complex pred: " ;
Sil.d_hpred hpred ; Predicates.d_hpred hpred ;
L.d_ln () ; L.d_ln () ;
false false
in 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, (** Check whether an inst represents a dereference without null check,
and return the line number and path position *) and return the line number and path position *)
let find_dereference_without_null_check_in_inst = function 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) Some (n, pos)
| _ -> | _ ->
None None
@ -334,13 +334,13 @@ let find_dereference_without_null_check_in_inst = function
(** Check whether a sexp contains a dereference without null check, (** Check whether a sexp contains a dereference without null check,
and return the line number and path position *) and return the line number and path position *)
let rec find_dereference_without_null_check_in_sexp = function let rec find_dereference_without_null_check_in_sexp = function
| Sil.Eexp (_, inst) -> | Predicates.Eexp (_, inst) ->
find_dereference_without_null_check_in_inst 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 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) if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd fsel)
else res else res
| Sil.Earray (_, esel, inst) -> | Predicates.Earray (_, esel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in 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) if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd esel)
else res 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] *) 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_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp = let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in let e_sub = Predicates.exp_sub sub e in
let desc use_buckets deref_str = let desc use_buckets deref_str =
let error_desc = let error_desc =
Errdesc.explain_dereference_as_caller_expression caller_pname tenv ~use_buckets deref_str 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 ) None )
in in
let check_hpred = function let check_hpred = function
| Sil.Hpointsto (lexp, se, _) -> | Predicates.Hpointsto (lexp, se, _) ->
check_dereference (Exp.root_of_lexp lexp) se check_dereference (Exp.root_of_lexp lexp) se
| _ -> | _ ->
None None
@ -441,9 +441,9 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo
Some deref_err ) Some deref_err )
let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list = let post_process_sigma tenv (sigma : Predicates.hpred list) loc : Predicates.hpred list =
let map_inst inst = Sil.inst_new_loc loc inst in let map_inst inst = Predicates.inst_new_loc loc inst in
let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in let do_hpred (_, _, hpred) = Predicates.hpred_instmap map_inst hpred in
(* update the location of instrumentations *) (* update the location of instrumentations *)
List.map ~f:(fun hpred -> do_hpred (Prover.expand_hpred_pointer tenv false hpred)) sigma 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_path_errors_in_post tenv caller_pname post post_path =
let check_attr atom = let check_attr atom =
match atom with match atom with
| Sil.Apred (Adiv0 path_pos, [e]) -> | Predicates.Apred (Adiv0 path_pos, [e]) ->
if Prover.check_zero tenv e then ( if Prover.check_zero tenv e then (
let desc = let desc =
Errdesc.explain_divide_by_zero tenv e (State.get_node_exn ()) (State.get_loc_exn ()) 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 false
in in
let atom_update_alloc_attribute = function let atom_update_alloc_attribute = function
| Sil.Apred (Aresource ra, [e]) | Predicates.Apred (Aresource ra, [e])
when not when not
( PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease ( PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease
&& actual_pre_has_freed_attribute e ) -> && actual_pre_has_freed_attribute e ) ->
(* unless it was already freed before the call *) (* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find tenv post e in let vpath, _ = Errdesc.vpath_find tenv post e in
let ra' = {ra with ra_pname= callee_pname; ra_loc= loc; ra_vpath= vpath} 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 ->
a a
in in
@ -506,24 +506,24 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre
let hpred_lhs_compare hpred1 hpred2 = let hpred_lhs_compare hpred1 hpred2 =
match (hpred1, hpred2) with match (hpred1, hpred2) with
| Sil.Hpointsto (e1, _, _), Sil.Hpointsto (e2, _, _) -> | Predicates.Hpointsto (e1, _, _), Predicates.Hpointsto (e2, _, _) ->
Exp.compare e1 e2 Exp.compare e1 e2
| Sil.Hpointsto _, _ -> | Predicates.Hpointsto _, _ ->
-1 -1
| _, Sil.Hpointsto _ -> | _, Predicates.Hpointsto _ ->
1 1
| hpred1, hpred2 -> | hpred1, hpred2 ->
Sil.compare_hpred hpred1 hpred2 Predicates.compare_hpred hpred1 hpred2
(** set the inst everywhere in a sexp *) (** set the inst everywhere in a sexp *)
let rec sexp_set_inst inst = function let rec sexp_set_inst inst = function
| Sil.Eexp (e, _) -> | Predicates.Eexp (e, _) ->
Sil.Eexp (e, inst) Predicates.Eexp (e, inst)
| Sil.Estruct (fsel, _) -> | Predicates.Estruct (fsel, _) ->
Sil.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst) Predicates.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst)
| Sil.Earray (len, esel, _) -> | Predicates.Earray (len, esel, _) ->
Sil.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst) Predicates.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst)
let rec fsel_star_fld fsel1 fsel2 = let rec fsel_star_fld fsel1 fsel2 =
@ -551,7 +551,7 @@ and esel_star_fld esel1 esel2 =
match (esel1, esel2) with match (esel1, esel2) with
| [], esel2 -> | [], esel2 ->
(* don't know whether element is read or written in fun call with array *) (* 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, [] ->
esel1 esel1
| (e1, se1) :: esel1', (e2, se2) :: esel2' -> ( | (e1, se1) :: esel1', (e2, se2) :: esel2' -> (
@ -561,26 +561,26 @@ and esel_star_fld esel1 esel2 =
| n when n < 0 -> | n when n < 0 ->
(e1, se1) :: esel_star_fld esel1' esel2 (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 *) (* don't know whether element is read or written in fun call with array *)
(e2, se2') :: esel_star_fld esel1 esel2' ) (e2, se2') :: esel_star_fld esel1 esel2' )
and sexp_star_fld se1 se2 : Sil.strexp = and sexp_star_fld se1 se2 : Predicates.strexp =
(* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *) (* L.d_str "sexp_star_fld "; Predicates.d_sexp se1; L.d_str " "; Predicates.d_sexp se2; L.d_ln (); *)
match (se1, se2) with match (se1, se2) with
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) -> | Predicates.Estruct (fsel1, _), Predicates.Estruct (fsel2, inst2) ->
Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2) Predicates.Estruct (fsel_star_fld fsel1 fsel2, inst2)
| Sil.Earray (len1, esel1, _), Sil.Earray (_, esel2, inst2) -> | Predicates.Earray (len1, esel1, _), Predicates.Earray (_, esel2, inst2) ->
Sil.Earray (len1, esel_star_fld esel1 esel2, inst2) Predicates.Earray (len1, esel_star_fld esel1 esel2, inst2)
| Sil.Eexp (_, inst1), Sil.Earray (len2, esel2, _) -> | Predicates.Eexp (_, inst1), Predicates.Earray (len2, esel2, _) ->
let esel1 = [(Exp.zero, se1)] in 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 " ; L.d_str "cannot star " ;
Sil.d_sexp se1 ; Predicates.d_sexp se1 ;
L.d_str " and " ; L.d_str " and " ;
Sil.d_sexp se2 ; Predicates.d_sexp se2 ;
L.d_ln () ; L.d_ln () ;
assert false assert false
@ -619,22 +619,23 @@ let texp_star tenv texp1 texp2 =
texp1 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 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 "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2;
L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *)
Sil.Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2) Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2)
| _ -> | _ ->
assert false assert false
(** Implementation of [*] for the field-splitting model *) (** 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 sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in
let sigma2 = List.stable_sort ~compare:hpred_lhs_compare sigma2 in let sigma2 = List.stable_sort ~compare:hpred_lhs_compare sigma2 in
(* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *) (* 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 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, _) = 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 = let hpred_star_typing (hpred1 : Predicates.hpred) (_, te2) : Predicates.hpred =
match hpred1 with Sil.Hpointsto (e1, se1, _) -> Sil.Hpointsto (e1, se1, te2) | _ -> assert false match hpred1 with Hpointsto (e1, se1, _) -> Hpointsto (e1, se1, te2) | _ -> assert false
(** Implementation of [*] between predicates and typings *) (** 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 typing_lhs_compare (e1, _) (e2, _) = Exp.compare e1 e2 in
let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in
let typings2 = List.stable_sort ~compare:typing_lhs_compare typings2 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 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 current_pi
| a :: new_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_warning "dropping atom with non-footprint variable" ;
L.d_ln () ; L.d_ln () ;
Sil.d_atom a ; Predicates.d_atom a ;
L.d_ln () ; L.d_ln () ;
extend_pi current_pi new_pi' ) extend_pi current_pi new_pi' )
else extend_pi (a :: 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 prop_is_exn pname prop =
let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in
let is_exn = function 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 exp_is_exn e2
| _ -> | _ ->
false false
@ -784,7 +787,7 @@ let prop_get_exn_name pname prop =
let rec search_exn e = function let rec search_exn e = function
| [] -> | [] ->
None 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 Some name
| _ :: tl -> | _ :: tl ->
search_exn e tl search_exn e tl
@ -792,7 +795,7 @@ let prop_get_exn_name pname prop =
let rec find_exn_name hpreds = function let rec find_exn_name hpreds = function
| [] -> | [] ->
None 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 search_exn e2 hpreds
| _ :: tl -> | _ :: tl ->
find_exn_name hpreds tl find_exn_name hpreds tl
@ -806,8 +809,8 @@ let lookup_custom_errors prop =
let rec search_error = function let rec search_error = function
| [] -> | [] ->
None None
| Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _ | Predicates.Hpointsto (Exp.Lvar var, Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _
when Pvar.equal var Sil.custom_error -> when Pvar.equal var Predicates.custom_error ->
Some error_str Some error_str
| _ :: tl -> | _ :: tl ->
search_error tl search_error tl
@ -819,8 +822,8 @@ let lookup_custom_errors prop =
let prop_set_exn tenv pname prop se_exn = let prop_set_exn tenv pname prop se_exn =
let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in
let map_hpred = function let map_hpred = function
| Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar -> | Predicates.Hpointsto (e, _, t) when Exp.equal e ret_pvar ->
Sil.Hpointsto (e, se_exn, t) Predicates.Hpointsto (e, se_exn, t)
| hpred -> | hpred ->
hpred hpred
in 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 if !BiabductionConfig.footprint && List.is_empty posts then
(* in case of divergence, produce a prop *) (* in case of divergence, produce a prop *)
(* with updated footprint and inconsistent current *) (* 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 else
List.map List.map
~f:(fun (p, path_post) -> ~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 handle_null_case_analysis sigma =
let id_assigned_to_null id = let id_assigned_to_null id =
let filter = function 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 Ident.equal id id' && IntLit.isnull i
| _ -> | _ ->
false 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) = let f (e, inst_opt) =
match (e, inst_opt) with match (e, inst_opt) with
| Exp.Var id, Some inst when id_assigned_to_null id -> | 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, Some inst')
| _ -> | _ ->
(e, inst_opt) (e, inst_opt)
in in
Sil.hpred_list_expmap f sigma Predicates.hpred_list_expmap f sigma
in in
let post_p2 = let post_p2 =
let post_p1_sigma = post_p1.Prop.sigma in 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 post_p2
| Some iter -> ( | Some iter -> (
let filter = function let filter = function
| Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar -> | Predicates.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar ->
Some () Some ()
| _ -> | _ ->
None None
@ -939,14 +942,14 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat
post_p2 post_p2
| Some iter' -> ( | Some iter' -> (
match fst (Prop.prop_iter_current tenv iter') with 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 *) (* resuls is an exception: set in caller *)
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
prop_set_exn tenv caller_pname p (Sil.Eexp (e', inst)) prop_set_exn tenv caller_pname p (Eexp (e', inst))
| Sil.Hpointsto (_, Sil.Eexp (e', _), _) -> | Predicates.Hpointsto (_, Eexp (e', _), _) ->
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
Prop.conjoin_eq tenv e' (Exp.Var ret_id) p Prop.conjoin_eq tenv e' (Exp.Var ret_id) p
| Sil.Hpointsto _ -> | Predicates.Hpointsto _ ->
(* returning nothing or unexpected sexp, turning into nondet *) (* returning nothing or unexpected sexp, turning into nondet *)
Prop.prop_iter_remove_curr_then_to_prop tenv iter' 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 in
let mk_instantiation (formal_var, (actual_e, actual_t)) = let mk_instantiation (formal_var, (actual_e, actual_t)) =
Prop.mk_ptsto tenv (Exp.Lvar formal_var) 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}) (Exp.Sizeof {typ= actual_t; nbytes= None; dynamic_length= None; subtype= Subtype.exact})
in in
let instantiated_formals = List.map ~f:mk_instantiation formals_actuals 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 = let last_call_ret_non_null =
List.exists List.exists
~f:(function ~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 Prover.check_disequal tenv prop exp Exp.zero
| _ -> | _ ->
false ) false )
@ -1025,7 +1029,7 @@ let mk_posts tenv prop callee_pname posts =
let returns_null prop = let returns_null prop =
List.exists List.exists
~f:(function ~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 Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero
| _ -> | _ ->
false ) false )
@ -1089,8 +1093,8 @@ let missing_sigma_need_adding_to_tenv tenv hpreds =
in in
let missing_hpred_need_adding_to_tenv hpred = let missing_hpred_need_adding_to_tenv hpred =
match hpred with 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 match Tenv.lookup tenv name with
| Some struc -> | Some struc ->
List.exists ~f:(field_is_missing struc) missing_fields 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 -> | Some callee_tenv ->
let add_field_in_hpred hpred = let add_field_in_hpred hpred =
match hpred with 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 match Tenv.lookup callee_tenv name with
| Some {fields} -> | Some {fields} ->
List.iter ~f:(fun field -> Tenv.add_field caller_tenv name field) 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 ) -> ( , missing_typ ) -> (
(* check if a missing_fld hpred is from a dyn language (ObjC) *) (* check if a missing_fld hpred is from a dyn language (ObjC) *)
let hpred_missing_objc_class = function let hpred_missing_objc_class = function
| Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) -> | Predicates.Hpointsto (_, Estruct (_, _), Exp.Sizeof {typ}) ->
Typ.is_objc_class typ Typ.is_objc_class typ
| _ -> | _ ->
false 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 remove_constant_string_class tenv prop =
let filter = function let filter = function
| Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) -> | Predicates.Hpointsto (Const (Cstr _ | Cclass _), _, _) ->
false false
| _ -> | _ ->
true 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 *) (** 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 prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t =
let is_footprint_atom_not_attribute a = 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 in
let pure = Prop.get_pure p in let pure = Prop.get_pure p in
let new_footprint_atoms = List.filter ~f:is_footprint_atom_not_attribute pure 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 else
(* add pure fact to footprint *) (* add pure fact to footprint *)
let filtered_pi_fp = 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 in
Prop.normalize tenv (Prop.set p ~pi_fp:filtered_pi_fp) 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 (** Check if the attribute change is a mismatch between a kind of allocation and a different kind of
deallocation *) 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 (** Check whether a sexp contains a dereference without null check, and return the line number and
path position *) 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 prop_incons =
let mk_incons prop = let mk_incons prop =
let p_abs = Abs.abstract pname tenv prop in let p_abs = Abs.abstract pname tenv prop in
let p_zero = Prop.set p_abs ~sub:Sil.sub_empty ~sigma:[] in let p_zero = Prop.set p_abs ~sub:Predicates.sub_empty ~sigma:[] in
Prop.normalize tenv (Prop.set p_zero ~pi:[Sil.Aneq (Exp.zero, Exp.zero)]) Prop.normalize tenv (Prop.set p_zero ~pi:[Predicates.Aneq (Exp.zero, Exp.zero)])
in in
Paths.PathSet.map mk_incons diverging_states Paths.PathSet.map mk_incons diverging_states
in in
@ -581,7 +581,7 @@ let extract_specs tenv pdesc pathset : Prop.normal BiabductionSummary.spec list
|> Ident.HashQueue.keys |> Ident.HashQueue.keys
in in
let sub_list = List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.knormal))) fav 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 in
let pre_post_visited_list = let pre_post_visited_list =
let pplist = Paths.PathSet.elements pathset in 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 create_seed_vars sigma =
let hpred_add_seed sigma = function let hpred_add_seed sigma = function
| Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) -> | Predicates.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 (Pvar.to_seed pv), se, typ) :: sigma
| _ -> | _ ->
sigma sigma
in in
@ -700,7 +700,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
| Java -> | Java ->
Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}
in 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 in
List.map ~f:do_formal new_formals List.map ~f:do_formal new_formals
in in
@ -723,7 +723,9 @@ let initial_prop tenv (curr_f : Procdesc.t) (prop : 'a Prop.t) ~add_formals : Pr
(* no new formals added *) (* no new formals added *)
in in
let prop1 = 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 in
let prop2 = prop_init_formals_seed tenv new_formals prop1 in let prop2 = prop_init_formals_seed tenv new_formals prop1 in
Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2) 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 = let sub_list =
List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.kfootprint))) vars List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.kfootprint))) vars
in 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 pre2 = Prop.prop_sub sub pre in
let pre3 = Prop.set pre2 ~pi_fp:(Prop.get_pure pre2) ~sigma_fp:pre2.Prop.sigma 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 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 *) (* Remove the constrain of the form this != null which is true for all Java virtual calls *)
let remove_this_not_null tenv prop = let remove_this_not_null tenv prop =
let collect_hpred (var_option, hpreds) = function 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 -> when Language.curr_language_is Java && Pvar.is_this pvar ->
(Some var, hpreds) (Some var, hpreds)
| hpred -> | hpred ->
(var_option, hpred :: hpreds) (var_option, hpred :: hpreds)
in in
let collect_atom var atoms = function 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 atoms
| a -> | a ->
a :: atoms a :: atoms
@ -1175,7 +1177,7 @@ let analyze_procedure_aux summary exe_env tenv : Summary.t =
let summary_compact = let summary_compact =
match summaryre.Summary.payloads.biabduction with match summaryre.Summary.payloads.biabduction with
| Some BiabductionSummary.({preposts} as biabduction) when Config.save_compact_summaries -> | 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 = let compact_preposts =
List.map ~f:(BiabductionSummary.NormSpec.compact sharing_env) preposts List.map ~f:(BiabductionSummary.NormSpec.compact sharing_env) preposts
in 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 malloc ~can_be_zero size_exp =
let exec ({pname; node_hash; location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem = 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 typ, stride, length0, dyn_length = get_malloc_info size_exp in
let length = Sem.eval integer_type_widths length0 mem 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 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 realloc src_exp size_exp =
let exec ({location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem = 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 typ, _, length0, dyn_length = get_malloc_info size_exp in
let length = Sem.eval integer_type_widths length0 mem 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 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 + one cannot do boolean-conjunction on symbolic heaps; and
+ the prover fails to see that 0!=o.f * o|-f->0 is inconsistent *) + 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 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_field field (f, e) = if Typ.Fieldname.equal field f then from_strexp e else None in
let get_strexp field = function let get_strexp field = function
| Sil.Estruct (fs, _inst) -> | Predicates.Estruct (fs, _inst) ->
List.find_map ~f:(get_field field) fs List.find_map ~f:(get_field field) fs
| _ -> | _ ->
None None
in in
let get_hpred obj field = function 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 get_strexp field se
| _ -> | _ ->
None 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 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 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 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) = let mk_load (e, id) =
Sil.Load Sil.Load
{id; e; root_typ= ToplUtils.any_type; typ= ToplUtils.any_type; loc= sourcefile_location ()} {id; e; root_typ= ToplUtils.any_type; typ= ToplUtils.any_type; loc= sourcefile_location ()}

Write Preview
Loading…
Cancel
Save