diff --git a/infer/src/IR/Sil.ml b/infer/src/IR/Sil.ml index 3dd94a7b3..62164981d 100644 --- a/infer/src/IR/Sil.ml +++ b/infer/src/IR/Sil.ml @@ -9,9 +9,8 @@ (** The Smallfoot Intermediate Language *) open! IStd -module Hashtbl = Caml.Hashtbl -module L = Logging module F = Format +module L = Logging (** {2 Programs and Types} *) @@ -85,175 +84,10 @@ let instr_is_auxiliary = function true -(** 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] - -let equal_atom = [%compare.equal: atom] - -let atom_has_local_addr a = - match a with - | Aeq (e0, e1) | Aneq (e0, e1) -> - Exp.has_local_addr e0 || Exp.has_local_addr e1 - | Apred _ | Anpred _ -> - false - - -(** kind of lseg or dllseg predicates *) -type lseg_kind = - | Lseg_NE (** nonempty (possibly circular) listseg *) - | Lseg_PE (** possibly empty (possibly circular) listseg *) -[@@deriving compare] - -let equal_lseg_kind = [%compare.equal: lseg_kind] - -(** The boolean is true when the pointer was dereferenced without testing for zero. *) -type zero_flag = bool option [@@deriving compare] - -(** True when the value was obtained by doing case analysis on null in a procedure call. *) -type null_case_flag = bool [@@deriving compare] - -(** 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] - -let equal_inst = [%compare.equal: inst] - -(** 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 - -let compare_strexp ?(inst = false) se1 se2 = - compare_strexp0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) se1 se2 - - -let equal_strexp ?(inst = false) se1 se2 = Int.equal (compare_strexp ~inst se1 se2) 0 - -(** 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 - -(** Comparison between heap predicates. Reverse natural order, and order first by anchor exp. *) -let compare_hpred ?(inst = false) hpred1 hpred2 = - compare_hpred0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) hpred1 hpred2 - - -let equal_hpred ?(inst = false) hpred1 hpred2 = Int.equal (compare_hpred ~inst hpred1 hpred2) 0 - -type hpara = inst hpara0 - -let compare_hpara = compare_hpara0 (fun _ _ -> 0) - -let equal_hpara = [%compare.equal: hpara] - -type hpara_dll = inst hpara_dll0 - -let compare_hpara_dll = compare_hpara_dll0 (fun _ _ -> 0) - -let equal_hpara_dll = [%compare.equal: hpara_dll] - -(** {2 Comparision and Inspection Functions} *) - -let is_objc_object = function Hpointsto (_, _, Sizeof {typ}) -> Typ.is_objc_class typ | _ -> false - -(** {2 Sets of heap predicates} *) -module HpredSet = Caml.Set.Make (struct - type t = hpred - - let compare = compare_hpred ~inst:false -end) - (** {2 Pretty Printing} *) let color_wrapper ~f = if Config.print_using_diff then Pp.color_wrapper ~f else f -let pp_seq_diff pp print_env fmt l = - if Config.print_using_diff then Pp.comma_seq_diff pp print_env fmt l - else Pp.comma_seq ~print_env pp fmt l - - -(** Pretty print an offset *) -let pp_offset pe f = function - | Off_fld (fld, _) -> - Typ.Fieldname.pp f fld - | Off_index exp -> - (Exp.pp_diff pe) f exp - - -(** Pretty print a list of offsets *) -let rec pp_offset_list pe f = function - | [] -> - () - | [off1; off2] -> - F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 - | off :: off_list -> - F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list - - -(** Dump a list of offsets *) -let d_offset_list (offl : offset list) = L.d_pp_with_pe pp_offset_list offl - let pp_exp_typ pe f (e, t) = F.fprintf f "%a:%a" (Exp.pp_diff pe) e (Typ.pp pe) t let location_of_instr_metadata = function @@ -372,1089 +206,3 @@ let add_with_block_parameters_flag instr = (** Dump an instruction. *) let d_instr (i : instr) = L.d_pp_with_pe ~color:Pp.Green (pp_instr ~print_types:true) i - -let pp_atom = - color_wrapper ~f:(fun pe f a -> - match a with - | Aeq (BinOp (op, e1, e2), Const (Cint i)) when IntLit.isone i -> - (Exp.pp_diff pe) f (Exp.BinOp (op, e1, e2)) - | Aeq (e1, e2) -> - F.fprintf f "%a = %a" (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 - | Aneq (e1, e2) -> - F.fprintf f "%a != %a" (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 - | Apred (a, es) -> - F.fprintf f "%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (Exp.pp_diff pe)) es - | Anpred (a, es) -> - F.fprintf f "!%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (Exp.pp_diff pe)) es ) - - -(** dump an atom *) -let d_atom (a : atom) = L.d_pp_with_pe pp_atom a - -let pp_lseg_kind f = function Lseg_NE -> F.pp_print_string f "ne" | Lseg_PE -> () - -(** Print a *-separated sequence. *) -let pp_star_seq pp f l = Pp.seq ~sep:" * " pp f l - -(** 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 - - (** create an empty predicate environment *) - - val empty_env : unit -> env - - (** return true if the environment is empty *) - - val is_empty : env -> bool - - (** return the id of the hpara *) - - val get_hpara_id : env -> hpara -> int - - (** return the id of the hpara_dll *) - - val get_hpara_dll_id : env -> hpara_dll -> int - - (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, passing the unique - id to the functions. The iterator can only be used once. *) - - val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit - - (** Process one hpred, updating the predicate environment *) - - val process_hpred : env -> hpred -> unit -end = struct - (** hash tables for hpara *) - module HparaHash = Hashtbl.Make (struct - type t = hpara - - let equal = equal_hpara - - let hash = Hashtbl.hash - end) - - (** hash tables for hpara_dll *) - module HparaDllHash = Hashtbl.Make (struct - type t = hpara_dll - - let equal = equal_hpara_dll - - let hash = Hashtbl.hash - end) - - (** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, - also keep a list of hparas still to be emitted. Same for hpara_dll. *) - type env = - { mutable num: int - ; hash: (int * bool) HparaHash.t - ; mutable todo: hpara list - ; hash_dll: (int * bool) HparaDllHash.t - ; mutable todo_dll: hpara_dll list } - - (** return true if the environment is empty *) - let is_empty env = Int.equal env.num 0 - - (** return the id of the hpara *) - let get_hpara_id env hpara = fst (HparaHash.find env.hash hpara) - - (** return the id of the hpara_dll *) - let get_hpara_dll_id env hpara_dll = fst (HparaDllHash.find env.hash_dll hpara_dll) - - (** Process one hpara, updating the map from hparas to numbers, and the todo list *) - let process_hpara env hpara = - if not (HparaHash.mem env.hash hpara) then ( - HparaHash.add env.hash hpara (env.num, false) ; - env.num <- env.num + 1 ; - env.todo <- env.todo @ [hpara] ) - - - (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) - let process_hpara_dll env hpara_dll = - if not (HparaDllHash.mem env.hash_dll hpara_dll) then ( - HparaDllHash.add env.hash_dll hpara_dll (env.num, false) ; - env.num <- env.num + 1 ; - env.todo_dll <- env.todo_dll @ [hpara_dll] ) - - - (** Process a sexp, updating env *) - let rec process_sexp env = function - | Eexp _ -> - () - | Earray (_, esel, _) -> - List.iter ~f:(fun (_, se) -> process_sexp env se) esel - | Estruct (fsel, _) -> - List.iter ~f:(fun (_, se) -> process_sexp env se) fsel - - - (** Process one hpred, updating env *) - let rec process_hpred env = function - | Hpointsto (_, se, _) -> - process_sexp env se - | Hlseg (_, hpara, _, _, _) -> - List.iter ~f:(process_hpred env) hpara.body ; - process_hpara env hpara - | Hdllseg (_, hpara_dll, _, _, _, _, _) -> - List.iter ~f:(process_hpred env) hpara_dll.body_dll ; - process_hpara_dll env hpara_dll - - - (** create an empty predicate environment *) - let empty_env () = - {num= 0; hash= HparaHash.create 3; todo= []; hash_dll= HparaDllHash.create 3; todo_dll= []} - - - (** iterator for predicates which are marked as todo in env, unless they have been visited - already. This can in turn extend the todo list for the nested predicates, which are then - visited as well. Can be applied only once, as it destroys the todo list *) - let iter (env : env) f f_dll = - while env.todo <> [] || env.todo_dll <> [] do - match env.todo with - | hpara :: todo' -> - env.todo <- todo' ; - let n, emitted = HparaHash.find env.hash hpara in - if not emitted then f n hpara - | [] -> ( - match env.todo_dll with - | hpara_dll :: todo_dll' -> - env.todo_dll <- todo_dll' ; - let n, emitted = HparaDllHash.find env.hash_dll hpara_dll in - if not emitted then f_dll n hpara_dll - | [] -> - () ) - done -end - -let pp_texp_simple pe = - match pe.Pp.opt with SIM_DEFAULT -> Exp.pp_texp pe | SIM_WITH_TYP -> Exp.pp_texp_full pe - - -let inst_actual_precondition = Iactual_precondition - -(** for formal parameters *) -let inst_formal = Iformal (None, false) - -(** for initial values *) -let inst_initial = Iinitial - -let inst_lookup = Ilookup - -let inst_none = Inone - -let inst_nullify = Inullify - -let inst_rearrange b loc pos = Irearrange (Some b, false, loc.Location.line, pos) - -let inst_update loc pos = Iupdate (None, false, loc.Location.line, pos) - -(** update the location of the instrumentation *) -let inst_new_loc loc inst = - match inst with - | Iabstraction -> - inst - | Iactual_precondition -> - inst - | Ialloc -> - inst - | Iformal _ -> - inst - | Iinitial -> - inst - | Ilookup -> - inst - | Inone -> - inst - | Inullify -> - inst - | Irearrange (zf, ncf, _, pos) -> - Irearrange (zf, ncf, loc.Location.line, pos) - | Itaint -> - inst - | Iupdate (zf, ncf, _, pos) -> - Iupdate (zf, ncf, loc.Location.line, pos) - | Ireturn_from_call _ -> - Ireturn_from_call loc.Location.line - - -(** pretty-print an inst *) -let pp_inst f inst = - let pp_zero_flag f = function Some true -> F.pp_print_string f "(z)" | _ -> () in - let pp_null_case_flag f ncf = if ncf then F.pp_print_string f "(ncf)" in - match inst with - | Iabstraction -> - F.pp_print_string f "abstraction" - | Iactual_precondition -> - F.pp_print_string f "actual_precondition" - | Ialloc -> - F.pp_print_string f "alloc" - | Iformal (zf, ncf) -> - F.fprintf f "formal%a%a" pp_zero_flag zf pp_null_case_flag ncf - | Iinitial -> - F.pp_print_string f "initial" - | Ilookup -> - F.pp_print_string f "lookup" - | Inone -> - F.pp_print_string f "none" - | Inullify -> - F.pp_print_string f "nullify" - | Irearrange (zf, ncf, n, _) -> - F.fprintf f "rearrange:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n - | Itaint -> - F.pp_print_string f "taint" - | Iupdate (zf, ncf, n, _) -> - F.fprintf f "update:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n - | Ireturn_from_call n -> - F.fprintf f "return_from_call: %d" n - - -exception JoinFail - -(** join of instrumentations, can raise JoinFail *) -let inst_partial_join inst1 inst2 = - let fail () = - L.d_printfln "inst_partial_join failed on %a %a" pp_inst inst1 pp_inst inst2 ; - raise JoinFail - in - if equal_inst inst1 inst2 then inst1 - else - match (inst1, inst2) with - | _, Inone | Inone, _ -> - inst_none - | _, Ialloc | Ialloc, _ -> - fail () - | _, Iinitial | Iinitial, _ -> - fail () - | _, Iupdate _ | Iupdate _, _ -> - fail () - | _ -> - inst_none - - -(** meet of instrumentations *) -let inst_partial_meet inst1 inst2 = if equal_inst inst1 inst2 then inst1 else inst_none - -(** Return the zero flag of the inst *) -let inst_zero_flag = function - | Iabstraction -> - None - | Iactual_precondition -> - None - | Ialloc -> - None - | Iformal (zf, _) -> - zf - | Iinitial -> - None - | Ilookup -> - None - | Inone -> - None - | Inullify -> - None - | Irearrange (zf, _, _, _) -> - zf - | Itaint -> - None - | Iupdate (zf, _, _, _) -> - zf - | Ireturn_from_call _ -> - None - - -(** Set the null case flag of the inst. *) -let inst_set_null_case_flag = function - | Iformal (zf, false) -> - Iformal (zf, true) - | Irearrange (zf, false, n, pos) -> - Irearrange (zf, true, n, pos) - | Iupdate (zf, false, n, pos) -> - Iupdate (zf, true, n, pos) - | inst -> - inst - - -(** Update [inst_old] to [inst_new] preserving the zero flag *) -let update_inst inst_old inst_new = - let combine_zero_flags z1 z2 = - match (z1, z2) with - | Some b1, Some b2 -> - Some (b1 || b2) - | Some b, None -> - Some b - | None, Some b -> - Some b - | None, None -> - None - in - match inst_new with - | Iabstraction -> - inst_new - | Iactual_precondition -> - inst_new - | Ialloc -> - inst_new - | Iformal (zf, ncf) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Iformal (zf', ncf) - | Iinitial -> - inst_new - | Ilookup -> - inst_new - | Inone -> - inst_new - | Inullify -> - inst_new - | Irearrange (zf, ncf, n, pos) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Irearrange (zf', ncf, n, pos) - | Itaint -> - inst_new - | Iupdate (zf, ncf, n, pos) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Iupdate (zf', ncf, n, pos) - | Ireturn_from_call _ -> - inst_new - - -(** describe an instrumentation with a string *) -let pp_inst_if_trace pe f inst = - if Config.trace_error then - if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Pp.html_with_color Orange pp_inst f inst - else F.fprintf f "%s%a%s" (Binop.str pe Lt) pp_inst inst (Binop.str pe Gt) - - -(** pretty print a strexp with an optional predicate env *) -let rec pp_sexp_env pe0 envo f se = - color_wrapper pe0 f se ~f:(fun pe f se -> - match se with - | Eexp (e, inst) -> - F.fprintf f "%a%a" (Exp.pp_diff pe) e (pp_inst_if_trace pe) inst - | Estruct (fel, inst) -> - let pp_diff f (n, se) = F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se in - F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst - | Earray (len, nel, inst) -> - let pp_diff f (i, se) = F.fprintf f "%a:%a" (Exp.pp_diff pe) i (pp_sexp_env pe envo) se in - F.fprintf f "[%a|%a]%a" (Exp.pp_diff pe) len (pp_seq_diff pp_diff pe) nel - (pp_inst_if_trace pe) inst ) - - -(** Pretty print an hpred with an optional predicate env *) -let rec pp_hpred_env pe0 envo f hpred = - color_wrapper pe0 f hpred ~f:(fun pe f hpred -> - match hpred with - | Hpointsto (e, se, te) -> - let pe' = - match (e, se) with - | Lvar pvar, Eexp (Var _, _) when not (Pvar.is_global pvar) -> - Pp.{pe with obj_sub= None} (* dont use obj sub on the var defining it *) - | _ -> - pe - in - F.fprintf f "%a|->%a:%a" (Exp.pp_diff pe') e (pp_sexp_env pe' envo) se - (pp_texp_simple pe') te - | Hlseg (k, hpara, e1, e2, elist) -> - F.fprintf f "lseg%a(%a,%a,[%a],%a)" pp_lseg_kind k (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 - (Pp.comma_seq (Exp.pp_diff pe)) - elist (pp_hpara_env pe envo) hpara - | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> - F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k (Exp.pp_diff pe) iF - (Exp.pp_diff pe) oB (Exp.pp_diff pe) oF (Exp.pp_diff pe) iB - (Pp.comma_seq (Exp.pp_diff pe)) - elist (pp_hpara_dll_env pe envo) hpara_dll ) - - -and pp_hpara_env pe envo f hpara = - match envo with - | None -> - let r, n, svars, evars, b = (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body) in - F.fprintf f "lam [%a,%a,%a]. exists [%a]. %a" Ident.pp r Ident.pp n (Pp.seq Ident.pp) svars - (Pp.seq Ident.pp) evars - (pp_star_seq (pp_hpred_env pe envo)) - b - | Some env -> - F.fprintf f "P%d" (Predicates.get_hpara_id env hpara) - - -and pp_hpara_dll_env pe envo f hpara_dll = - match envo with - | None -> - let iF, oB, oF, svars, evars, b = - ( hpara_dll.cell - , hpara_dll.blink - , hpara_dll.flink - , hpara_dll.svars_dll - , hpara_dll.evars_dll - , hpara_dll.body_dll ) - in - F.fprintf f "lam [%a,%a,%a,%a]. exists [%a]. %a" Ident.pp iF Ident.pp oB Ident.pp oF - (Pp.seq Ident.pp) svars (Pp.seq Ident.pp) evars - (pp_star_seq (pp_hpred_env pe envo)) - b - | Some env -> - F.fprintf f "P%d" (Predicates.get_hpara_dll_id env hpara_dll) - - -(** pretty print a strexp *) -let pp_sexp pe f = pp_sexp_env pe None f - -(** pretty print a hpara *) -let pp_hpara pe f = pp_hpara_env pe None f - -(** pretty print a hpara_dll *) -let pp_hpara_dll pe f = pp_hpara_dll_env pe None f - -(** pretty print a hpred *) -let pp_hpred pe f = pp_hpred_env pe None f - -(** dump a strexp. *) -let d_sexp (se : strexp) = L.d_pp_with_pe pp_sexp se - -(** dump a hpred. *) -let d_hpred (hpred : hpred) = L.d_pp_with_pe pp_hpred hpred - -(** {2 Functions for traversing SIL data types} *) - -let rec strexp_expmap (f : Exp.t * inst option -> Exp.t * inst option) = - let fe e = fst (f (e, None)) in - let fei (e, inst) = - match f (e, Some inst) with e', None -> (e', inst) | e', Some inst' -> (e', inst') - in - function - | Eexp (e, inst) -> - let e', inst' = fei (e, inst) in - Eexp (e', inst') - | Estruct (fld_se_list, inst) -> - let f_fld_se (fld, se) = (fld, strexp_expmap f se) in - Estruct (List.map ~f:f_fld_se fld_se_list, inst) - | Earray (len, idx_se_list, inst) -> - let len' = fe len in - let f_idx_se (idx, se) = - let idx' = fe idx in - (idx', strexp_expmap f se) - in - Earray (len', List.map ~f:f_idx_se idx_se_list, inst) - - -let hpred_expmap (f : Exp.t * inst option -> Exp.t * inst option) = - let fe e = fst (f (e, None)) in - function - | Hpointsto (e, se, te) -> - let e' = fe e in - let se' = strexp_expmap f se in - let te' = fe te in - Hpointsto (e', se', te') - | Hlseg (k, hpara, root, next, shared) -> - let root' = fe root in - let next' = fe next in - let shared' = List.map ~f:fe shared in - Hlseg (k, hpara, root', next', shared') - | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> - let iF' = fe iF in - let oB' = fe oB in - let oF' = fe oF in - let iB' = fe iB in - let shared' = List.map ~f:fe shared in - Hdllseg (k, hpara, iF', oB', oF', iB', shared') - - -let rec strexp_instmap (f : inst -> inst) strexp = - match strexp with - | Eexp (e, inst) -> - Eexp (e, f inst) - | Estruct (fld_se_list, inst) -> - let f_fld_se (fld, se) = (fld, strexp_instmap f se) in - Estruct (List.map ~f:f_fld_se fld_se_list, f inst) - | Earray (len, idx_se_list, inst) -> - let f_idx_se (idx, se) = (idx, strexp_instmap f se) in - Earray (len, List.map ~f:f_idx_se idx_se_list, f inst) - - -let rec hpara_instmap (f : inst -> inst) hpara = - {hpara with body= List.map ~f:(hpred_instmap f) hpara.body} - - -and hpara_dll_instmap (f : inst -> inst) hpara_dll = - {hpara_dll with body_dll= List.map ~f:(hpred_instmap f) hpara_dll.body_dll} - - -and hpred_instmap (fn : inst -> inst) (hpred : hpred) : hpred = - match hpred with - | Hpointsto (e, se, te) -> - let se' = strexp_instmap fn se in - Hpointsto (e, se', te) - | Hlseg (k, hpara, e, f, el) -> - Hlseg (k, hpara_instmap fn hpara, e, f, el) - | Hdllseg (k, hpar_dll, e, f, g, h, el) -> - Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) - - -let hpred_list_expmap (f : Exp.t * inst option -> Exp.t * inst option) (hlist : hpred list) = - List.map ~f:(hpred_expmap f) hlist - - -let atom_expmap (f : Exp.t -> Exp.t) = function - | Aeq (e1, e2) -> - Aeq (f e1, f e2) - | Aneq (e1, e2) -> - Aneq (f e1, f e2) - | Apred (a, es) -> - Apred (a, List.map ~f es) - | Anpred (a, es) -> - Anpred (a, List.map ~f es) - - -(** {2 Function for computing lexps in sigma} *) - -let hpred_get_lexp acc = function - | Hpointsto (e, _, _) -> - e :: acc - | Hlseg (_, _, e, _, _) -> - e :: acc - | Hdllseg (_, _, e1, _, _, e2, _) -> - e1 :: e2 :: acc - - -let hpred_list_get_lexps (filter : Exp.t -> bool) (hlist : hpred list) : Exp.t list = - let lexps = List.fold ~f:hpred_get_lexp ~init:[] hlist in - List.filter ~f:filter lexps - - -let hpred_entries hpred = hpred_get_lexp [] hpred - -(** {2 Functions for computing free non-program variables} *) - -let atom_gen_free_vars = - let open Sequence.Generator in - function - | Aeq (e1, e2) | Aneq (e1, e2) -> - Exp.gen_free_vars e1 >>= fun () -> Exp.gen_free_vars e2 - | Apred (_, es) | Anpred (_, es) -> - ISequence.gen_sequence_list es ~f:Exp.gen_free_vars - - -let atom_free_vars a = Sequence.Generator.run (atom_gen_free_vars a) - -let rec strexp_gen_free_vars = - let open Sequence.Generator in - function - | Eexp (e, _) -> - Exp.gen_free_vars e - | Estruct (fld_se_list, _) -> - ISequence.gen_sequence_list fld_se_list ~f:(fun (_, se) -> strexp_gen_free_vars se) - | Earray (len, idx_se_list, _) -> - Exp.gen_free_vars len - >>= fun () -> - ISequence.gen_sequence_list idx_se_list ~f:(fun (e, se) -> - Exp.gen_free_vars e >>= fun () -> strexp_gen_free_vars se ) - - -let hpred_gen_free_vars = - let open Sequence.Generator in - function - | Hpointsto (base, sexp, te) -> - Exp.gen_free_vars base - >>= fun () -> strexp_gen_free_vars sexp >>= fun () -> Exp.gen_free_vars te - | Hlseg (_, _, e1, e2, elist) -> - Exp.gen_free_vars e1 - >>= fun () -> - Exp.gen_free_vars e2 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars - | Hdllseg (_, _, e1, e2, e3, e4, elist) -> - Exp.gen_free_vars e1 - >>= fun () -> - Exp.gen_free_vars e2 - >>= fun () -> - Exp.gen_free_vars e3 - >>= fun () -> - Exp.gen_free_vars e4 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars - - -let hpred_free_vars h = Sequence.Generator.run (hpred_gen_free_vars h) - -(** {2 Functions for computing all free or bound non-program variables} *) - -(** Variables in hpara, excluding bound vars in the body *) -let hpara_shallow_gen_free_vars {body; root; next; svars; evars} = - let open Sequence.Generator in - ISequence.gen_sequence_list ~f:hpred_gen_free_vars body - >>= fun () -> - yield root - >>= fun () -> - yield next - >>= fun () -> - ISequence.gen_sequence_list ~f:yield svars - >>= fun () -> ISequence.gen_sequence_list ~f:yield evars - - -let hpara_shallow_free_vars h = Sequence.Generator.run (hpara_shallow_gen_free_vars h) - -(** Variables in hpara_dll, excluding bound vars in the body *) -let hpara_dll_shallow_gen_free_vars {body_dll; cell; blink; flink; svars_dll; evars_dll} = - let open Sequence.Generator in - ISequence.gen_sequence_list ~f:hpred_gen_free_vars body_dll - >>= fun () -> - yield cell - >>= fun () -> - yield blink - >>= fun () -> - yield flink - >>= fun () -> - ISequence.gen_sequence_list ~f:yield svars_dll - >>= fun () -> ISequence.gen_sequence_list ~f:yield evars_dll - - -let hpara_dll_shallow_free_vars h = Sequence.Generator.run (hpara_dll_shallow_gen_free_vars h) - -(** {2 Functions for Substitution} *) - -(** substitution *) -type ident_exp = Ident.t * Exp.t [@@deriving compare] - -let compare_ident_exp_ids (id1, _) (id2, _) = Ident.compare id1 id2 - -type subst = ident_exp list [@@deriving compare] - -type subst_fun = Ident.t -> Exp.t - -let equal_subst = [%compare.equal: subst] - -let sub_no_duplicated_ids sub = not (List.contains_dup ~compare:compare_ident_exp_ids sub) - -(** Create a substitution from a list of pairs. For all (id1, e1), (id2, e2) in the input list, if - id1 = id2, then e1 = e2. *) -let subst_of_list sub = - let sub' = List.dedup_and_sort ~compare:compare_ident_exp sub in - assert (sub_no_duplicated_ids sub') ; - sub' - - -(** like subst_of_list, but allow duplicate ids and only keep the first occurrence *) -let subst_of_list_duplicates sub = List.dedup_and_sort ~compare:compare_ident_exp_ids sub - -(** Convert a subst to a list of pairs. *) -let sub_to_list sub = sub - -(** The empty substitution. *) -let sub_empty = subst_of_list [] - -let is_sub_empty = List.is_empty - -(** Join two substitutions into one. For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) -let sub_join sub1 sub2 = - let sub = IList.merge_dedup ~compare:compare_ident_exp sub1 sub2 in - assert (sub_no_duplicated_ids sub) ; - sub - - -(** 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. *) -let sub_symmetric_difference sub1_in sub2_in = - let rec diff sub_common sub1_only sub2_only sub1 sub2 = - match (sub1, sub2) with - | [], _ | _, [] -> - let sub1_only' = List.rev_append sub1_only sub1 in - let sub2_only' = List.rev_append sub2_only sub2 in - let sub_common = List.rev sub_common in - (sub_common, sub1_only', sub2_only') - | id_e1 :: sub1', id_e2 :: sub2' -> - let n = compare_ident_exp id_e1 id_e2 in - if Int.equal n 0 then diff (id_e1 :: sub_common) sub1_only sub2_only sub1' sub2' - else if n < 0 then diff sub_common (id_e1 :: sub1_only) sub2_only sub1' sub2 - else diff sub_common sub1_only (id_e2 :: sub2_only) sub1 sub2' - in - diff [] [] [] sub1_in sub2_in - - -(** [sub_find filter sub] returns the expression associated to the first identifier that satisfies - [filter]. Raise [Not_found] if there isn't one. *) -let sub_find filter (sub : subst) = snd (List.find_exn ~f:(fun (i, _) -> filter i) sub) - -(** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *) -let sub_filter filter (sub : subst) = List.filter ~f:(fun (i, _) -> filter i) sub - -(** [sub_filter_pair filter sub] restricts the domain of [sub] to the identifiers satisfying - [filter(id, sub(id))]. *) -let sub_filter_pair = List.filter - -(** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy - [filter]. *) -let sub_range_partition filter (sub : subst) = List.partition_tf ~f:(fun (_, e) -> filter e) sub - -(** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers - satisfy [filter]. *) -let sub_domain_partition filter (sub : subst) = List.partition_tf ~f:(fun (i, _) -> filter i) sub - -(** Return the list of identifiers in the domain of the substitution. *) -let sub_domain sub = List.map ~f:fst sub - -(** Return the list of expressions in the range of the substitution. *) -let sub_range sub = List.map ~f:snd sub - -(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *) -let sub_range_map f sub = subst_of_list (List.map ~f:(fun (i, e) -> (i, f e)) sub) - -(** [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]. *) -let sub_map f g sub = subst_of_list (List.map ~f:(fun (i, e) -> (f i, g e)) sub) - -let mem_sub id sub = List.exists ~f:(fun (id1, _) -> Ident.equal id id1) sub - -(** Extend substitution and return [None] if not possible. *) -let extend_sub sub id exp : subst option = - let compare (id1, _) (id2, _) = Ident.compare id1 id2 in - if mem_sub id sub then None else Some (List.merge ~compare sub [(id, exp)]) - - -(** Free auxilary variables in the domain and range of the substitution. *) -let subst_gen_free_vars sub = - let open Sequence.Generator in - ISequence.gen_sequence_list sub ~f:(fun (id, e) -> yield id >>= fun () -> Exp.gen_free_vars e) - - -let subst_free_vars sub = Sequence.Generator.run (subst_gen_free_vars sub) - -let rec exp_sub_ids (f : subst_fun) exp = - match (exp : Exp.t) with - | Var id -> ( - match f id with - | Exp.Var id' when Ident.equal id id' -> - exp (* it will preserve physical equality when needed *) - | exp' -> - exp' ) - | Lvar _ -> - exp - | Exn e -> - let e' = exp_sub_ids f e in - if phys_equal e' e then exp else Exp.Exn e' - | Closure c -> - let captured_vars = - IList.map_changed ~equal:[%compare.equal: Exp.t * Pvar.t * Typ.t] - ~f:(fun ((e, pvar, typ) as captured) -> - let e' = exp_sub_ids f e in - if phys_equal e' e then captured else (e', pvar, typ) ) - c.captured_vars - in - if phys_equal captured_vars c.captured_vars then exp else Exp.Closure {c with captured_vars} - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) -> - exp - | Cast (t, e) -> - let e' = exp_sub_ids f e in - if phys_equal e' e then exp else Exp.Cast (t, e') - | UnOp (op, e, typ_opt) -> - let e' = exp_sub_ids f e in - if phys_equal e' e then exp else Exp.UnOp (op, e', typ_opt) - | BinOp (op, e1, e2) -> - let e1' = exp_sub_ids f e1 in - let e2' = exp_sub_ids f e2 in - if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.BinOp (op, e1', e2') - | Lfield (e, fld, typ) -> - let e' = exp_sub_ids f e in - if phys_equal e' e then exp else Exp.Lfield (e', fld, typ) - | Lindex (e1, e2) -> - let e1' = exp_sub_ids f e1 in - let e2' = exp_sub_ids f e2 in - if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.Lindex (e1', e2') - | Sizeof ({dynamic_length= Some l} as sizeof_data) -> - let l' = exp_sub_ids f l in - if phys_equal l' l then exp else Exp.Sizeof {sizeof_data with dynamic_length= Some l'} - | Sizeof {dynamic_length= None} -> - exp - - -let apply_sub subst : subst_fun = - fun id -> match List.Assoc.find subst ~equal:Ident.equal id with Some x -> x | None -> Exp.Var id - - -let exp_sub (subst : subst) e = exp_sub_ids (apply_sub subst) e - -(** apply [f] to id's in [instr]. if [sub_id_binders] is false, [f] is only applied to bound id's *) -let instr_sub_ids ~sub_id_binders f instr = - let sub_id id = - match exp_sub_ids f (Var id) with Var id' when not (Ident.equal id id') -> id' | _ -> id - in - match instr with - | Load {id; e= rhs_exp; root_typ; typ; loc} -> - let id' = if sub_id_binders then sub_id id else id in - let rhs_exp' = exp_sub_ids f rhs_exp in - if phys_equal id' id && phys_equal rhs_exp' rhs_exp then instr - else Load {id= id'; e= rhs_exp'; root_typ; typ; loc} - | Store {e1= lhs_exp; root_typ; typ; e2= rhs_exp; loc} -> - let lhs_exp' = exp_sub_ids f lhs_exp in - let rhs_exp' = exp_sub_ids f rhs_exp in - if phys_equal lhs_exp' lhs_exp && phys_equal rhs_exp' rhs_exp then instr - else Store {e1= lhs_exp'; root_typ; typ; e2= rhs_exp'; loc} - | Call (((id, typ) as ret_id_typ), fun_exp, actuals, call_flags, loc) -> - let ret_id' = - if sub_id_binders then - let id' = sub_id id in - if Ident.equal id id' then ret_id_typ else (id', typ) - else ret_id_typ - in - let fun_exp' = exp_sub_ids f fun_exp in - let actuals' = - IList.map_changed ~equal:[%compare.equal: Exp.t * Typ.t] - ~f:(fun ((actual, typ) as actual_pair) -> - let actual' = exp_sub_ids f actual in - if phys_equal actual' actual then actual_pair else (actual', typ) ) - actuals - in - if phys_equal ret_id' ret_id_typ && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals - then instr - else Call (ret_id', fun_exp', actuals', call_flags, loc) - | Prune (exp, loc, true_branch, if_kind) -> - let exp' = exp_sub_ids f exp in - if phys_equal exp' exp then instr else Prune (exp', loc, true_branch, if_kind) - | Metadata (ExitScope (vars, loc)) -> - let sub_var var = - match var with - | Var.ProgramVar _ -> - var - | Var.LogicalVar ident -> - let ident' = sub_id ident in - if phys_equal ident ident' then var else Var.of_id ident' - in - let vars' = IList.map_changed ~equal:phys_equal ~f:sub_var vars in - if phys_equal vars vars' then instr else Metadata (ExitScope (vars', loc)) - | Metadata (Abstract _ | Nullify _ | Skip | VariableLifetimeBegins _) -> - instr - - -(** apply [subst] to all id's in [instr], including binder id's *) -let instr_sub (subst : subst) instr = instr_sub_ids ~sub_id_binders:true (apply_sub subst) instr - -let atom_sub subst = atom_expmap (exp_sub subst) - -let hpred_sub subst = - let f (e, inst_opt) = (exp_sub subst e, inst_opt) in - hpred_expmap f - - -(** {2 Functions for replacing occurrences of expressions.} *) - -(** The first parameter should define a partial function. No parts of hpara are replaced by these - functions. *) -let rec exp_replace_exp epairs e = - (* First we check if there is an exact match *) - match List.find ~f:(fun (e1, _) -> Exp.equal e e1) epairs with - | Some (_, e2) -> - e2 - | None -> ( - (* If e is a compound expression, we need to check for its subexpressions as well *) - match e with - | Exp.UnOp (op, e0, ty) -> - let e0' = exp_replace_exp epairs e0 in - if phys_equal e0 e0' then e else Exp.UnOp (op, e0', ty) - | Exp.BinOp (op, lhs, rhs) -> - let lhs' = exp_replace_exp epairs lhs in - let rhs' = exp_replace_exp epairs rhs in - if phys_equal lhs lhs' && phys_equal rhs rhs' then e else Exp.BinOp (op, lhs', rhs') - | Exp.Cast (ty, e0) -> - let e0' = exp_replace_exp epairs e0 in - if phys_equal e0 e0' then e else Exp.Cast (ty, e0') - | Exp.Lfield (e0, fname, ty) -> - let e0' = exp_replace_exp epairs e0 in - if phys_equal e0 e0' then e else Exp.Lfield (e0', fname, ty) - | Exp.Lindex (base, index) -> - let base' = exp_replace_exp epairs base in - let index' = exp_replace_exp epairs index in - if phys_equal base base' && phys_equal index index' then e else Exp.Lindex (base', index') - | _ -> - e ) - - -let atom_replace_exp epairs atom = atom_expmap (fun e -> exp_replace_exp epairs e) atom - -let rec strexp_replace_exp epairs = function - | Eexp (e, inst) -> - Eexp (exp_replace_exp epairs e, inst) - | Estruct (fsel, inst) -> - let f (fld, se) = (fld, strexp_replace_exp epairs se) in - Estruct (List.map ~f fsel, inst) - | Earray (len, isel, inst) -> - let len' = exp_replace_exp epairs len in - let f (idx, se) = - let idx' = exp_replace_exp epairs idx in - (idx', strexp_replace_exp epairs se) - in - Earray (len', List.map ~f isel, inst) - - -let hpred_replace_exp epairs = function - | Hpointsto (root, se, te) -> - let root_repl = exp_replace_exp epairs root in - let strexp_repl = strexp_replace_exp epairs se in - let te_repl = exp_replace_exp epairs te in - Hpointsto (root_repl, strexp_repl, te_repl) - | Hlseg (k, para, root, next, shared) -> - let root_repl = exp_replace_exp epairs root in - let next_repl = exp_replace_exp epairs next in - let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in - Hlseg (k, para, root_repl, next_repl, shared_repl) - | Hdllseg (k, para, e1, e2, e3, e4, shared) -> - let e1' = exp_replace_exp epairs e1 in - let e2' = exp_replace_exp epairs e2 in - let e3' = exp_replace_exp epairs e3 in - let e4' = exp_replace_exp epairs e4 in - let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in - Hdllseg (k, para, e1', e2', e3', e4', shared_repl) - - -(** {2 Compaction} *) -module HpredInstHash = Hashtbl.Make (struct - type t = hpred - - let equal = equal_hpred ~inst:true - - let hash = Hashtbl.hash -end) - -type sharing_env = {exph: Exp.t Exp.Hash.t; hpredh: hpred HpredInstHash.t} - -(** Create a sharing env to store canonical representations *) -let create_sharing_env () = {exph= Exp.Hash.create 3; hpredh= HpredInstHash.create 3} - -(** Return a canonical representation of the exp *) -let exp_compact sh e = - try Exp.Hash.find sh.exph e with Caml.Not_found -> Exp.Hash.add sh.exph e e ; e - - -let rec sexp_compact sh se = - match se with - | Eexp (e, inst) -> - Eexp (exp_compact sh e, inst) - | Estruct (fsel, inst) -> - Estruct (List.map ~f:(fun (f, se) -> (f, sexp_compact sh se)) fsel, inst) - | Earray _ -> - se - - -(** Return a compact representation of the hpred *) -let hpred_compact_ sh hpred = - match hpred with - | Hpointsto (e1, se, e2) -> - let e1' = exp_compact sh e1 in - let e2' = exp_compact sh e2 in - let se' = sexp_compact sh se in - Hpointsto (e1', se', e2') - | Hlseg _ -> - hpred - | Hdllseg _ -> - hpred - - -let hpred_compact sh hpred = - try HpredInstHash.find sh.hpredh hpred - with Caml.Not_found -> - let hpred' = hpred_compact_ sh hpred in - HpredInstHash.add sh.hpredh hpred' hpred' ; - hpred' - - -(** {2 Functions for constructing or destructing entities in this module} *) - -(** Compute the offset list of an expression *) -let exp_get_offsets exp = - let rec f offlist_past e = - match (e : Exp.t) with - | Var _ | Const _ | UnOp _ | BinOp _ | Exn _ | Closure _ | Lvar _ | Sizeof {dynamic_length= None} - -> - offlist_past - | Sizeof {dynamic_length= Some l} -> - f offlist_past l - | Cast (_, sub_exp) -> - f offlist_past sub_exp - | Lfield (sub_exp, fldname, typ) -> - f (Off_fld (fldname, typ) :: offlist_past) sub_exp - | Lindex (sub_exp, e) -> - f (Off_index e :: offlist_past) sub_exp - in - f [] exp - - -let exp_add_offsets exp offsets = - let rec f acc = function - | [] -> - acc - | Off_fld (fld, typ) :: offs' -> - f (Exp.Lfield (acc, fld, typ)) offs' - | Off_index e :: offs' -> - f (Exp.Lindex (acc, e)) offs' - in - f exp offsets - - -(** Convert all the lseg's in sigma to nonempty lsegs. *) -let sigma_to_sigma_ne sigma : (atom list * hpred list) list = - if Config.nelseg then - let f eqs_sigma_list hpred = - match hpred with - | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) -> - let g (eqs, sigma) = (eqs, hpred :: sigma) in - List.map ~f:g eqs_sigma_list - | Hlseg (Lseg_PE, para, e1, e2, el) -> - let g (eqs, sigma) = - [(Aeq (e1, e2) :: eqs, sigma); (eqs, Hlseg (Lseg_NE, para, e1, e2, el) :: sigma)] - in - List.concat_map ~f:g eqs_sigma_list - | Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, el) -> - let g (eqs, sigma) = - [ (Aeq (e1, e3) :: Aeq (e2, e4) :: eqs, sigma) - ; (eqs, Hdllseg (Lseg_NE, para_dll, e1, e2, e3, e4, el) :: sigma) ] - in - List.concat_map ~f:g eqs_sigma_list - in - List.fold ~f ~init:[([], [])] sigma - else [([], sigma)] - - -(** [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'].*) -let hpara_instantiate para e1 e2 elist = - let subst_for_svars = - let g id e = (id, e) in - try List.map2_exn ~f:g para.svars elist with Invalid_argument _ -> assert false - in - let ids_evars = - let g _ = Ident.create_fresh Ident.kprimed in - List.map ~f:g para.evars - in - let subst_for_evars = - let g id id' = (id, Exp.Var id') in - try List.map2_exn ~f:g para.evars ids_evars with Invalid_argument _ -> assert false - in - let subst = - subst_of_list (((para.root, e1) :: (para.next, e2) :: subst_for_svars) @ subst_for_evars) - in - (ids_evars, List.map ~f:(hpred_sub subst) para.body) - - -(** [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'].*) -let hpara_dll_instantiate (para : hpara_dll) cell blink flink elist = - let subst_for_svars = - let g id e = (id, e) in - try List.map2_exn ~f:g para.svars_dll elist with Invalid_argument _ -> assert false - in - let ids_evars = - let g _ = Ident.create_fresh Ident.kprimed in - List.map ~f:g para.evars_dll - in - let subst_for_evars = - let g id id' = (id, Exp.Var id') in - try List.map2_exn ~f:g para.evars_dll ids_evars with Invalid_argument _ -> assert false - in - let subst = - subst_of_list - ( ((para.cell, cell) :: (para.blink, blink) :: (para.flink, flink) :: subst_for_svars) - @ subst_for_evars ) - in - (ids_evars, List.map ~f:(hpred_sub subst) para.body_dll) - - -let custom_error = Pvar.mk_global (Mangled.from_string "INFER_CUSTOM_ERROR") diff --git a/infer/src/IR/Sil.mli b/infer/src/IR/Sil.mli index 631150c51..0b851c825 100644 --- a/infer/src/IR/Sil.mli +++ b/infer/src/IR/Sil.mli @@ -78,186 +78,10 @@ val skip_instr : instr val instr_is_auxiliary : instr -> bool (** Check if an instruction is auxiliary, or if it comes from source instructions. *) -(** Offset for an lvalue. *) -type offset = Off_fld of Typ.Fieldname.t * Typ.t | Off_index of Exp.t - -(** {2 Components of Propositions} *) - -(** an atom is a pure atomic formula *) -type atom = - | Aeq of Exp.t * Exp.t (** equality *) - | Aneq of Exp.t * Exp.t (** disequality *) - | Apred of PredSymb.t * Exp.t list (** predicate symbol applied to exps *) - | Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *) -[@@deriving compare] - -val equal_atom : atom -> atom -> bool - -val atom_has_local_addr : atom -> bool - -(** kind of lseg or dllseg predicates *) -type lseg_kind = - | Lseg_NE (** nonempty (possibly circular) listseg *) - | Lseg_PE (** possibly empty (possibly circular) listseg *) -[@@deriving compare] - -val equal_lseg_kind : lseg_kind -> lseg_kind -> bool - -(** The boolean is true when the pointer was dereferenced without testing for zero. *) -type zero_flag = bool option - -(** True when the value was obtained by doing case analysis on null in a procedure call. *) -type null_case_flag = bool - -(** instrumentation of heap values *) -type inst = - | Iabstraction - | Iactual_precondition - | Ialloc - | Iformal of zero_flag * null_case_flag - | Iinitial - | Ilookup - | Inone - | Inullify - | Irearrange of zero_flag * null_case_flag * int * PredSymb.path_pos - | Itaint - | Iupdate of zero_flag * null_case_flag * int * PredSymb.path_pos - | Ireturn_from_call of int -[@@deriving compare] - -val equal_inst : inst -> inst -> bool - -val inst_actual_precondition : inst - -val inst_formal : inst - -val inst_initial : inst -(** for formal parameters and heap values at the beginning of the function *) - -val inst_lookup : inst -(** for initial values *) - -val inst_none : inst - -val inst_nullify : inst - -val inst_rearrange : bool -> Location.t -> PredSymb.path_pos -> inst -(** the boolean indicates whether the pointer is known nonzero *) - -val inst_update : Location.t -> PredSymb.path_pos -> inst - -val inst_set_null_case_flag : inst -> inst -(** Set the null case flag of the inst. *) - -val inst_new_loc : Location.t -> inst -> inst -(** update the location of the instrumentation *) - -val update_inst : inst -> inst -> inst -(** Update [inst_old] to [inst_new] preserving the zero flag *) - -exception JoinFail - -val inst_partial_join : inst -> inst -> inst -(** join of instrumentations, can raise JoinFail *) - -val inst_partial_meet : inst -> inst -> inst -(** meet of instrumentations *) - -(** structured expressions represent a value of structured type, such as an array or a struct. *) -type 'inst strexp0 = - | Eexp of Exp.t * 'inst (** Base case: expression with instrumentation *) - | Estruct of (Typ.Fieldname.t * 'inst strexp0) list * 'inst (** C structure *) - | Earray of Exp.t * (Exp.t * 'inst strexp0) list * 'inst - (** Array of given length There are two conditions imposed / used in the array case. First, if - some index and value pair appears inside an array in a strexp, then the index is less than - the length of the array. For instance, [x |->\[10 | e1: v1\]] implies that [e1 <= 9]. - Second, if two indices appear in an array, they should be different. For instance, - [x |->\[10 | e1: v1, e2: v2\]] implies that [e1 != e2]. *) -[@@deriving compare] - -type strexp = inst strexp0 - -val compare_strexp : ?inst:bool -> strexp -> strexp -> int -(** Comparison function for strexp. The inst:: parameter specifies whether instumentations should - also be considered (false by default). *) - -val equal_strexp : ?inst:bool -> strexp -> strexp -> bool -(** Equality function for strexp. The inst:: parameter specifies whether instumentations should also - be considered (false by default). *) - -(** an atomic heap predicate *) -type 'inst hpred0 = - | Hpointsto of Exp.t * 'inst strexp0 * Exp.t - (** represents [exp|->strexp:typexp] where [typexp] is an expression representing a type, e.h. - [sizeof(t)]. *) - | Hlseg of lseg_kind * 'inst hpara0 * Exp.t * Exp.t * Exp.t list - (** higher - order predicate for singly - linked lists. Should ensure that exp1!= exp2 implies - that exp1 is allocated. This assumption is used in the rearrangement. The last [exp list] - parameter is used to denote the shared links by all the nodes in the list. *) - | Hdllseg of lseg_kind * 'inst hpara_dll0 * Exp.t * Exp.t * Exp.t * Exp.t * Exp.t list - (** higher-order predicate for doubly-linked lists. Parameter for the higher-order - singly-linked list predicate. Means "lambda (root,next,svars). Exists evars. body". Assume - that root, next, svars, evars are disjoint sets of primed identifiers, and include all the - free primed identifiers in body. body should not contain any non - primed identifiers or - program variables (i.e. pvars). *) -[@@deriving compare] - -and 'inst hpara0 = - {root: Ident.t; next: Ident.t; svars: Ident.t list; evars: Ident.t list; body: 'inst hpred0 list} -[@@deriving compare] - -(** parameter for the higher-order doubly-linked list predicates. Assume that all the free - identifiers in body_dll should belong to cell, blink, flink, svars_dll, evars_dll. *) -and 'inst hpara_dll0 = - { cell: Ident.t (** address cell *) - ; blink: Ident.t (** backward link *) - ; flink: Ident.t (** forward link *) - ; svars_dll: Ident.t list - ; evars_dll: Ident.t list - ; body_dll: 'inst hpred0 list } -[@@deriving compare] - -type hpred = inst hpred0 - -type hpara = inst hpara0 - -type hpara_dll = inst hpara_dll0 - -val compare_hpred : ?inst:bool -> hpred -> hpred -> int -(** Comparison function for hpred. The inst:: parameter specifies whether instumentations should - also be considered (false by default). *) - -val equal_hpred : ?inst:bool -> hpred -> hpred -> bool -(** Equality function for hpred. The inst:: parameter specifies whether instumentations should also - be considered (false by default). *) - -module HpredSet : Caml.Set.S with type elt = hpred -(** Sets of heap predicates *) - -(** {2 Compaction} *) - -type sharing_env - -val create_sharing_env : unit -> sharing_env -(** Create a sharing env to store canonical representations *) - -val hpred_compact : sharing_env -> hpred -> hpred -(** Return a compact representation of the exp *) - -val is_objc_object : hpred -> bool -(** {2 Comparision And Inspection Functions} *) - val add_with_block_parameters_flag : instr -> instr (** Adds a with_blocks_parameters flag to a method call, when the arguments contain an Objective-C block, and the method is an Objective-C method (to be extended to other methods) *) -(** {2 Pretty Printing} *) - -val pp_offset : Pp.env -> F.formatter -> offset -> unit - -val d_offset_list : offset list -> unit -(** Dump a list of offsets *) - val location_of_instr : instr -> Location.t (** Get the location of the instruction *) @@ -274,201 +98,3 @@ val pp_instr : print_types:bool -> Pp.env -> F.formatter -> instr -> unit val d_instr : instr -> unit (** Dump an instruction. *) - -val pp_atom : Pp.env -> F.formatter -> atom -> unit -(** Pretty print an atom. *) - -val d_atom : atom -> unit -(** Dump an atom. *) - -val pp_inst : F.formatter -> inst -> unit -(** pretty-print an inst *) - -val pp_sexp : Pp.env -> F.formatter -> strexp -> unit -(** Pretty print a strexp. *) - -val d_sexp : strexp -> unit -(** Dump a strexp. *) - -val pp_hpred : Pp.env -> F.formatter -> hpred -> unit -(** Pretty print a hpred. *) - -val d_hpred : hpred -> unit -(** Dump a hpred. *) - -val pp_hpara : Pp.env -> F.formatter -> hpara -> unit -(** Pretty print a hpara. *) - -val pp_hpara_dll : Pp.env -> F.formatter -> hpara_dll -> unit -(** Pretty print a hpara_dll. *) - -(** Module Predicates records the occurrences of predicates as parameters of (doubly -)linked lists - and Epara. Provides unique numbering for predicates and an iterator. *) -module Predicates : sig - (** predicate environment *) - type env - - val empty_env : unit -> env - (** create an empty predicate environment *) - - val is_empty : env -> bool - (** return true if the environment is empty *) - - val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit - (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, passing the unique - id to the functions. The iterator can only be used once. *) - - val process_hpred : env -> hpred -> unit - (** Process one hpred, updating the predicate environment *) -end - -val pp_hpred_env : Pp.env -> Predicates.env option -> F.formatter -> hpred -> unit -(** Pretty print a hpred with optional predicate env *) - -(** {2 Functions for traversing SIL data types} *) - -val strexp_expmap : (Exp.t * inst option -> Exp.t * inst option) -> strexp -> strexp -(** Change exps in strexp using [f]. WARNING: the result might not be normalized. *) - -val hpred_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred -> hpred -(** Change exps in hpred by [f]. WARNING: the result might not be normalized. *) - -val hpred_instmap : (inst -> inst) -> hpred -> hpred -(** Change instrumentations in hpred using [f]. *) - -val hpred_list_expmap : (Exp.t * inst option -> Exp.t * inst option) -> hpred list -> hpred list -(** Change exps in hpred list by [f]. WARNING: the result might not be normalized. *) - -val atom_expmap : (Exp.t -> Exp.t) -> atom -> atom -(** Change exps in atom by [f]. WARNING: the result might not be normalized. *) - -val hpred_list_get_lexps : (Exp.t -> bool) -> hpred list -> Exp.t list - -val hpred_entries : hpred -> Exp.t list - -val atom_free_vars : atom -> Ident.t Sequence.t - -val atom_gen_free_vars : atom -> (unit, Ident.t) Sequence.Generator.t - -val hpred_free_vars : hpred -> Ident.t Sequence.t - -val hpred_gen_free_vars : hpred -> (unit, Ident.t) Sequence.Generator.t - -val hpara_shallow_free_vars : hpara -> Ident.t Sequence.t - -val hpara_dll_shallow_free_vars : hpara_dll -> Ident.t Sequence.t -(** Variables in hpara_dll, excluding bound vars in the body *) - -(** {2 Substitution} *) - -type subst = private (Ident.t * Exp.t) list [@@deriving compare] - -val equal_subst : subst -> subst -> bool -(** Equality for substitutions. *) - -val subst_of_list : (Ident.t * Exp.t) list -> subst -(** Create a substitution from a list of pairs. For all (id1, e1), (id2, e2) in the input list, if - id1 = id2, then e1 = e2. *) - -val subst_of_list_duplicates : (Ident.t * Exp.t) list -> subst -(** like subst_of_list, but allow duplicate ids and only keep the first occurrence *) - -val sub_to_list : subst -> (Ident.t * Exp.t) list -(** Convert a subst to a list of pairs. *) - -val sub_empty : subst -(** The empty substitution. *) - -val is_sub_empty : subst -> bool - -val sub_join : subst -> subst -> subst -(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the - output is this common part. The second and third components are the remainder of [subst1] and - [subst2], respectively. *) - -val sub_symmetric_difference : subst -> subst -> subst * subst * subst -(** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the - output is this common part. The second and third components are the remainder of [subst1] and - [subst2], respectively. *) - -val sub_find : (Ident.t -> bool) -> subst -> Exp.t -(** [sub_find filter sub] returns the expression associated to the first identifier that satisfies - [filter]. Raise [Not_found] if there isn't one. *) - -val sub_filter : (Ident.t -> bool) -> subst -> subst -(** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *) - -val sub_filter_pair : subst -> f:(Ident.t * Exp.t -> bool) -> subst -(** [sub_filter_exp filter sub] restricts the domain of [sub] to the identifiers satisfying - [filter(id, sub(id))]. *) - -val sub_range_partition : (Exp.t -> bool) -> subst -> subst * subst -(** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy - [filter]. *) - -val sub_domain_partition : (Ident.t -> bool) -> subst -> subst * subst -(** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers - satisfy [filter]. *) - -val sub_domain : subst -> Ident.t list -(** Return the list of identifiers in the domain of the substitution. *) - -val sub_range : subst -> Exp.t list -(** Return the list of expressions in the range of the substitution. *) - -val sub_range_map : (Exp.t -> Exp.t) -> subst -> subst -(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *) - -val sub_map : (Ident.t -> Ident.t) -> (Exp.t -> Exp.t) -> subst -> subst -(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain of [sub] and the - substitution [g] to the expressions in the range of [sub]. *) - -val extend_sub : subst -> Ident.t -> Exp.t -> subst option -(** Extend substitution and return [None] if not possible. *) - -val subst_free_vars : subst -> Ident.t Sequence.t - -val subst_gen_free_vars : subst -> (unit, Ident.t) Sequence.Generator.t - -(** substitution functions WARNING: these functions do not ensure that the results are normalized. *) - -val exp_sub : subst -> Exp.t -> Exp.t - -val atom_sub : subst -> atom -> atom - -val instr_sub : subst -> instr -> instr -(** apply [subst] to all id's in [instr], including LHS id's *) - -val hpred_sub : subst -> hpred -> hpred - -(** {2 Functions for replacing occurrences of expressions.} *) - -val exp_replace_exp : (Exp.t * Exp.t) list -> Exp.t -> Exp.t - -val atom_replace_exp : (Exp.t * Exp.t) list -> atom -> atom - -val hpred_replace_exp : (Exp.t * Exp.t) list -> hpred -> hpred - -(** {2 Functions for constructing or destructing entities in this module} *) - -val exp_get_offsets : Exp.t -> offset list -(** Compute the offset list of an expression *) - -val exp_add_offsets : Exp.t -> offset list -> Exp.t -(** Add the offset list to an expression *) - -val sigma_to_sigma_ne : hpred list -> (atom list * hpred list) list - -val hpara_instantiate : hpara -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list -(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], [e2] and [elist]. If - [para = lambda (x, y, xs). exists zs. b], then the result of the instantiation is - [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] for some fresh [_zs'].*) - -val hpara_dll_instantiate : - hpara_dll -> Exp.t -> Exp.t -> Exp.t -> Exp.t list -> Ident.t list * hpred list -(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], [blink], - [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], then the result of the - instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] for some fresh - [_zs'].*) - -val custom_error : Pvar.t diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index df403ab3d..0934192fc 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -47,7 +47,7 @@ let is_special_field matcher field_name_opt field = (** Check whether the hpred is a |-> representing a resource in the Racquire state *) let hpred_is_open_resource tenv prop = function - | Sil.Hpointsto (e, _, _) -> ( + | Predicates.Hpointsto (e, _, _) -> ( match Attribute.get_resource tenv prop e with | Some (Apred (Aresource {ra_kind= Racquire; ra_res= res}, _)) -> Some res @@ -214,7 +214,7 @@ and exp_lv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option = None ) else let seen = Exp.Set.add e seen_ in - match Prop.exp_normalize_noabs tenv Sil.sub_empty e with + match Prop.exp_normalize_noabs tenv Predicates.sub_empty e with | Exp.Const c -> if verbose then (L.d_str "exp_lv_dexp: constant " ; Exp.d_exp e ; L.d_ln ()) ; Some (DExp.Dderef (DExp.Dconst c)) @@ -407,12 +407,13 @@ let explain_allocation_mismatch ra_alloc ra_dealloc = (** check whether the type of leaked [hpred] appears as a predicate in an inductive predicate in [prop] *) let leak_from_list_abstraction hpred prop = - let hpred_type = function - | Sil.Hpointsto (_, _, texp) -> + let hpred_type (hpred : Predicates.hpred) = + match hpred with + | Hpointsto (_, _, texp) -> Some texp - | Sil.Hlseg (_, {Sil.body= [Sil.Hpointsto (_, _, texp)]}, _, _, _) -> + | Hlseg (_, {body= [Hpointsto (_, _, texp)]}, _, _, _) -> Some texp - | Sil.Hdllseg (_, {Sil.body_dll= [Sil.Hpointsto (_, _, texp)]}, _, _, _, _, _) -> + | Hdllseg (_, {body_dll= [Hpointsto (_, _, texp)]}, _, _, _, _, _) -> Some texp | _ -> None @@ -421,12 +422,12 @@ let leak_from_list_abstraction hpred prop = let check_hpred texp hp = match hpred_type hp with Some texp' when Exp.equal texp texp' -> found := true | _ -> () in - let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body in - let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body_dll in + let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Predicates.body in + let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Predicates.body_dll in match hpred_type hpred with | Some texp -> let env = Prop.prop_pred_env prop in - Sil.Predicates.iter env (check_hpara texp) (check_hpara_dll texp) ; + Predicates.Env.iter env (check_hpara texp) (check_hpara_dll texp) ; if !found then ( L.d_str "leak_from_list_abstraction of predicate of type " ; Exp.d_texp_full texp ; @@ -437,13 +438,15 @@ let leak_from_list_abstraction hpred prop = (** find the type of hpred, if any *) -let find_hpred_typ hpred = match hpred with Sil.Hpointsto (_, _, texp) -> Some texp | _ -> None +let find_hpred_typ hpred = + match hpred with Predicates.Hpointsto (_, _, texp) -> Some texp | _ -> None + (** find the type of pvar and remove the pointer, if any *) let find_typ_without_ptr prop pvar = let res = ref None in let do_hpred = function - | Sil.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) -> + | Predicates.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) -> res := Some te | _ -> () @@ -571,7 +574,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = let rec find sigma_acc sigma_todo exp = let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = match se with - | Sil.Eexp (e, _) when Exp.equal exp e -> ( + | Predicates.Eexp (e, _) when Exp.equal exp e -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with | Exp.Lvar pv -> @@ -604,7 +607,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = in let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with - | Sil.Eexp (e, _) when Exp.equal exp e -> ( + | Predicates.Eexp (e, _) when Exp.equal exp e -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with | Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) -> @@ -622,7 +625,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = Exp.d_exp lexp ; L.d_ln () ) ; (None, None) ) - | Sil.Estruct (fsel, _) -> + | Predicates.Estruct (fsel, _) -> let res = ref (None, None) in List.iter ~f:(do_fse res sigma_acc' sigma_todo' lexp texp) fsel ; !res @@ -637,13 +640,13 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = | _ -> false in - List.exists ~f:filter (Sil.sub_to_list prop.Prop.sub) + List.exists ~f:filter (Predicates.sub_to_list prop.Prop.sub) in function - | Sil.Hpointsto (Exp.Lvar pv, sexp, texp) + | Predicates.Hpointsto (Exp.Lvar pv, sexp, texp) when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv -> do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp - | Sil.Hpointsto (Exp.Var id, sexp, texp) + | Predicates.Hpointsto (Exp.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp | _ -> @@ -673,17 +676,18 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = let access_opt ?(is_nullable = false) inst = - match inst with - | Sil.Iupdate (_, ncf, n, _) -> + match (inst : Predicates.inst) with + | Iupdate (_, ncf, n, _) -> Some (Localise.Last_assigned (n, ncf)) - | Sil.Irearrange (_, _, n, _) -> + | Irearrange (_, _, n, _) -> Some (Localise.Last_accessed (n, is_nullable)) - | Sil.Ireturn_from_call n -> + | Ireturn_from_call n -> Some (Localise.Returned_from_call n) - | Sil.Ialloc when Language.curr_language_is Java -> + | Ialloc when Language.curr_language_is Java -> Some Localise.Initialized_automatically | inst -> - if verbose then L.d_printfln "explain_dexp_access: inst is not an update %a" Sil.pp_inst inst ; + if verbose then + L.d_printfln "explain_dexp_access: inst is not an update %a" Predicates.pp_inst inst ; None @@ -693,19 +697,19 @@ let explain_dexp_access prop dexp is_nullable = let sexpo_to_inst = function | None -> None - | Some (Sil.Eexp (_, inst)) -> + | Some (Predicates.Eexp (_, inst)) -> Some inst | Some se -> if verbose then ( L.d_str "sexpo_to_inst: can't find inst " ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_ln () ) ; None in - let find_ptsto (e : Exp.t) : Sil.strexp option = + let find_ptsto (e : Exp.t) : Predicates.strexp option = let res = ref None in let do_hpred = function - | Sil.Hpointsto (e', se, _) when Exp.equal e e' -> + | Predicates.Hpointsto (e', se, _) when Exp.equal e e' -> res := Some se | _ -> () @@ -731,28 +735,28 @@ let explain_dexp_access prop dexp is_nullable = | (e1, se) :: esel' -> if Exp.equal e1 e then Some se else lookup_esel esel' e in - let rec lookup : DExp.t -> Sil.strexp option = function + let rec lookup : DExp.t -> Predicates.strexp option = function | DExp.Dconst c -> - Some (Sil.Eexp (Exp.Const c, Sil.inst_none)) + Some (Predicates.Eexp (Exp.Const c, Predicates.inst_none)) | DExp.Darray (de1, de2) -> ( match (lookup de1, lookup de2) with | None, _ | _, None -> None - | Some (Sil.Earray (_, esel, _)), Some (Sil.Eexp (e, _)) -> + | Some (Predicates.Earray (_, esel, _)), Some (Predicates.Eexp (e, _)) -> lookup_esel esel e | Some se1, Some se2 -> if verbose then ( L.d_str "lookup: case not matched on Darray " ; - Sil.d_sexp se1 ; + Predicates.d_sexp se1 ; L.d_str " " ; - Sil.d_sexp se2 ; + Predicates.d_sexp se2 ; L.d_ln () ) ; None ) | DExp.Darrow (DExp.Dpvaraddr pvar, f) -> ( match lookup (DExp.Dpvaraddr pvar) with | None -> None - | Some (Sil.Estruct (fsel, _)) -> + | Some (Predicates.Estruct (fsel, _)) -> lookup_fld fsel f | Some _ -> if verbose then L.d_strln "lookup: case not matched on Darrow" ; @@ -761,7 +765,7 @@ let explain_dexp_access prop dexp is_nullable = match lookup (DExp.Dderef de1) with | None -> None - | Some (Sil.Estruct (fsel, _)) -> + | Some (Predicates.Estruct (fsel, _)) -> lookup_fld fsel f | Some _ -> if verbose then L.d_strln "lookup: case not matched on Darrow" ; @@ -770,9 +774,9 @@ let explain_dexp_access prop dexp is_nullable = match lookup de1 with | None -> None - | Some (Sil.Estruct (fsel, _)) -> + | Some (Predicates.Estruct (fsel, _)) -> lookup_fld fsel f - | Some (Sil.Eexp (Const (Cfun _), _) as fun_strexp) -> + | Some (Predicates.Eexp (Const (Cfun _), _) as fun_strexp) -> Some fun_strexp | Some _ -> if verbose then L.d_strln "lookup: case not matched on Ddot" ; @@ -781,7 +785,13 @@ let explain_dexp_access prop dexp is_nullable = if verbose then L.d_strln "lookup: found Dpvar" ; find_ptsto (Exp.Lvar pvar) | DExp.Dderef de -> ( - match lookup de with None -> None | Some (Sil.Eexp (e, _)) -> find_ptsto e | Some _ -> None ) + match lookup de with + | None -> + None + | Some (Predicates.Eexp (e, _)) -> + find_ptsto e + | Some _ -> + None ) | DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de -> if verbose then L.d_printfln "lookup: case )pvar + constant) %a" DExp.pp de ; None @@ -790,7 +800,7 @@ let explain_dexp_access prop dexp is_nullable = match c with | Const.Cfun _ -> (* Treat function as an update *) - Some (Sil.Eexp (Exp.Const c, Sil.Ireturn_from_call loc.Location.line)) + Some (Predicates.Eexp (Exp.Const c, Predicates.Ireturn_from_call loc.Location.line)) | _ -> None ) | DExp.Dpvaraddr pvar -> @@ -1051,21 +1061,21 @@ let find_with_exp prop exp = if is_none !res then res := Some (pv, Fstruct (List.rev fld_lst)) in let rec search_struct pv fld_lst = function - | Sil.Eexp (e, _) -> + | Predicates.Eexp (e, _) -> if Exp.equal e exp then found_in_struct pv fld_lst - | Sil.Estruct (fsel, _) -> + | Predicates.Estruct (fsel, _) -> List.iter ~f:(fun (f, se) -> search_struct pv (f :: fld_lst) se) fsel | _ -> () in let do_hpred_pointed_by_pvar pv e = function - | Sil.Hpointsto (e1, se, _) -> + | Predicates.Hpointsto (e1, se, _) -> if Exp.equal e e1 then search_struct pv [] se | _ -> () in let do_hpred = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + | Predicates.Hpointsto (Lvar pv, Eexp (e, _), _) -> if Exp.equal e exp then found_in_pvar pv else List.iter ~f:(do_hpred_pointed_by_pvar pv e) prop.Prop.sigma | _ -> diff --git a/infer/src/backend/errdesc.mli b/infer/src/backend/errdesc.mli index 312b0412e..07cec3c1f 100644 --- a/infer/src/backend/errdesc.mli +++ b/infer/src/backend/errdesc.mli @@ -14,7 +14,7 @@ val vpath_find : Tenv.t -> 'a Prop.t -> Exp.t -> DecompiledExp.vpath * Typ.t opt (** find the dexp, if any, where the given value is stored also return the type of the value if found *) -val hpred_is_open_resource : Tenv.t -> 'a Prop.t -> Sil.hpred -> PredSymb.resource option +val hpred_is_open_resource : Tenv.t -> 'a Prop.t -> Predicates.hpred -> PredSymb.resource option (** Check whether the hpred is a |-> representing a resource in the Racquire state *) val find_normal_variable_funcall : @@ -107,7 +107,7 @@ val explain_unary_minus_applied_to_unsigned_expression : val explain_leak : Tenv.t - -> Sil.hpred + -> Predicates.hpred -> 'a Prop.t -> PredSymb.t option -> string option @@ -125,4 +125,4 @@ val warning_err : Location.t -> ('a, Format.formatter, unit) format -> 'a val find_outermost_dereference : Tenv.t -> Procdesc.Node.t -> Exp.t -> DecompiledExp.t option -val access_opt : ?is_nullable:bool -> Sil.inst -> Localise.access option +val access_opt : ?is_nullable:bool -> Predicates.inst -> Localise.access option diff --git a/infer/src/biabduction/Abs.ml b/infer/src/biabduction/Abs.ml index e1957a0a4..45106d9ff 100644 --- a/infer/src/biabduction/Abs.ml +++ b/infer/src/biabduction/Abs.ml @@ -19,9 +19,9 @@ type rule = ; r_root: Match.hpred_pat ; r_sigma: Match.hpred_pat list ; (* sigma should be in a specific order *) - r_new_sigma: Sil.hpred list - ; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Sil.subst -> Sil.atom list - ; r_condition: Prop.normal Prop.t -> Sil.subst -> bool } + r_new_sigma: Predicates.hpred list + ; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Predicates.subst -> Predicates.atom list + ; r_condition: Prop.normal Prop.t -> Predicates.subst -> bool } let sigma_rewrite tenv p r : Prop.normal Prop.t option = match Match.prop_match_with_impl tenv p r.r_condition r.r_vars r.r_root r.r_sigma with @@ -43,7 +43,7 @@ let create_fresh_primeds_ls para = let id_next = Ident.create_fresh Ident.kprimed in let id_end = Ident.create_fresh Ident.kprimed in let ids_shared = - let svars = para.Sil.svars in + let svars = para.Predicates.svars in let f _ = Ident.create_fresh Ident.kprimed in List.map ~f svars in @@ -56,15 +56,16 @@ let create_fresh_primeds_ls para = (ids_tuple, exps_tuple) -let create_condition_ls ids_private id_base p_leftover (inst : Sil.subst) = +let create_condition_ls ids_private id_base p_leftover (inst : Predicates.subst) = let insts_of_private_ids, insts_of_public_ids, inst_of_base = let f id' = List.exists ~f:(fun id'' -> Ident.equal id' id'') ids_private in - let inst_private, inst_public = Sil.sub_domain_partition f inst in - let insts_of_public_ids = Sil.sub_range inst_public in + let inst_private, inst_public = Predicates.sub_domain_partition f inst in + let insts_of_public_ids = Predicates.sub_range inst_public in let inst_of_base = - try Sil.sub_find (Ident.equal id_base) inst_public with Caml.Not_found -> assert false + try Predicates.sub_find (Ident.equal id_base) inst_public + with Caml.Not_found -> assert false in - let insts_of_private_ids = Sil.sub_range inst_private in + let insts_of_private_ids = Predicates.sub_range inst_private in (insts_of_private_ids, insts_of_public_ids, inst_of_base) in (* @@ -94,16 +95,16 @@ let create_condition_ls ids_private id_base p_leftover (inst : Sil.subst) = Exp.free_vars e |> Fn.non intersects_fav_insts_of_private_ids ) -let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) = +let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Predicates.hpara) = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in let exp_base, exp_next, exp_end, exps_shared = exps_tuple in - let ids_exist_fst, para_fst = Sil.hpara_instantiate para exp_base exp_next exps_shared in + let ids_exist_fst, para_fst = Predicates.hpara_instantiate para exp_base exp_next exps_shared in let para_fst_start, para_fst_rest = let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in match para_fst with | [] -> - L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; + L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Predicates.pp_hpara Pp.text) para ; assert false | hpred :: hpreds -> let hpat = mark_impl_flag hpred in @@ -112,12 +113,12 @@ let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) = in let ids_exist_snd, para_snd = let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in - let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in + let ids, para_body = Predicates.hpara_instantiate para exp_next exp_end exps_shared in let para_body_hpats = List.map ~f:mark_impl_flag para_body in (ids, para_body_hpats) in - let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in create_condition_ls ids_private id_base @@ -134,11 +135,11 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in let exp_base, exp_next, exp_end, exps_shared = exps_tuple in - let ids_exist, para_inst = Sil.hpara_instantiate para exp_base exp_next exps_shared in + let ids_exist, para_inst = Predicates.hpara_instantiate para exp_base exp_next exps_shared in let para_inst_start, para_inst_rest = match para_inst with | [] -> - L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; + L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Predicates.pp_hpara Pp.text) para ; assert false | hpred :: hpreds -> let allow_impl hpred = {Match.hpred; Match.flag= impl_ok1} in @@ -147,8 +148,8 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = let lseg_pat = {Match.hpred= Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag= impl_ok2} in - let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = id_next :: ids_exist in create_condition_ls ids_private id_base @@ -169,13 +170,13 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = {Match.hpred= Prop.mk_lseg tenv k1 para exp_base exp_next exps_shared; Match.flag= impl_ok1} in let ids_exist, para_inst_pat = - let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in + let ids, para_body = Predicates.hpara_instantiate para exp_next exp_end exps_shared in let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in let para_body_pat = List.map ~f:allow_impl para_body in (ids, para_body_pat) in - let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let lseg_res = Prop.mk_lseg tenv Lseg_NE para exp_base exp_end exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = id_next :: ids_exist in create_condition_ls ids_private id_base @@ -188,12 +189,12 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = ; r_condition= condition } -let lseg_kind_add k1 k2 = +let lseg_kind_add (k1 : Predicates.lseg_kind) (k2 : Predicates.lseg_kind) : Predicates.lseg_kind = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE -> - Sil.Lseg_NE - | Sil.Lseg_PE, Sil.Lseg_PE -> - Sil.Lseg_PE + | Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_NE -> + Lseg_NE + | Lseg_PE, Lseg_PE -> + Lseg_PE let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = @@ -208,7 +209,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = in let k_res = lseg_kind_add k1 k2 in let lseg_res = Prop.mk_lseg tenv k_res para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = + let gen_pi_res _ _ (_ : Predicates.subst) = [] (* let inst_base, inst_next, inst_end = @@ -217,7 +218,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = (find id_base, find id_next, find id_end) with Not_found -> assert false in let spooky_case _ = - (equal_lseg_kind Sil.Lseg_PE k_res) + (equal_lseg_kind Lseg_PE k_res) && (check_allocatedness p_leftover inst_end) && ((check_disequal p_start inst_base inst_next) || (check_disequal p_start inst_next inst_end)) in @@ -240,20 +241,20 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = ; r_condition= condition } -let mk_rules_for_sll tenv (para : Sil.hpara) : rule list = +let mk_rules_for_sll tenv (para : Predicates.hpara) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_ls tenv true true para in - let pts_pels = mk_rule_ptsls_ls tenv Sil.Lseg_PE true false para in - let pels_pts = mk_rule_lspts_ls tenv Sil.Lseg_PE false true para in - let pels_nels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_NE false false para in - let nels_pels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_PE false false para in - let pels_pels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_PE false false para in + let pts_pels = mk_rule_ptsls_ls tenv Lseg_PE true false para in + let pels_pts = mk_rule_lspts_ls tenv Lseg_PE false true para in + let pels_nels = mk_rule_lsls_ls tenv Lseg_PE Lseg_NE false false para in + let nels_pels = mk_rule_lsls_ls tenv Lseg_NE Lseg_PE false false para in + let pels_pels = mk_rule_lsls_ls tenv Lseg_PE Lseg_PE false false para in [pts_pts; pts_pels; pels_pts; pels_nels; nels_pels; pels_pels] else let pts_pts = mk_rule_ptspts_ls tenv true true para in - let pts_nels = mk_rule_ptsls_ls tenv Sil.Lseg_NE true false para in - let nels_pts = mk_rule_lspts_ls tenv Sil.Lseg_NE false true para in - let nels_nels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_NE false false para in + let pts_nels = mk_rule_ptsls_ls tenv Lseg_NE true false para in + let nels_pts = mk_rule_lspts_ls tenv Lseg_NE false true para in + let nels_nels = mk_rule_lsls_ls tenv Lseg_NE Lseg_NE false false para in [pts_pts; pts_nels; nels_pts; nels_nels] @@ -267,7 +268,7 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = let id_oB = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in let ids_shared = - let svars = para.Sil.svars_dll in + let svars = para.Predicates.svars_dll in let f _ = Ident.create_fresh Ident.kprimed in List.map ~f svars in @@ -276,12 +277,15 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = let exp_oB = Exp.Var id_oB in let exp_oF = Exp.Var id_oF in let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in - let ids_exist_fst, para_fst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in + let ids_exist_fst, para_fst = + Predicates.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared + in let para_fst_start, para_fst_rest = let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in match para_fst with | [] -> - L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Sil.pp_hpara_dll Pp.text) para ; + L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Predicates.pp_hpara_dll Pp.text) + para ; assert false | hpred :: hpreds -> let hpat = mark_impl_flag hpred in @@ -290,12 +294,12 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = in let ids_exist_snd, para_snd = let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in - let ids, para_body = Sil.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in + let ids, para_body = Predicates.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in let para_body_hpats = List.map ~f:mark_impl_flag para_body in (ids, para_body_hpats) in - let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = (* for the case of ptspts since iF'=iB therefore iF' cannot be private*) let ids_private = ids_exist_fst @ ids_exist_snd in @@ -322,7 +326,7 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = let id_oF = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in let ids_shared = - let svars = para.Sil.svars_dll in + let svars = para.Predicates.svars_dll in let f _ = Ident.create_fresh Ident.kprimed in List.map ~f svars in @@ -332,7 +336,9 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = let exp_oF = Exp.Var id_oF in let exp_iB = Exp.Var id_iB in let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in - let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in + let ids_exist, para_inst = + Predicates.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared + in let para_inst_start, para_inst_rest = match para_inst with | [] -> @@ -345,8 +351,8 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = { Match.hpred= Prop.mk_dllseg tenv k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared ; Match.flag= impl_ok2 } in - let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = id_iF' :: ids_exist in create_condition_dll ids_private id_iF @@ -366,7 +372,7 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = let id_oB' = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in let ids_shared = - let svars = para.Sil.svars_dll in + let svars = para.Predicates.svars_dll in let f _ = Ident.create_fresh Ident.kprimed in List.map ~f svars in @@ -376,7 +382,9 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = let exp_oB' = Exp.Var id_oB' in let exp_oF = Exp.Var id_oF in let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in - let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared in + let ids_exist, para_inst = + Predicates.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared + in let para_inst_pat = let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in List.map ~f:allow_impl para_inst @@ -385,8 +393,8 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = { Match.hpred= Prop.mk_dllseg tenv k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared ; Match.flag= impl_ok1 } in - let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let dllseg_res = Prop.mk_dllseg tenv Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = id_oB' :: ids_exist in create_condition_dll ids_private id_iF @@ -407,7 +415,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = let id_oF = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in let ids_shared = - let svars = para.Sil.svars_dll in + let svars = para.Predicates.svars_dll in let f _ = Ident.create_fresh Ident.kprimed in List.map ~f svars in @@ -428,7 +436,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = in let k_res = lseg_kind_add k1 k2 in let lseg_res = Prop.mk_dllseg tenv k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in - let gen_pi_res _ _ (_ : Sil.subst) = [] in + let gen_pi_res _ _ (_ : Predicates.subst) = [] in let condition = let ids_private = [id_iF'; id_oB'] in create_condition_dll ids_private id_iF @@ -441,20 +449,20 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = ; r_condition= condition } -let mk_rules_for_dll tenv (para : Sil.hpara_dll) : rule list = +let mk_rules_for_dll tenv (para : Predicates.hpara_dll) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_dll tenv true true para in - let pts_pedll = mk_rule_ptsdll_dll tenv Sil.Lseg_PE true false para in - let pedll_pts = mk_rule_dllpts_dll tenv Sil.Lseg_PE false true para in - let pedll_nedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_NE false false para in - let nedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_PE false false para in - let pedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_PE false false para in + let pts_pedll = mk_rule_ptsdll_dll tenv Lseg_PE true false para in + let pedll_pts = mk_rule_dllpts_dll tenv Lseg_PE false true para in + let pedll_nedll = mk_rule_dlldll_dll tenv Lseg_PE Lseg_NE false false para in + let nedll_pedll = mk_rule_dlldll_dll tenv Lseg_NE Lseg_PE false false para in + let pedll_pedll = mk_rule_dlldll_dll tenv Lseg_PE Lseg_PE false false para in [pts_pts; pts_pedll; pedll_pts; pedll_nedll; nedll_pedll; pedll_pedll] else let ptspts_dll = mk_rule_ptspts_dll tenv true true para in - let ptsdll_dll = mk_rule_ptsdll_dll tenv Sil.Lseg_NE true false para in - let dllpts_dll = mk_rule_dllpts_dll tenv Sil.Lseg_NE false true para in - let dlldll_dll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_NE false false para in + let ptsdll_dll = mk_rule_ptsdll_dll tenv Lseg_NE true false para in + let dllpts_dll = mk_rule_dllpts_dll tenv Lseg_NE false true para in + let dlldll_dll = mk_rule_dlldll_dll tenv Lseg_NE Lseg_NE false false para in [ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll] @@ -493,7 +501,7 @@ let typ_get_recursive_flds tenv typ_exp = assert false -let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option = +let discover_para_roots tenv p root1 next1 root2 next2 : Predicates.hpara option = let eq_arg1 = Exp.equal root1 next1 in let eq_arg2 = Exp.equal root2 next2 in let precondition_check = (not eq_arg1) && not eq_arg2 in @@ -510,7 +518,8 @@ let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option = Some hpara -let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpara_dll option = +let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : + Predicates.hpara_dll option = let eq_arg1 = Exp.equal root1 blink1 in let eq_arg1' = Exp.equal root1 flink1 in let eq_arg2 = Exp.equal root2 blink2 in @@ -535,21 +544,21 @@ let discover_para_candidates tenv p = let get_edges_strexp rec_flds root se = let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in match se with - | Sil.Eexp _ | Sil.Earray _ -> + | Predicates.Eexp _ | Predicates.Earray _ -> () - | Sil.Estruct (fsel, _) -> + | Predicates.Estruct (fsel, _) -> let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in let process (_, nextse) = - match nextse with Sil.Eexp (next, _) -> add_edge (root, next) | _ -> assert false + match nextse with Predicates.Eexp (next, _) -> add_edge (root, next) | _ -> assert false in List.iter ~f:process fsel' in let rec get_edges_sigma = function | [] -> () - | Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest -> + | Predicates.Hlseg _ :: sigma_rest | Predicates.Hdllseg _ :: sigma_rest -> get_edges_sigma sigma_rest - | Sil.Hpointsto (root, se, te) :: sigma_rest -> + | Predicates.Hpointsto (root, se, te) :: sigma_rest -> let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in @@ -577,12 +586,12 @@ let discover_para_dll_candidates tenv p = let get_edges_strexp rec_flds root se = let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in match se with - | Sil.Eexp _ | Sil.Earray _ -> + | Predicates.Eexp _ | Predicates.Earray _ -> () - | Sil.Estruct (fsel, _) -> + | Predicates.Estruct (fsel, _) -> let fsel' = List.rev_filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in let convert_to_exp acc (_, se) = - match se with Sil.Eexp (e, _) -> e :: acc | _ -> assert false + match se with Predicates.Eexp (e, _) -> e :: acc | _ -> assert false in let links = List.fold ~f:convert_to_exp ~init:[] fsel' in let rec iter_pairs = function @@ -597,9 +606,9 @@ let discover_para_dll_candidates tenv p = let rec get_edges_sigma = function | [] -> () - | Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest -> + | Predicates.Hlseg _ :: sigma_rest | Predicates.Hdllseg _ :: sigma_rest -> get_edges_sigma sigma_rest - | Sil.Hpointsto (root, se, te) :: sigma_rest -> + | Predicates.Hpointsto (root, se, te) :: sigma_rest -> let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in @@ -659,7 +668,7 @@ let discover_para_dll tenv p = (****************** Start of the ADT abs_rules ******************) (** Type of parameter for abstraction rules *) -type para_ty = SLL of Sil.hpara | DLL of Sil.hpara_dll +type para_ty = SLL of Predicates.hpara | DLL of Predicates.hpara_dll (** Rule set: a list of rules of a given type *) type rule_set = para_ty * rule list @@ -677,16 +686,16 @@ let set_current_rules rules = Global.current_rules := rules let reset_current_rules () = Global.current_rules := [] let eqs_sub subst eqs = - List.map ~f:(fun (e1, e2) -> (Sil.exp_sub subst e1, Sil.exp_sub subst e2)) eqs + List.map ~f:(fun (e1, e2) -> (Predicates.exp_sub subst e1, Predicates.exp_sub subst e2)) eqs let eqs_solve ids_in eqs_in = - let rec solve (sub : Sil.subst) (eqs : (Exp.t * Exp.t) list) : Sil.subst option = + let rec solve (sub : Predicates.subst) (eqs : (Exp.t * Exp.t) list) : Predicates.subst option = let do_default id e eqs_rest = if not (List.exists ~f:(fun id' -> Ident.equal id id') ids_in) then None else let sub' = - match Sil.extend_sub sub id e with + match Predicates.extend_sub sub id e with | None -> L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ; assert false @@ -714,32 +723,36 @@ let eqs_solve ids_in eqs_in = None in let compute_ids sub = - let sub_list = Sil.sub_to_list sub in + let sub_list = Predicates.sub_to_list sub in let sub_dom = List.map ~f:fst sub_list in let filter id = not (List.exists ~f:(fun id' -> Ident.equal id id') sub_dom) in List.filter ~f:filter ids_in in - match solve Sil.sub_empty eqs_in with None -> None | Some sub -> Some (compute_ids sub, sub) + match solve Predicates.sub_empty eqs_in with + | None -> + None + | Some sub -> + Some (compute_ids sub, sub) let sigma_special_cases_eqs sigma = let rec f ids_acc eqs_acc sigma_acc = function | [] -> [(List.rev ids_acc, List.rev eqs_acc, List.rev sigma_acc)] - | (Sil.Hpointsto _ as hpred) :: sigma_rest -> + | (Predicates.Hpointsto _ as hpred) :: sigma_rest -> f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest - | (Sil.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest -> + | (Predicates.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest -> let empty_case = f ids_acc ((e1, e2) :: eqs_acc) sigma_acc sigma_rest in let pointsto_case = - let eids, para_inst = Sil.hpara_instantiate para e1 e2 es in + let eids, para_inst = Predicates.hpara_instantiate para e1 e2 es in f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest) in let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in empty_case @ pointsto_case @ general_case - | (Sil.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest -> + | (Predicates.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest -> let empty_case = f ids_acc ((e1, e3) :: (e2, e4) :: eqs_acc) sigma_acc sigma_rest in let pointsto_case = - let eids, para_inst = Sil.hpara_dll_instantiate para e1 e2 e3 es in + let eids, para_inst = Predicates.hpara_dll_instantiate para e1 e2 e3 es in f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest) in let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in @@ -748,7 +761,7 @@ let sigma_special_cases_eqs sigma = f [] [] [] sigma -let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list = +let sigma_special_cases ids sigma : (Ident.t list * Predicates.hpred list) list = let special_cases_eqs = sigma_special_cases_eqs sigma in let special_cases_rev = let f acc (eids_cur, eqs_cur, sigma_cur) = @@ -757,22 +770,24 @@ let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list = | None -> acc | Some (ids_res, sub) -> - (ids_res, List.map ~f:(Sil.hpred_sub sub) sigma_cur) :: acc + (ids_res, List.map ~f:(Predicates.hpred_sub sub) sigma_cur) :: acc in List.fold ~f ~init:[] special_cases_eqs in List.rev special_cases_rev -let hpara_special_cases hpara : Sil.hpara list = - let update_para (evars', body') = {hpara with Sil.evars= evars'; Sil.body= body'} in - let special_cases = sigma_special_cases hpara.Sil.evars hpara.Sil.body in +let hpara_special_cases hpara : Predicates.hpara list = + let update_para (evars', body') = {hpara with Predicates.evars= evars'; Predicates.body= body'} in + let special_cases = sigma_special_cases hpara.Predicates.evars hpara.Predicates.body in List.map ~f:update_para special_cases -let hpara_special_cases_dll hpara : Sil.hpara_dll list = - let update_para (evars', body') = {hpara with Sil.evars_dll= evars'; Sil.body_dll= body'} in - let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in +let hpara_special_cases_dll hpara : Predicates.hpara_dll list = + let update_para (evars', body') = + {hpara with Predicates.evars_dll= evars'; Predicates.body_dll= body'} + in + let special_cases = sigma_special_cases hpara.Predicates.evars_dll hpara.Predicates.body_dll in List.map ~f:update_para special_cases @@ -861,7 +876,7 @@ let abstract_pure_part tenv p ~(from_abstract_footprint : bool) = let fav_nonpure = Prop.non_pure_free_vars p |> Ident.set_of_sequence in (* vars in current and footprint sigma *) let filter atom = - Sil.atom_free_vars atom + Predicates.atom_free_vars atom |> Sequence.for_all ~f:(fun id -> if Ident.is_primed id then Ident.Set.mem id fav_sigma else if Ident.is_footprint id then Ident.Set.mem id fav_nonpure @@ -872,26 +887,26 @@ let abstract_pure_part tenv p ~(from_abstract_footprint : bool) = let new_pure = List.fold ~f:(fun pi a -> - match a with + match (a : Predicates.atom) with (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) - | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Lt, _, _)) - | Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const (Const.Cint i)) - | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, _, _)) - | Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const (Const.Cint i)) + | Aeq (Const (Cint i), BinOp (Lt, _, _)) + | Aeq (BinOp (Lt, _, _), Const (Cint i)) + | Aeq (Const (Cint i), BinOp (Le, _, _)) + | Aeq (BinOp (Le, _, _), Const (Cint i)) when IntLit.isone i -> a :: pi - | Sil.Aeq (Exp.Var name, e) when not (Ident.is_primed name) -> ( - match e with Exp.Var _ | Exp.Const _ -> a :: pi | _ -> pi ) - | Sil.Aneq (Var _, _) | Sil.Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) -> + | Aeq (Var name, e) when not (Ident.is_primed name) -> ( + match e with Var _ | Const _ -> a :: pi | _ -> pi ) + | Aneq (Var _, _) | Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) -> a :: pi - | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> + | Aeq _ | Aneq _ | Apred _ | Anpred _ -> pi ) ~init:[] pi_filtered in List.rev new_pure in let new_pure = do_pure (Prop.get_pure p) in - let eprop' = Prop.set p ~pi:new_pure ~sub:Sil.sub_empty in + let eprop' = Prop.set p ~pi:new_pure ~sub:Predicates.sub_empty in let eprop'' = if !BiabductionConfig.footprint && not from_abstract_footprint then let new_pi_footprint = do_pure p.Prop.pi_fp in @@ -915,10 +930,10 @@ let abstract_gc tenv p = Sequence.exists fav_seq ~f:(fun id -> Ident.Set.mem id fav_p_without_pi) in let strong_filter = function - | Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) -> + | Predicates.Aeq (e1, e2) | Predicates.Aneq (e1, e2) -> check (Exp.free_vars e1) && check (Exp.free_vars e2) - | (Sil.Apred _ | Anpred _) as a -> - check (Sil.atom_free_vars a) + | (Predicates.Apred _ | Anpred _) as a -> + check (Predicates.atom_free_vars a) in let new_pi = List.filter ~f:strong_filter pi in let prop = Prop.normalize tenv (Prop.set p ~pi:new_pi) in @@ -934,9 +949,9 @@ let sigma_reachable root_fav sigma = let reach_set = ref root_fav in let edges = ref [] in let do_hpred hpred = - let hp_fav_set = Sil.hpred_free_vars hpred |> Ident.set_of_sequence in + let hp_fav_set = Predicates.hpred_free_vars hpred |> Ident.set_of_sequence in let add_entry e = edges := (e, hp_fav_set) :: !edges in - List.iter ~f:add_entry (Sil.hpred_entries hpred) + List.iter ~f:add_entry (Predicates.hpred_entries hpred) in List.iter ~f:do_hpred sigma ; let edge_fires (e, _) = @@ -962,7 +977,7 @@ let sigma_reachable root_fav sigma = in find_fixpoint !edges ; (* L.d_str "reachable: "; - Ident.Set.iter (fun id -> Sil.d_exp (Exp.Var id); L.d_str " ") !reach_set; + Ident.Set.iter (fun id -> Predicates.d_exp (Exp.Var id); L.d_str " ") !reach_set; L.d_ln (); *) !reach_set @@ -1015,7 +1030,7 @@ let check_junk pname tenv prop = | [] -> List.rev sigma_done | hpred :: sigma_todo' -> - let entries = Sil.hpred_entries hpred in + let entries = Predicates.hpred_entries hpred in if should_remove_hpred entries then ( let part = if fp_part then "footprint" else "normal" in L.d_printfln ".... Prop with garbage in %s part ...." part ; @@ -1139,7 +1154,7 @@ let check_junk pname tenv prop = else remove_junk fp_part fav_root sigma' in let sigma_new = - let fav_sub = Sil.subst_free_vars prop.Prop.sub |> Ident.set_of_sequence in + let fav_sub = Predicates.subst_free_vars prop.Prop.sub |> Ident.set_of_sequence in let fav_sub_sigmafp = Prop.sigma_free_vars prop.Prop.sigma_fp |> Ident.set_of_sequence ~init:fav_sub in @@ -1164,9 +1179,9 @@ let remove_pure_garbage tenv ?(count = fun _ -> 0) prop = let changed = ref false in let rec go prop = let propcount = prop |> Prop.free_vars |> Ident.counts_of_sequence in - let prop = Prop.set prop ~pi:(Prop.get_pure prop) ~sub:Sil.sub_empty in + let prop = Prop.set prop ~pi:(Prop.get_pure prop) ~sub:Predicates.sub_empty in let drop id = Int.equal 1 (count id + propcount id) in - let keep atom = not (Sequence.exists ~f:drop (Sil.atom_free_vars atom)) in + let keep atom = not (Sequence.exists ~f:drop (Predicates.atom_free_vars atom)) in let pi = List.filter ~f:keep prop.Prop.pi in let dropped = List.length pi < List.length prop.Prop.pi in changed := !changed || dropped ; @@ -1209,9 +1224,9 @@ let abstract_spec pname tenv spec = a disequality. As a workaround, here we drop pure facts from the consequent that are known to be true. *) let module AtomSet = Caml.Set.Make (struct - type t = Sil.atom + type t = Predicates.atom - let compare = Sil.compare_atom + let compare = Predicates.compare_atom end) in let pre_pure = let pre = Jprop.to_prop spec.pre in @@ -1272,21 +1287,21 @@ let abstract_prop pname tenv ~(rename_primed : bool) ~(from_abstract_footprint : let get_local_stack cur_sigma init_sigma = let filter_stack = function - | Sil.Hpointsto (Exp.Lvar _, _, _) -> + | Predicates.Hpointsto (Exp.Lvar _, _, _) -> true - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ -> false in let get_stack_var = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pvar, _, _) -> pvar - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ -> assert false in let filter_local_stack olds = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pvar, _, _) -> not (List.exists ~f:(Pvar.equal pvar) olds) - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ -> false in let init_stack = List.filter ~f:filter_stack init_sigma in @@ -1309,9 +1324,9 @@ let extract_footprint_for_abs (p : 'a Prop.t) : Prop.exposed Prop.t * Pvar.t lis let remove_local_stack sigma pvars = let filter_non_stack = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pvar, _, _) -> not (List.exists ~f:(Pvar.equal pvar) pvars) - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hpointsto _ | Predicates.Hlseg _ | Predicates.Hdllseg _ -> true in List.filter ~f:filter_non_stack sigma diff --git a/infer/src/biabduction/Absarray.ml b/infer/src/biabduction/Absarray.ml index 5d07ce8a3..19763dc0d 100644 --- a/infer/src/biabduction/Absarray.ml +++ b/infer/src/biabduction/Absarray.ml @@ -29,7 +29,7 @@ let array_clean_new_index footprint_part new_idx = (** Abstraction for Arrays *) -type sigma = Sil.hpred list +type sigma = Predicates.hpred list (** Matcher for the sigma part specialized to strexps *) module StrexpMatch : sig @@ -39,11 +39,11 @@ module StrexpMatch : sig val path_to_exps : path -> Exp.t list (** convert a path into a list of expressions *) - val path_from_exp_offsets : Exp.t -> Sil.offset list -> path + val path_from_exp_offsets : Exp.t -> Predicates.offset list -> path (** create a path from a root and a list of offsets *) (** path to the root, length, elements and type of a new_array *) - type strexp_data = path * Sil.strexp * Typ.t + type strexp_data = path * Predicates.strexp * Typ.t (** sigma with info about a current array *) type t @@ -57,7 +57,7 @@ module StrexpMatch : sig val get_data : Tenv.t -> t -> strexp_data (** Get the array *) - val replace_strexp : Tenv.t -> bool -> t -> Sil.strexp -> sigma + val replace_strexp : Tenv.t -> bool -> t -> Predicates.strexp -> sigma (** Replace the strexp at a given position by a new strexp *) val replace_index : Tenv.t -> bool -> t -> Exp.t -> Exp.t -> sigma @@ -74,7 +74,7 @@ end = struct let fail () = L.d_strln "Failure of get_strexp_at_syn_offsets" ; L.d_str "se: " ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_ln () ; L.d_str "t: " ; Typ.d_full t ; @@ -84,7 +84,7 @@ end = struct match (se, t.desc, syn_offs) with | _, _, [] -> (se, t) - | Sil.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> ( + | Predicates.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> ( match Tenv.lookup tenv name with | Some {fields} -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in @@ -92,7 +92,7 @@ end = struct get_strexp_at_syn_offsets tenv se' t' syn_offs' | None -> fail () ) - | Sil.Earray (_, esel, _), Typ.Tarray {elt= t'}, Index ind :: syn_offs' -> + | Predicates.Earray (_, esel, _), Typ.Tarray {elt= t'}, Index ind :: syn_offs' -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in get_strexp_at_syn_offsets tenv se' t' syn_offs' | _ -> @@ -104,7 +104,7 @@ end = struct match (se, t.desc, syn_offs) with | _, _, [] -> update se - | Sil.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> ( + | Predicates.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> ( match Tenv.lookup tenv name with | Some {fields} -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in @@ -119,16 +119,16 @@ end = struct if Typ.Fieldname.equal f'' fld then (fld, se_mod) else (f'', se'') ) fsel in - Sil.Estruct (fsel', inst) + Predicates.Estruct (fsel', inst) | None -> assert false ) - | Sil.Earray (len, esel, inst), Tarray {elt= t'}, Index idx :: syn_offs' -> + | Predicates.Earray (len, esel, inst), Tarray {elt= t'}, Index idx :: syn_offs' -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in let esel' = List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel in - Sil.Earray (len, esel', inst) + Predicates.Earray (len, esel', inst) | _ -> assert false @@ -151,9 +151,9 @@ end = struct (** create a path from a root and a list of offsets *) let path_from_exp_offsets root offs = let offset_to_syn_offset = function - | Sil.Off_fld (fld, typ) -> + | Predicates.Off_fld (fld, typ) -> Field (fld, typ) - | Sil.Off_index idx -> + | Predicates.Off_index idx -> Index idx in let syn_offs = List.map ~f:offset_to_syn_offset offs in @@ -161,14 +161,14 @@ end = struct (** path to the root, len, elements and type of a new_array *) - type strexp_data = path * Sil.strexp * Typ.t + type strexp_data = path * Predicates.strexp * Typ.t (** Store hpred using physical equality, and offset list for an array *) - type t = sigma * Sil.hpred * syn_offset list + type t = sigma * Predicates.hpred * syn_offset list (** Find an array at the given path. Can raise [Not_found] *) let find_path sigma (root, syn_offs) : t = - let filter = function Sil.Hpointsto (e, _, _) -> Exp.equal root e | _ -> false in + let filter = function Predicates.Hpointsto (e, _, _) -> Exp.equal root e | _ -> false in let hpred = List.find_exn ~f:filter sigma in (sigma, hpred, syn_offs) @@ -182,13 +182,13 @@ end = struct if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found else match (se, typ.desc) with - | Sil.Estruct (fsel, _), Tstruct name -> ( + | Predicates.Estruct (fsel, _), Tstruct name -> ( match Tenv.lookup tenv name with | Some {fields} -> find_offset_fsel sigma_other hpred root offs fsel fields typ | None -> () ) - | Sil.Earray (_, esel, _), Tarray {elt} -> + | Predicates.Earray (_, esel, _), Tarray {elt} -> find_offset_esel sigma_other hpred root offs esel elt | _ -> () @@ -216,7 +216,7 @@ end = struct () | hpred :: sigma_rest -> ( match hpred with - | Sil.Hpointsto (root, se, te) -> + | Predicates.Hpointsto (root, se, te) -> let sigma_other = sigma_seen @ sigma_rest in find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te) | _ -> @@ -229,7 +229,7 @@ end = struct (** Get the matched strexp *) let get_data tenv ((_, hpred, syn_offs) : t) = match hpred with - | Sil.Hpointsto (root, se, te) -> + | Predicates.Hpointsto (root, se, te) -> let t = Exp.texp_to_typ None te in let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in let path' = (root, syn_offs) in @@ -248,22 +248,22 @@ end = struct let update se' = let se_in = update se' in match (se', se_in) with - | Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2) -> + | Predicates.Earray (len, esel, _), Predicates.Earray (_, esel_in, inst2) -> let orig_indices = List.map ~f:fst esel in let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in let process_index idx = if index_is_not_new idx then idx else array_clean_new_index footprint_part idx in let esel_in' = List.map ~f:(fun (idx, se) -> (process_index idx, se)) esel_in in - Sil.Earray (len, esel_in', inst2) + Predicates.Earray (len, esel_in', inst2) | _, _ -> se_in in match hpred with - | Sil.Hpointsto (root, se, te) -> + | Predicates.Hpointsto (root, se, te) -> let t = Exp.texp_to_typ None te in let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update in - Sil.Hpointsto (root, se', te) + Predicates.Hpointsto (root, se', te) | _ -> assert false @@ -280,13 +280,13 @@ end = struct (index' : Exp.t) = let update se' = match se' with - | Sil.Earray (len, esel, inst) -> + | Predicates.Earray (len, esel, inst) -> let esel' = List.map ~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se')) esel in - Sil.Earray (len, esel', inst) + Predicates.Earray (len, esel', inst) | _ -> assert false in @@ -407,7 +407,7 @@ let index_is_pointed_to tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) in let pointers = List.concat_map ~f:add_index_to_paths indices in let filter = function - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) -> + | Predicates.Hpointsto (_, Predicates.Eexp (e, _), _) -> List.exists ~f:(Exp.equal e) pointers | _ -> false @@ -464,13 +464,13 @@ let keep_only_indices tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) (i let matched = StrexpMatch.find_path sigma path in let _, se, _ = StrexpMatch.get_data tenv matched in match se with - | Sil.Earray (len, esel, inst) -> + | Predicates.Earray (len, esel, inst) -> let esel', esel_leftover' = List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel in if List.is_empty esel_leftover' then (sigma, false) else - let se' = Sil.Earray (len, esel', inst) in + let se' = Predicates.Earray (len, esel', inst) in let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in (sigma', true) | _ -> @@ -493,7 +493,7 @@ let array_typ_can_abstract {Typ.desc} = let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool = let can_abstract_se = match se with - | Sil.Earray (_, esel, _) -> + | Predicates.Earray (_, esel, _) -> let len = List.length esel in len > 1 | _ -> @@ -543,7 +543,7 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _) : StrexpMatch.str partition_abstract should_keep abstract esel default_indices in let do_footprint () = - match se_in with Sil.Earray (_, esel, _) -> do_array_footprint esel | _ -> assert false + match se_in with Predicates.Earray (_, esel, _) -> do_array_footprint esel | _ -> assert false in let filter_abstract d_keys should_keep abstract ksel default_keys = let keep_ksel = List.filter ~f:should_keep ksel in @@ -568,7 +568,11 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _) : StrexpMatch.str filter_abstract Exp.d_list should_keep abstract esel [] in let do_reexecution () = - match se_in with Sil.Earray (_, esel, _) -> do_array_reexecution esel | _ -> assert false + match se_in with + | Predicates.Earray (_, esel, _) -> + do_array_reexecution esel + | _ -> + assert false in if !BiabductionConfig.footprint then do_footprint () else do_reexecution () @@ -595,29 +599,29 @@ let check_after_array_abstraction tenv prop = else not (Exp.free_vars ind |> Sequence.exists ~f:Ident.is_primed) in let rec check_se root offs typ = function - | Sil.Eexp _ -> + | Predicates.Eexp _ -> () - | Sil.Earray (_, esel, _) -> + | Predicates.Earray (_, esel, _) -> (* check that no more than 2 elements are in the array *) let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in if List.length esel > 2 && array_typ_can_abstract typ then if List.for_all ~f:(check_index root offs) esel then () else report_error prop else List.iter - ~f:(fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) + ~f:(fun (ind, se) -> check_se root (offs @ [Predicates.Off_index ind]) typ_elem se) esel - | Sil.Estruct (fsel, _) -> + | Predicates.Estruct (fsel, _) -> List.iter ~f:(fun (f, se) -> let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in - check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se ) + check_se root (offs @ [Predicates.Off_fld (f, typ)]) typ_f se ) fsel in let check_hpred = function - | Sil.Hpointsto (root, se, texp) -> + | Predicates.Hpointsto (root, se, texp) -> let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in check_se root [] typ se - | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hlseg _ | Predicates.Hdllseg _ -> () in let check_sigma sigma = List.iter ~f:check_hpred sigma in @@ -639,7 +643,8 @@ let remove_redundant_elements tenv prop = let occurs_at_most_once : Ident.t -> bool = let fav_curr = let ( @@@ ) = Sequence.append in - Sil.subst_free_vars prop.Prop.sub @@@ Prop.pi_free_vars prop.Prop.pi + Predicates.subst_free_vars prop.Prop.sub + @@@ Prop.pi_free_vars prop.Prop.pi @@@ Prop.sigma_free_vars prop.Prop.sigma in let fav_foot = @@ -657,34 +662,34 @@ let remove_redundant_elements tenv prop = L.d_strln "kill_redundant: removing " ; Exp.d_exp e ; L.d_str " " ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_ln () ; array_abstraction_performed := true ; modified := true ; false in match (e, se) with - | Exp.Const (Const.Cint i), Sil.Eexp (Exp.Var id, _) + | Exp.Const (Const.Cint i), Predicates.Eexp (Exp.Var id, _) when ((not fp_part) || IntLit.iszero i) && (not (Ident.is_normal id)) && occurs_at_most_once id -> remove () (* unknown value can be removed in re-execution mode or if the index is zero *) - | Exp.Var id, Sil.Eexp _ when (not (Ident.is_normal id)) && occurs_at_most_once id -> + | Exp.Var id, Predicates.Eexp _ when (not (Ident.is_normal id)) && occurs_at_most_once id -> remove () (* index unknown can be removed *) | _ -> true in let remove_redundant_se fp_part = function - | Sil.Earray (len, esel, inst) -> + | Predicates.Earray (len, esel, inst) -> let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in - Sil.Earray (len, esel', inst) + Predicates.Earray (len, esel', inst) | se -> se in let remove_redundant_hpred fp_part = function - | Sil.Hpointsto (e, se, te) -> + | Predicates.Hpointsto (e, se, te) -> let se' = remove_redundant_se fp_part se in - Sil.Hpointsto (e, se', te) + Predicates.Hpointsto (e, se', te) | hpred -> hpred in diff --git a/infer/src/biabduction/Attribute.ml b/infer/src/biabduction/Attribute.ml index a2084db1d..7840719d9 100644 --- a/infer/src/biabduction/Attribute.ml +++ b/infer/src/biabduction/Attribute.ml @@ -11,12 +11,12 @@ open! IStd (** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *) (** Check whether an atom is used to mark an attribute *) -let is_pred atom = match atom with Sil.Apred _ | Anpred _ -> true | _ -> false +let is_pred atom = match atom with Predicates.Apred _ | Anpred _ -> true | _ -> false (** Add an attribute associated to the argument expressions *) let add tenv ?(footprint = false) ?(polarity = true) prop attr args = Prop.prop_atom_and tenv ~footprint prop - (if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args)) + (if polarity then Predicates.Apred (attr, args) else Predicates.Anpred (attr, args)) let attributes_in_same_category attr1 attr2 = @@ -28,19 +28,19 @@ let attributes_in_same_category attr1 attr2 = (** Replace an attribute associated to the expression *) let add_or_replace_check_changed tenv check_attribute_change prop atom = match atom with - | Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) -> + | Predicates.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) -> let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in let _, nexp = List.hd_exn pairs in (* len exps0 > 0 by match *) let atom_map = function - | (Sil.Apred (att, exp :: _) | Anpred (att, exp :: _)) + | (Predicates.Apred (att, exp :: _) | Anpred (att, exp :: _)) when Exp.equal nexp exp && attributes_in_same_category att att0 -> check_attribute_change att att0 ; atom | atom' -> atom' in let pi = prop.Prop.pi in - let pi' = IList.map_changed ~equal:Sil.equal_atom ~f:atom_map pi in + let pi' = IList.map_changed ~equal:Predicates.equal_atom ~f:atom_map pi in if phys_equal pi pi' then Prop.prop_atom_and tenv prop atom else Prop.normalize tenv (Prop.set prop ~pi:pi') | _ -> @@ -65,7 +65,7 @@ let get_for_exp tenv (prop : 'a Prop.t) exp = let nexp = Prop.exp_normalize_prop tenv prop exp in let atom_get_attr attributes atom = match atom with - | (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp -> + | (Predicates.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp -> atom :: attributes | _ -> attributes @@ -77,7 +77,7 @@ let get tenv prop exp category = let atts = get_for_exp tenv prop exp in List.find ~f:(function - | Sil.Apred (att, _) | Anpred (att, _) -> + | Predicates.Apred (att, _) | Anpred (att, _) -> PredSymb.equal_category (PredSymb.to_category att) category | _ -> false ) @@ -97,7 +97,7 @@ let get_wontleak tenv prop exp = get tenv prop exp ACwontleak let has_dangling_uninit tenv prop exp = let la = get_for_exp tenv prop exp in List.exists - ~f:(function Sil.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false) + ~f:(function Predicates.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false) la @@ -110,7 +110,7 @@ let filter_atoms tenv ~f prop = let remove tenv prop atom = if is_pred atom then let natom = Prop.atom_normalize_prop tenv prop atom in - let f a = not (Sil.equal_atom natom a) in + let f a = not (Predicates.equal_atom natom a) in filter_atoms tenv ~f prop else prop @@ -118,7 +118,7 @@ let remove tenv prop atom = (** Remove an attribute from all the atoms in the heap *) let remove_for_attr tenv prop att0 = let f = function - | Sil.Apred (att, _) | Anpred (att, _) -> + | Predicates.Apred (att, _) | Anpred (att, _) -> not (PredSymb.equal att0 att) | _ -> true @@ -128,7 +128,7 @@ let remove_for_attr tenv prop att0 = let remove_resource tenv ra_kind ra_res = let f = function - | Sil.Apred (Aresource res_action, _) -> + | Predicates.Apred (Aresource res_action, _) -> PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0 || PredSymb.compare_resource res_action.ra_res ra_res <> 0 | _ -> @@ -146,15 +146,15 @@ let map_resource tenv prop f = att in let atom_map = function - | Sil.Apred (att, ([e] as es)) -> - Sil.Apred (attribute_map e att, es) - | Sil.Anpred (att, ([e] as es)) -> - Sil.Anpred (attribute_map e att, es) + | Predicates.Apred (att, ([e] as es)) -> + Predicates.Apred (attribute_map e att, es) + | Predicates.Anpred (att, ([e] as es)) -> + Predicates.Anpred (attribute_map e att, es) | atom -> atom in let pi0 = prop.Prop.pi in - let pi1 = IList.map_changed ~equal:Sil.equal_atom ~f:atom_map pi0 in + let pi1 = IList.map_changed ~equal:Predicates.equal_atom ~f:atom_map pi0 in if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1) @@ -165,7 +165,7 @@ let replace_objc_null tenv prop lhs_exp rhs_exp = | Some atom, Exp.Var _ -> let prop = remove tenv prop atom in let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop in - let natom = Sil.atom_replace_exp [(rhs_exp, lhs_exp)] atom in + let natom = Predicates.atom_replace_exp [(rhs_exp, lhs_exp)] atom in add_or_replace tenv prop natom | _ -> prop @@ -281,7 +281,7 @@ let find_arithmetic_problem tenv proc_node_session prop exp = of stack variables whose address was still present after deallocation. *) let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = let filter = function - | Sil.Hpointsto (Exp.Lvar v, _, _) -> + | Predicates.Hpointsto (Exp.Lvar v, _, _) -> List.exists ~f:(Pvar.equal v) pvars | _ -> false @@ -294,7 +294,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = let exp_replace = List.map ~f:(function - | Sil.Hpointsto (Exp.Lvar v, _, _) -> + | Predicates.Hpointsto (Exp.Lvar v, _, _) -> let freshv = Ident.create_fresh Ident.kprimed in fresh_address_vars := (v, freshv) :: !fresh_address_vars ; (Exp.Lvar v, Exp.Var freshv) @@ -302,11 +302,14 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = assert false ) sigma_stack in - let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in - let pi = List.map ~f:(Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in + let pi1 = + List.map ~f:(fun (id, e) -> Predicates.Aeq (Exp.Var id, e)) (Predicates.sub_to_list p.sub) + in + let pi = List.map ~f:(Predicates.atom_replace_exp exp_replace) (p.pi @ pi1) in let p' = Prop.normalize tenv - (Prop.set p ~sub:Sil.sub_empty ~sigma:(Prop.sigma_replace_exp tenv exp_replace sigma_other)) + (Prop.set p ~sub:Predicates.sub_empty + ~sigma:(Prop.sigma_replace_exp tenv exp_replace sigma_other)) in let p'' = let res = ref p' in @@ -317,7 +320,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = (* the address of a de-allocated stack var in in the post *) if Ident.Set.mem freshv p'_fav then ( stack_vars_address_in_post := v :: !stack_vars_address_in_post ; - let pred = Sil.Apred (Adangling DAaddr_stack_var, [Exp.Var freshv]) in + let pred = Predicates.Apred (Adangling DAaddr_stack_var, [Exp.Var freshv]) in res := add_or_replace tenv !res pred ) in List.iter ~f:do_var !fresh_address_vars ; @@ -326,7 +329,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = (* Filter out local addresses in p'' *) let filtered_pi, changed = List.fold_right p''.pi ~init:([], false) ~f:(fun a (filtered, changed) -> - if Sil.atom_has_local_addr a then (filtered, true) else (a :: filtered, changed) ) + if Predicates.atom_has_local_addr a then (filtered, true) else (a :: filtered, changed) ) in (* Avoid normalization when p'' does not change *) let p''' = if changed then Prop.normalize tenv (Prop.set p'' ~pi:filtered_pi) else p'' in @@ -339,18 +342,18 @@ let find_equal_formal_path tenv e prop = let rec find_in_sigma e seen_hpreds = List.fold_right ~f:(fun hpred res -> - if List.mem ~equal:Sil.equal_hpred seen_hpreds hpred then None + if List.mem ~equal:Predicates.equal_hpred seen_hpreds hpred then None else let seen_hpreds = hpred :: seen_hpreds in match res with | Some _ -> res | None -> ( - match hpred with - | Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _) + match (hpred : Predicates.hpred) with + | Hpointsto (Exp.Lvar pvar1, Eexp (exp2, Predicates.Iformal (_, _)), _) when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) -> Some (Exp.Lvar pvar1) - | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> + | Hpointsto (exp1, Estruct (fields, _), _) -> List.fold_right ~f:(fun (field, strexp) res -> match res with @@ -358,7 +361,7 @@ let find_equal_formal_path tenv e prop = res | None -> ( match strexp with - | Sil.Eexp (exp2, _) when Exp.equal exp2 e -> ( + | Predicates.Eexp (exp2, _) when Exp.equal exp2 e -> ( match find_in_sigma exp1 seen_hpreds with | Some vfs -> Some (Exp.Lfield (vfs, field, Typ.mk Tvoid)) diff --git a/infer/src/biabduction/Attribute.mli b/infer/src/biabduction/Attribute.mli index 41c4fc72d..1d32c48fd 100644 --- a/infer/src/biabduction/Attribute.mli +++ b/infer/src/biabduction/Attribute.mli @@ -10,7 +10,7 @@ open! IStd (** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *) -val is_pred : Sil.atom -> bool +val is_pred : Predicates.atom -> bool (** Check whether an atom is used to mark an attribute *) val add : @@ -23,43 +23,43 @@ val add : -> Prop.normal Prop.t (** Add an attribute associated to the argument expressions *) -val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t +val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Predicates.atom -> Prop.normal Prop.t (** Replace an attribute associated to the expression *) val add_or_replace_check_changed : Tenv.t -> (PredSymb.t -> PredSymb.t -> unit) -> Prop.normal Prop.t - -> Sil.atom + -> Predicates.atom -> Prop.normal Prop.t (** Replace an attribute associated to the expression, and call the given function with new and old attributes if they changed. *) -val get_all : 'a Prop.t -> Sil.atom list +val get_all : 'a Prop.t -> Predicates.atom list (** Get all the attributes of the prop *) -val get_for_exp : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom list +val get_for_exp : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom list (** Get the attributes associated to the expression, if any *) -val get_objc_null : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option +val get_objc_null : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option (** Get the objc null attribute associated to the expression, if any *) -val get_observer : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option +val get_observer : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option (** Get the observer attribute associated to the expression, if any *) -val get_resource : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option +val get_resource : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option (** Get the resource attribute associated to the expression, if any *) -val get_undef : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option +val get_undef : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option (** Get the undef attribute associated to the expression, if any *) -val get_wontleak : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option +val get_wontleak : Tenv.t -> 'a Prop.t -> Exp.t -> Predicates.atom option (** Get the wontleak attribute associated to the expression, if any *) val has_dangling_uninit : Tenv.t -> 'a Prop.t -> Exp.t -> bool (** Test for existence of an Adangling DAuninit attribute associated to the exp *) -val remove : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t +val remove : Tenv.t -> Prop.normal Prop.t -> Predicates.atom -> Prop.normal Prop.t (** Remove an attribute *) val remove_for_attr : Tenv.t -> Prop.normal Prop.t -> PredSymb.t -> Prop.normal Prop.t diff --git a/infer/src/biabduction/BiabductionSummary.ml b/infer/src/biabduction/BiabductionSummary.ml index 43b6c57fc..11380513d 100644 --- a/infer/src/biabduction/BiabductionSummary.ml +++ b/infer/src/biabduction/BiabductionSummary.ml @@ -175,7 +175,7 @@ module NormSpec : sig val normalize : Tenv.t -> Prop.normal spec -> t - val compact : Sil.sharing_env -> t -> t + val compact : Predicates.sharing_env -> t -> t (** Return a compact representation of the spec *) val tospec : t -> Prop.normal spec @@ -208,7 +208,7 @@ end = struct let idlist = free_vars tenv spec |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let count = ref 0 in let sub = - Sil.subst_of_list + Predicates.subst_of_list (List.map ~f:(fun id -> incr count ; diff --git a/infer/src/biabduction/BiabductionSummary.mli b/infer/src/biabduction/BiabductionSummary.mli index ab6a5ab1c..b308bdc90 100644 --- a/infer/src/biabduction/BiabductionSummary.mli +++ b/infer/src/biabduction/BiabductionSummary.mli @@ -31,7 +31,7 @@ module Jprop : sig applies it to the subparts if the result is [None]. Returns the most absract results which pass [filter]. *) - val jprop_sub : Sil.subst -> Prop.normal t -> Prop.exposed t + val jprop_sub : Predicates.subst -> Prop.normal t -> Prop.exposed t (** apply a substitution to a jprop *) val map : ('a Prop.t -> 'b Prop.t) -> 'a t -> 'b t @@ -58,7 +58,7 @@ type 'a spec = {pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited module NormSpec : sig type t - val compact : Sil.sharing_env -> t -> t + val compact : Predicates.sharing_env -> t -> t (** Return a compact representation of the spec *) val erase_join_info_pre : Tenv.t -> t -> t diff --git a/infer/src/biabduction/BuiltinDefn.ml b/infer/src/biabduction/BuiltinDefn.ml index 63ac1d524..b799f7990 100644 --- a/infer/src/biabduction/BuiltinDefn.ml +++ b/infer/src/biabduction/BuiltinDefn.ml @@ -25,13 +25,14 @@ let execute___builtin_va_arg {Builtin.summary; tenv; prop_; path; args; loc; exe raise (Exceptions.Wrong_argument_number __POS__) -let mk_empty_array len = Sil.Earray (len, [], Sil.inst_none) +let mk_empty_array len = Predicates.Earray (len, [], Predicates.inst_none) (* Make a rearranged array. As it is rearranged when it appears in a precondition it requires that the function is called with the array allocated. If not infer return a null pointer deref *) let mk_empty_array_rearranged len = - Sil.Earray (len, [], Sil.inst_rearrange true (State.get_loc_exn ()) (State.get_path_pos ())) + Predicates.Earray + (len, [], Predicates.inst_rearrange true (State.get_loc_exn ()) (State.get_path_pos ())) let extract_array_type typ = @@ -58,11 +59,11 @@ let add_array_to_prop tenv pdesc prop_ lexp typ = let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let hpred_opt = List.find - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) prop.Prop.sigma in match hpred_opt with - | Some (Sil.Hpointsto (_, Sil.Earray (len, _, _), _)) -> + | Some (Predicates.Hpointsto (_, Predicates.Earray (len, _, _), _)) -> Some (len, prop) | Some _ -> None (* e points to something but not an array *) @@ -125,12 +126,12 @@ let execute___set_array_length {Builtin.tenv; summary; prop_; path; args} : Buil let n_len, prop = check_arith_norm_exp tenv pname len prop__ in let hpred, sigma' = List.partition_tf - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) prop.Prop.sigma in match hpred with - | [Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t)] -> - let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in + | [Predicates.Hpointsto (e, Earray (_, esel, inst), t)] -> + let hpred' = Predicates.Hpointsto (e, Earray (n_len, esel, inst), t) in let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in [(Prop.normalize tenv prop', path)] | _ -> @@ -160,7 +161,7 @@ let create_type tenv n_lexp typ prop = let prop_type = match List.find - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) prop.Prop.sigma with | Some _ -> @@ -169,7 +170,7 @@ let create_type tenv n_lexp typ prop = let mhpred = match typ.Typ.desc with | Typ.Tptr (typ', _) -> - let sexp = Sil.Estruct ([], Sil.inst_none) in + let sexp = Predicates.Estruct ([], Predicates.inst_none) in let texp = Exp.Sizeof {typ= typ'; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} in @@ -222,7 +223,8 @@ let execute___get_type_of {Builtin.summary; tenv; prop_; path; ret_id_typ; args} let hpred_opt = List.find_map ~f:(function - | Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None ) + | Predicates.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None + ) prop.Prop.sigma in match hpred_opt with @@ -241,12 +243,12 @@ let replace_ptsto_texp tenv prop root_e texp = let process_sigma sigma = let sigma1, sigma2 = List.partition_tf - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e root_e | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e root_e | _ -> false) sigma in match sigma1 with - | [Sil.Hpointsto (e, se, _)] -> - Sil.Hpointsto (e, se, texp) :: sigma2 + | [Predicates.Hpointsto (e, se, _)] -> + Predicates.Hpointsto (e, se, texp) :: sigma2 | _ -> sigma in @@ -278,10 +280,10 @@ let execute___instanceof_cast ~instof {Builtin.summary; tenv; prop_; path; ret_i else let res_opt = List.find - ~f:(function Sil.Hpointsto (e1, _, _) -> Exp.equal e1 val1 | _ -> false) + ~f:(function Predicates.Hpointsto (e1, _, _) -> Exp.equal e1 val1 | _ -> false) prop.Prop.sigma |> Option.map ~f:(function - | Sil.Hpointsto (_, _, texp1) -> ( + | Predicates.Hpointsto (_, _, texp1) -> ( let pos_type_opt, neg_type_opt = Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 in @@ -438,7 +440,7 @@ let execute_exit {Builtin.prop_; path} : Builtin.ret_typ = SymExec.diverge prop_ let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (lexp, _, _), [] -> + | Predicates.Hpointsto (lexp, _, _), [] -> let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in if mark_as_freed then let pname = PredSymb.mem_dealloc_pname mk in @@ -456,7 +458,7 @@ let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter = in p_res :: acc else prop :: acc - | Sil.Hpointsto _, _ :: _ -> + | Predicates.Hpointsto _, _ :: _ -> assert false (* alignment error *) | _ -> assert false @@ -581,7 +583,7 @@ let execute_alloc mk can_return_null {Builtin.summary; tenv; prop_; path; ret_id in let id_new = Ident.create_fresh Ident.kprimed in let exp_new = Exp.Var id_new in - let ptsto_new = Prop.mk_ptsto_exp tenv Prop.Fld_init (exp_new, cnt_te, None) Sil.Ialloc in + let ptsto_new = Prop.mk_ptsto_exp tenv Prop.Fld_init (exp_new, cnt_te, None) Predicates.Ialloc in let prop_plus_ptsto = let prop' = Prop.normalize tenv (Prop.prop_sigma_star prop [ptsto_new]) in let ra = @@ -612,10 +614,10 @@ let execute___cxx_typeid ({Builtin.summary; tenv; prop_; args; loc; exe_env} as let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let typ = List.find - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) prop.Prop.sigma |> Option.value_map - ~f:(function Sil.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_) + ~f:(function Predicates.Hpointsto (_, _, Exp.Sizeof {typ}) -> typ | _ -> typ_) ~default:typ_ in let typ_string = Typ.to_string typ in @@ -763,7 +765,7 @@ let execute___infer_fail {Builtin.summary; tenv; prop_; path; args; loc; exe_env in let set_instr = Sil.Store - { e1= Exp.Lvar Sil.custom_error + { e1= Exp.Lvar Predicates.custom_error ; root_typ= Typ.mk Tvoid ; typ= Typ.mk Tvoid ; e2= Exp.Const (Const.Cstr error_str) @@ -784,7 +786,7 @@ let execute___assert_fail {Builtin.summary; tenv; prop_; path; args; loc; exe_en in let set_instr = Sil.Store - { e1= Exp.Lvar Sil.custom_error + { e1= Exp.Lvar Predicates.custom_error ; root_typ= Typ.mk Tvoid ; typ= Typ.mk Tvoid ; e2= Exp.Const (Const.Cstr error_str) diff --git a/infer/src/biabduction/Dom.ml b/infer/src/biabduction/Dom.ml index 5dbf60c08..22e3590cf 100644 --- a/infer/src/biabduction/Dom.ml +++ b/infer/src/biabduction/Dom.ml @@ -29,20 +29,20 @@ let equal_sigma sigma1 sigma2 = | [], [] -> () | [], _ :: _ | _ :: _, [] -> - L.d_strln "failure reason 1" ; raise Sil.JoinFail + L.d_strln "failure reason 1" ; raise Predicates.JoinFail | hpred1 :: sigma1_rest', hpred2 :: sigma2_rest' -> - if Sil.equal_hpred hpred1 hpred2 then f sigma1_rest' sigma2_rest' - else (L.d_strln "failure reason 2" ; raise Sil.JoinFail) + if Predicates.equal_hpred hpred1 hpred2 then f sigma1_rest' sigma2_rest' + else (L.d_strln "failure reason 2" ; raise Predicates.JoinFail) in - let sigma1_sorted = List.sort ~compare:Sil.compare_hpred sigma1 in - let sigma2_sorted = List.sort ~compare:Sil.compare_hpred sigma2 in + let sigma1_sorted = List.sort ~compare:Predicates.compare_hpred sigma1 in + let sigma2_sorted = List.sort ~compare:Predicates.compare_hpred sigma2 in f sigma1_sorted sigma2_sorted let sigma_get_start_lexps_sort sigma = let exp_compare_neg e1 e2 = -Exp.compare e1 e2 in let filter e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in - let lexps = Sil.hpred_list_get_lexps filter sigma in + let lexps = Predicates.hpred_list_get_lexps filter sigma in List.sort ~compare:exp_compare_neg lexps @@ -119,7 +119,7 @@ end = struct let new_c = lookup_const' const_tbl new_r in let old_c = lookup_const' const_tbl old_r in let res_c = Exp.Set.union new_c old_c in - if Exp.Set.cardinal res_c > 1 then (L.d_strln "failure reason 3" ; raise Sil.JoinFail) ; + if Exp.Set.cardinal res_c > 1 then (L.d_strln "failure reason 3" ; raise Predicates.JoinFail) ; Hashtbl.replace tbl old_r new_r ; Hashtbl.replace const_tbl new_r res_c @@ -127,7 +127,7 @@ end = struct let replace_const' tbl const_tbl e c = let r = find' tbl e in let set = Exp.Set.add c (lookup_const' const_tbl r) in - if Exp.Set.cardinal set > 1 then (L.d_strln "failure reason 4" ; raise Sil.JoinFail) ; + if Exp.Set.cardinal set > 1 then (L.d_strln "failure reason 4" ; raise Predicates.JoinFail) ; Hashtbl.replace const_tbl r set @@ -145,15 +145,16 @@ end = struct | false, true -> replace_const' tbl const_tbl e' e | _ -> - L.d_strln "failure reason 5" ; raise Sil.JoinFail ) + L.d_strln "failure reason 5" ; raise Predicates.JoinFail ) | Exp.Var id, Exp.Const _ | Exp.Var id, Exp.Lvar _ -> if can_rename id then replace_const' tbl const_tbl e e' - else (L.d_strln "failure reason 6" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 6" ; raise Predicates.JoinFail) | Exp.Const _, Exp.Var id' | Exp.Lvar _, Exp.Var id' -> if can_rename id' then replace_const' tbl const_tbl e' e - else (L.d_strln "failure reason 7" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 7" ; raise Predicates.JoinFail) | _ -> - if not (Exp.equal e e') then (L.d_strln "failure reason 8" ; raise Sil.JoinFail) else () + if not (Exp.equal e e') then (L.d_strln "failure reason 8" ; raise Predicates.JoinFail) + else () let check side es = @@ -198,7 +199,7 @@ end = struct let lexps2 = ref Exp.Set.empty let get_lexp_set' sigma = - let lexp_lst = Sil.hpred_list_get_lexps (fun _ -> true) sigma in + let lexp_lst = Predicates.hpred_list_get_lexps (fun _ -> true) sigma in List.fold ~f:(fun set e -> Exp.Set.add e set) ~init:Exp.Set.empty lexp_lst @@ -513,7 +514,8 @@ module Rename : sig val get_others : side -> Exp.t -> (Exp.t * Exp.t) option - val get_other_atoms : Tenv.t -> side -> Sil.atom -> (Sil.atom * Sil.atom) option + val get_other_atoms : + Tenv.t -> side -> Predicates.atom -> (Predicates.atom * Predicates.atom) option val lookup : side -> Exp.t -> Exp.t @@ -521,11 +523,11 @@ module Rename : sig val lookup_list_todo : side -> Exp.t list -> Exp.t list - val to_subst_proj : side -> unit Ident.HashQueue.t -> Sil.subst + val to_subst_proj : side -> unit Ident.HashQueue.t -> Predicates.subst val get_unify_eqs : unit -> (Exp.t * Exp.t) list - val to_subst_emb : side -> Sil.subst + val to_subst_emb : side -> Predicates.subst (* val get : Exp.t -> Exp.t -> Exp.t option @@ -570,7 +572,7 @@ end = struct L.d_str "no pattern match in check lost_little e: " ; Exp.d_exp e ; L.d_ln () ; - raise Sil.JoinFail + raise Predicates.JoinFail in lost_little side e assoc_es in @@ -618,12 +620,12 @@ end = struct if todo then Todo.push t ; id | _ -> - L.d_strln "failure reason 9" ; raise Sil.JoinFail ) + L.d_strln "failure reason 9" ; raise Predicates.JoinFail ) | Exp.Var _ | Exp.Const _ | Exp.Lvar _ -> if todo then Todo.push (e, e, e) ; e | _ -> - L.d_strln "failure reason 10" ; raise Sil.JoinFail + L.d_strln "failure reason 10" ; raise Predicates.JoinFail let lookup side e = lookup' false side e @@ -655,8 +657,8 @@ end = struct false in if find_duplicates sub_list_side_sorted then ( - L.d_strln "failure reason 11" ; raise Sil.JoinFail ) - else Sil.subst_of_list sub_list_side + L.d_strln "failure reason 11" ; raise Predicates.JoinFail ) + else Predicates.subst_of_list sub_list_side module SideExpPairHash = Hashtbl.Make (struct @@ -717,7 +719,7 @@ end = struct let compare (i, _) (j, _) = Ident.compare i j in List.dedup_and_sort ~compare sub_list in - Sil.subst_of_list uniq_sub_list + Predicates.subst_of_list uniq_sub_list let get_others' f_lookup side e = @@ -761,53 +763,47 @@ end = struct let a_op = construct e_op in if Config.trace_join then ( L.d_str "build_other_atoms (successful) " ; - Sil.d_atom a_res ; + Predicates.d_atom a_res ; L.d_str ", " ; - Sil.d_atom a_op ; + Predicates.d_atom a_op ; L.d_ln () ) ; Some (a_res, a_op) in let exp_contains_only_normal_ids e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in let atom_contains_only_normal_ids a = - Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_normal + Predicates.atom_free_vars a |> Sequence.for_all ~f:Ident.is_normal in let normal_ids_only = atom_contains_only_normal_ids atom_in in if normal_ids_only then Some (atom_in, atom_in) else - match atom_in with - | Sil.Aneq ((Exp.Var id as e), e') - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + match (atom_in : Predicates.atom) with + | Aneq ((Var id as e), e') when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> (* e' cannot also be a normal id according to the guard so we can consider the two cases separately (this case and the next) *) build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e - | Sil.Aneq (e', (Exp.Var id as e)) - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + | Aneq (e', (Var id as e)) when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e - | Sil.Apred (a, (Var id as e) :: es) + | Apred (a, (Var id as e) :: es) when (not (Ident.is_normal id)) && List.for_all ~f:exp_contains_only_normal_ids es -> build_other_atoms (fun e0 -> Prop.mk_pred tenv a (e0 :: es)) side e - | Sil.Anpred (a, (Var id as e) :: es) + | Anpred (a, (Var id as e) :: es) when (not (Ident.is_normal id)) && List.for_all ~f:exp_contains_only_normal_ids es -> build_other_atoms (fun e0 -> Prop.mk_npred tenv a (e0 :: es)) side e - | Sil.Aeq ((Exp.Var id as e), e') - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + | Aeq ((Var id as e), e') when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> (* e' cannot also be a normal id according to the guard so we can consider the two cases separately (this case and the next) *) build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e - | Sil.Aeq (e', (Exp.Var id as e)) - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + | Aeq (e', (Var id as e)) when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e - | Sil.Aeq (Exp.BinOp (Binop.Le, e, e'), Exp.Const (Const.Cint i)) - | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, e, e')) + | (Aeq (BinOp (Le, e, e'), Const (Cint i)) | Aeq (Const (Cint i), BinOp (Le, e, e'))) when IntLit.isone i && exp_contains_only_normal_ids e' -> - let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e0, e')) in + let construct e0 = Prop.mk_inequality tenv (BinOp (Le, e0, e')) in build_other_atoms construct side e - | Sil.Aeq (Exp.BinOp (Binop.Lt, e', e), Exp.Const (Const.Cint i)) - | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Lt, e', e)) + | (Aeq (BinOp (Lt, e', e), Const (Cint i)) | Aeq (Const (Cint i), BinOp (Lt, e', e))) when IntLit.isone i && exp_contains_only_normal_ids e' -> - let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, e', e0)) in + let construct e0 = Prop.mk_inequality tenv (BinOp (Lt, e', e0)) in build_other_atoms construct side e - | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> + | Aeq _ | Aneq _ | Apred _ | Anpred _ -> None @@ -831,7 +827,9 @@ end = struct if (not (Exp.free_vars e1 |> Sequence.exists ~f:can_rename)) && not (Exp.free_vars e2 |> Sequence.exists ~f:can_rename) - then if Exp.equal e1 e2 then e1 else (L.d_strln "failure reason 13" ; raise Sil.JoinFail) + then + if Exp.equal e1 e2 then e1 + else (L.d_strln "failure reason 13" ; raise Predicates.JoinFail) else match default_op with | ExtDefault e -> @@ -901,12 +899,12 @@ let rec exp_construct_fresh side e = let strexp_construct_fresh side = let f (e, inst_opt) = (exp_construct_fresh side e, inst_opt) in - Sil.strexp_expmap f + Predicates.strexp_expmap f let hpred_construct_fresh side = let f (e, inst_opt) = (exp_construct_fresh side e, inst_opt) in - Sil.hpred_expmap f + Predicates.hpred_expmap f (** {2 Join and Meet for Ids} *) @@ -919,12 +917,12 @@ let ident_partial_join (id1 : Ident.t) (id2 : Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with | true, true -> if Ident.equal id1 id2 then Exp.Var id1 - else (L.d_strln "failure reason 14" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 14" ; raise Predicates.JoinFail) | true, _ | _, true -> Rename.extend (Exp.Var id1) (Exp.Var id2) Rename.ExtFresh | _ -> if not (ident_same_kind_primed_footprint id1 id2) then ( - L.d_strln "failure reason 15" ; raise Sil.JoinFail ) + L.d_strln "failure reason 15" ; raise Predicates.JoinFail ) else let e1 = Exp.Var id1 in let e2 = Exp.Var id2 in @@ -935,7 +933,7 @@ let ident_partial_meet (id1 : Ident.t) (id2 : Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with | true, true -> if Ident.equal id1 id2 then Exp.Var id1 - else (L.d_strln "failure reason 16" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 16" ; raise Predicates.JoinFail) | true, _ -> let e1, e2 = (Exp.Var id1, Exp.Var id2) in Rename.extend e1 e2 (Rename.ExtDefault e1) @@ -948,7 +946,7 @@ let ident_partial_meet (id1 : Ident.t) (id2 : Ident.t) = else if Ident.is_footprint id1 && Ident.equal id1 id2 then let e = Exp.Var id1 in Rename.extend e e (Rename.ExtDefault e) - else (L.d_strln "failure reason 17" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 17" ; raise Predicates.JoinFail) (** {2 Join and Meet for Exps} *) @@ -961,10 +959,10 @@ let const_partial_join c1 c2 = let is_int = function Const.Cint _ -> true | _ -> false in if Const.equal c1 c2 then Exp.Const c1 else if Const.kind_equal c1 c2 && not (is_int c1) then ( - L.d_strln "failure reason 18" ; raise Sil.JoinFail ) + L.d_strln "failure reason 18" ; raise Predicates.JoinFail ) else if !BiabductionConfig.abs_val >= 2 then FreshVarExp.get_fresh_exp (Exp.Const c1) (Exp.Const c2) - else (L.d_strln "failure reason 19" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 19" ; raise Predicates.JoinFail) let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = @@ -973,12 +971,12 @@ let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = | Exp.Var id1, Exp.Var id2 -> ident_partial_join id1 id2 | Exp.Var id, Exp.Const _ | Exp.Const _, Exp.Var id -> - if Ident.is_normal id then (L.d_strln "failure reason 20" ; raise Sil.JoinFail) + if Ident.is_normal id then (L.d_strln "failure reason 20" ; raise Predicates.JoinFail) else Rename.extend e1 e2 Rename.ExtFresh | Exp.Const c1, Exp.Const c2 -> const_partial_join c1 c2 | Exp.Var id, Exp.Lvar _ | Exp.Lvar _, Exp.Var id -> - if Ident.is_normal id then (L.d_strln "failure reason 21" ; raise Sil.JoinFail) + if Ident.is_normal id then (L.d_strln "failure reason 21" ; raise Predicates.JoinFail) else Rename.extend e1 e2 Rename.ExtFresh | Exp.BinOp (Binop.PlusA _, Exp.Var id1, Exp.Const _), Exp.Var id2 | Exp.Var id1, Exp.BinOp (Binop.PlusA _, Exp.Var id2, Exp.Const _) @@ -995,12 +993,13 @@ let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = let e_res = Rename.extend (Exp.int c1') (Exp.Var id2) Rename.ExtFresh in Exp.BinOp (Binop.PlusA None, e_res, Exp.int c2) | Exp.Cast (t1, e1), Exp.Cast (t2, e2) -> - if not (Typ.equal t1 t2) then (L.d_strln "failure reason 22" ; raise Sil.JoinFail) + if not (Typ.equal t1 t2) then (L.d_strln "failure reason 22" ; raise Predicates.JoinFail) else let e1'' = exp_partial_join e1 e2 in Exp.Cast (t1, e1'') | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> - if not (Unop.equal unop1 unop2) then (L.d_strln "failure reason 23" ; raise Sil.JoinFail) + if not (Unop.equal unop1 unop2) then ( + L.d_strln "failure reason 23" ; raise Predicates.JoinFail ) else Exp.UnOp (unop1, exp_partial_join e1 e2, topt1) (* should be topt1 = topt2 *) | Exp.BinOp (Binop.PlusPI, e1, e1'), Exp.BinOp (Binop.PlusPI, e2, e2') -> let e1'' = exp_partial_join e1 e2 in @@ -1013,16 +1012,19 @@ let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = in Exp.BinOp (Binop.PlusPI, e1'', e2'') | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') -> - if not (Binop.equal binop1 binop2) then (L.d_strln "failure reason 24" ; raise Sil.JoinFail) + if not (Binop.equal binop1 binop2) then ( + L.d_strln "failure reason 24" ; raise Predicates.JoinFail ) else let e1'' = exp_partial_join e1 e2 in let e2'' = exp_partial_join e1' e2' in Exp.BinOp (binop1, e1'', e2'') | Exp.Lvar pvar1, Exp.Lvar pvar2 -> - if not (Pvar.equal pvar1 pvar2) then (L.d_strln "failure reason 25" ; raise Sil.JoinFail) + if not (Pvar.equal pvar1 pvar2) then ( + L.d_strln "failure reason 25" ; raise Predicates.JoinFail ) else e1 | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> - if not (Typ.Fieldname.equal f1 f2) then (L.d_strln "failure reason 26" ; raise Sil.JoinFail) + if not (Typ.Fieldname.equal f1 f2) then ( + L.d_strln "failure reason 26" ; raise Predicates.JoinFail ) else Exp.Lfield (exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *) | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> let e1'' = exp_partial_join e1 e2 in @@ -1043,7 +1045,7 @@ let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = L.d_str " " ; Exp.d_exp e2 ; L.d_ln () ; - raise Sil.JoinFail + raise Predicates.JoinFail and length_partial_join len1 len2 = @@ -1089,7 +1091,7 @@ and typ_partial_join (t1 : Typ.t) (t2 : Typ.t) = L.d_str " " ; Typ.d_full t2 ; L.d_ln () ; - raise Sil.JoinFail + raise Predicates.JoinFail let rec exp_partial_meet (e1 : Exp.t) (e2 : Exp.t) : Exp.t = @@ -1098,44 +1100,48 @@ let rec exp_partial_meet (e1 : Exp.t) (e2 : Exp.t) : Exp.t = ident_partial_meet id1 id2 | Exp.Var id, Exp.Const _ -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) - else (L.d_strln "failure reason 27" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 27" ; raise Predicates.JoinFail) | Exp.Const _, Exp.Var id -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) - else (L.d_strln "failure reason 28" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 28" ; raise Predicates.JoinFail) | Exp.Const c1, Exp.Const c2 -> - if Const.equal c1 c2 then e1 else (L.d_strln "failure reason 29" ; raise Sil.JoinFail) + if Const.equal c1 c2 then e1 else (L.d_strln "failure reason 29" ; raise Predicates.JoinFail) | Exp.Cast (t1, e1), Exp.Cast (t2, e2) -> - if not (Typ.equal t1 t2) then (L.d_strln "failure reason 30" ; raise Sil.JoinFail) + if not (Typ.equal t1 t2) then (L.d_strln "failure reason 30" ; raise Predicates.JoinFail) else let e1'' = exp_partial_meet e1 e2 in Exp.Cast (t1, e1'') | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> - if not (Unop.equal unop1 unop2) then (L.d_strln "failure reason 31" ; raise Sil.JoinFail) + if not (Unop.equal unop1 unop2) then ( + L.d_strln "failure reason 31" ; raise Predicates.JoinFail ) else Exp.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *) | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') -> - if not (Binop.equal binop1 binop2) then (L.d_strln "failure reason 32" ; raise Sil.JoinFail) + if not (Binop.equal binop1 binop2) then ( + L.d_strln "failure reason 32" ; raise Predicates.JoinFail ) else let e1'' = exp_partial_meet e1 e2 in let e2'' = exp_partial_meet e1' e2' in Exp.BinOp (binop1, e1'', e2'') | Exp.Var id, Exp.Lvar _ -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) - else (L.d_strln "failure reason 33" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 33" ; raise Predicates.JoinFail) | Exp.Lvar _, Exp.Var id -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) - else (L.d_strln "failure reason 34" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 34" ; raise Predicates.JoinFail) | Exp.Lvar pvar1, Exp.Lvar pvar2 -> - if not (Pvar.equal pvar1 pvar2) then (L.d_strln "failure reason 35" ; raise Sil.JoinFail) + if not (Pvar.equal pvar1 pvar2) then ( + L.d_strln "failure reason 35" ; raise Predicates.JoinFail ) else e1 | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> - if not (Typ.Fieldname.equal f1 f2) then (L.d_strln "failure reason 36" ; raise Sil.JoinFail) + if not (Typ.Fieldname.equal f1 f2) then ( + L.d_strln "failure reason 36" ; raise Predicates.JoinFail ) else Exp.Lfield (exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *) | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> let e1'' = exp_partial_meet e1 e2 in let e2'' = exp_partial_meet e1' e2' in Exp.Lindex (e1'', e2'') | _ -> - L.d_strln "failure reason 37" ; raise Sil.JoinFail + L.d_strln "failure reason 37" ; raise Predicates.JoinFail let exp_list_partial_join = List.map2_exn ~f:exp_partial_join @@ -1144,17 +1150,18 @@ let exp_list_partial_meet = List.map2_exn ~f:exp_partial_meet (** {2 Join and Meet for Strexp} *) -let rec strexp_partial_join mode (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil.strexp = +let rec strexp_partial_join mode (strexp1 : Predicates.strexp) (strexp2 : Predicates.strexp) : + Predicates.strexp = let rec f_fld_se_list inst mode acc fld_se_list1 fld_se_list2 = match (fld_se_list1, fld_se_list2) with | [], [] -> - Sil.Estruct (List.rev acc, inst) + Predicates.Estruct (List.rev acc, inst) | [], _ | _, [] -> ( match mode with | JoinState.Pre -> - L.d_strln "failure reason 42" ; raise Sil.JoinFail + L.d_strln "failure reason 42" ; raise Predicates.JoinFail | JoinState.Post -> - Sil.Estruct (List.rev acc, inst) ) + Predicates.Estruct (List.rev acc, inst) ) | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> ( let comparison = Typ.Fieldname.compare fld1 fld2 in if Int.equal comparison 0 then @@ -1164,7 +1171,7 @@ let rec strexp_partial_join mode (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : else match mode with | JoinState.Pre -> - L.d_strln "failure reason 43" ; raise Sil.JoinFail + L.d_strln "failure reason 43" ; raise Predicates.JoinFail | JoinState.Post -> if comparison < 0 then f_fld_se_list inst mode acc fld_se_list1' fld_se_list2 else if comparison > 0 then f_fld_se_list inst mode acc fld_se_list1 fld_se_list2' @@ -1174,13 +1181,13 @@ let rec strexp_partial_join mode (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : let rec f_idx_se_list inst len idx_se_list_acc idx_se_list1 idx_se_list2 = match (idx_se_list1, idx_se_list2) with | [], [] -> - Sil.Earray (len, List.rev idx_se_list_acc, inst) + Predicates.Earray (len, List.rev idx_se_list_acc, inst) | [], _ | _, [] -> ( match mode with | JoinState.Pre -> - L.d_strln "failure reason 44" ; raise Sil.JoinFail + L.d_strln "failure reason 44" ; raise Predicates.JoinFail | JoinState.Post -> - Sil.Earray (len, List.rev idx_se_list_acc, inst) ) + Predicates.Earray (len, List.rev idx_se_list_acc, inst) ) | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' -> let idx = exp_partial_join idx1 idx2 in let strexp' = strexp_partial_join mode se1 se2 in @@ -1188,21 +1195,22 @@ let rec strexp_partial_join mode (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : f_idx_se_list inst len idx_se_list_new idx_se_list1' idx_se_list2' in match (strexp1, strexp2) with - | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> - Sil.Eexp (exp_partial_join e1 e2, Sil.inst_partial_join inst1 inst2) - | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) -> - let inst = Sil.inst_partial_join inst1 inst2 in + | Eexp (e1, inst1), Eexp (e2, inst2) -> + Predicates.Eexp (exp_partial_join e1 e2, Predicates.inst_partial_join inst1 inst2) + | Estruct (fld_se_list1, inst1), Estruct (fld_se_list2, inst2) -> + let inst = Predicates.inst_partial_join inst1 inst2 in f_fld_se_list inst mode [] fld_se_list1 fld_se_list2 - | Sil.Earray (len1, idx_se_list1, inst1), Sil.Earray (len2, idx_se_list2, inst2) -> + | Earray (len1, idx_se_list1, inst1), Earray (len2, idx_se_list2, inst2) -> let len = length_partial_join len1 len2 in - let inst = Sil.inst_partial_join inst1 inst2 in + let inst = Predicates.inst_partial_join inst1 inst2 in f_idx_se_list inst len [] idx_se_list1 idx_se_list2 | _ -> L.d_strln "no match in strexp_partial_join" ; - raise Sil.JoinFail + raise Predicates.JoinFail -let rec strexp_partial_meet (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil.strexp = +let rec strexp_partial_meet (strexp1 : Predicates.strexp) (strexp2 : Predicates.strexp) : + Predicates.strexp = let construct side rev_list ref_list = let construct_offset_se (off, se) = (off, strexp_construct_fresh side se) in let acc = List.map ~f:construct_offset_se ref_list in @@ -1211,11 +1219,11 @@ let rec strexp_partial_meet (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil. let rec f_fld_se_list inst acc fld_se_list1 fld_se_list2 = match (fld_se_list1, fld_se_list2) with | [], [] -> - Sil.Estruct (List.rev acc, inst) + Predicates.Estruct (List.rev acc, inst) | [], _ -> - Sil.Estruct (construct Rhs acc fld_se_list2, inst) + Predicates.Estruct (construct Rhs acc fld_se_list2, inst) | _, [] -> - Sil.Estruct (construct Lhs acc fld_se_list1, inst) + Predicates.Estruct (construct Lhs acc fld_se_list1, inst) | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> let comparison = Typ.Fieldname.compare fld1 fld2 in if comparison < 0 then @@ -1234,11 +1242,11 @@ let rec strexp_partial_meet (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil. let rec f_idx_se_list inst len acc idx_se_list1 idx_se_list2 = match (idx_se_list1, idx_se_list2) with | [], [] -> - Sil.Earray (len, List.rev acc, inst) + Predicates.Earray (len, List.rev acc, inst) | [], _ -> - Sil.Earray (len, construct Rhs acc idx_se_list2, inst) + Predicates.Earray (len, construct Rhs acc idx_se_list2, inst) | _, [] -> - Sil.Earray (len, construct Lhs acc idx_se_list1, inst) + Predicates.Earray (len, construct Lhs acc idx_se_list1, inst) | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' -> let idx = exp_partial_meet idx1 idx2 in let se' = strexp_partial_meet se1 se2 in @@ -1246,88 +1254,80 @@ let rec strexp_partial_meet (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil. f_idx_se_list inst len acc_new idx_se_list1' idx_se_list2' in match (strexp1, strexp2) with - | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> - Sil.Eexp (exp_partial_meet e1 e2, Sil.inst_partial_meet inst1 inst2) - | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) -> - let inst = Sil.inst_partial_meet inst1 inst2 in + | Eexp (e1, inst1), Eexp (e2, inst2) -> + Eexp (exp_partial_meet e1 e2, Predicates.inst_partial_meet inst1 inst2) + | Estruct (fld_se_list1, inst1), Estruct (fld_se_list2, inst2) -> + let inst = Predicates.inst_partial_meet inst1 inst2 in f_fld_se_list inst [] fld_se_list1 fld_se_list2 - | Sil.Earray (len1, idx_se_list1, inst1), Sil.Earray (len2, idx_se_list2, inst2) - when Exp.equal len1 len2 -> - let inst = Sil.inst_partial_meet inst1 inst2 in + | Earray (len1, idx_se_list1, inst1), Earray (len2, idx_se_list2, inst2) when Exp.equal len1 len2 + -> + let inst = Predicates.inst_partial_meet inst1 inst2 in f_idx_se_list inst len1 [] idx_se_list1 idx_se_list2 | _ -> - L.d_strln "failure reason 52" ; raise Sil.JoinFail + L.d_strln "failure reason 52" ; raise Predicates.JoinFail (** {2 Join and Meet for kind, hpara, hpara_dll} *) -let kind_join k1 k2 = - match (k1, k2) with - | Sil.Lseg_PE, _ -> - Sil.Lseg_PE - | _, Sil.Lseg_PE -> - Sil.Lseg_PE - | Sil.Lseg_NE, Sil.Lseg_NE -> - Sil.Lseg_NE +let kind_join (k1 : Predicates.lseg_kind) (k2 : Predicates.lseg_kind) : Predicates.lseg_kind = + match (k1, k2) with Lseg_PE, _ -> Lseg_PE | _, Lseg_PE -> Lseg_PE | Lseg_NE, Lseg_NE -> Lseg_NE -let kind_meet k1 k2 = - match (k1, k2) with - | Sil.Lseg_NE, _ -> - Sil.Lseg_NE - | _, Sil.Lseg_NE -> - Sil.Lseg_NE - | Sil.Lseg_PE, Sil.Lseg_PE -> - Sil.Lseg_PE +let kind_meet (k1 : Predicates.lseg_kind) (k2 : Predicates.lseg_kind) : Predicates.lseg_kind = + match (k1, k2) with Lseg_NE, _ -> Lseg_NE | _, Lseg_NE -> Lseg_NE | Lseg_PE, Lseg_PE -> Lseg_PE -let hpara_partial_join tenv (hpara1 : Sil.hpara) (hpara2 : Sil.hpara) : Sil.hpara = +let hpara_partial_join tenv (hpara1 : Predicates.hpara) (hpara2 : Predicates.hpara) : + Predicates.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara2 - else (L.d_strln "failure reason 53" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 53" ; raise Predicates.JoinFail) -let hpara_partial_meet tenv (hpara1 : Sil.hpara) (hpara2 : Sil.hpara) : Sil.hpara = +let hpara_partial_meet tenv (hpara1 : Predicates.hpara) (hpara2 : Predicates.hpara) : + Predicates.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara1 - else (L.d_strln "failure reason 54" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 54" ; raise Predicates.JoinFail) -let hpara_dll_partial_join tenv (hpara1 : Sil.hpara_dll) (hpara2 : Sil.hpara_dll) : Sil.hpara_dll = +let hpara_dll_partial_join tenv (hpara1 : Predicates.hpara_dll) (hpara2 : Predicates.hpara_dll) : + Predicates.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara2 - else (L.d_strln "failure reason 55" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 55" ; raise Predicates.JoinFail) -let hpara_dll_partial_meet tenv (hpara1 : Sil.hpara_dll) (hpara2 : Sil.hpara_dll) : Sil.hpara_dll = +let hpara_dll_partial_meet tenv (hpara1 : Predicates.hpara_dll) (hpara2 : Predicates.hpara_dll) : + Predicates.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara1 - else (L.d_strln "failure reason 56" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 56" ; raise Predicates.JoinFail) (** {2 Join and Meet for hpred} *) -let hpred_partial_join tenv mode (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hpred) - (hpred2 : Sil.hpred) : Sil.hpred = +let hpred_partial_join tenv mode (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Predicates.hpred) + (hpred2 : Predicates.hpred) : Predicates.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with - | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) -> + | Hpointsto (_, se1, te1), Hpointsto (_, se2, te2) -> let te = exp_partial_join te1 te2 in Prop.mk_ptsto tenv e (strexp_partial_join mode se1 se2) te - | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) -> + | Hlseg (k1, hpara1, _, next1, shared1), Hlseg (k2, hpara2, _, next2, shared2) -> let hpara' = hpara_partial_join tenv hpara1 hpara2 in let next' = exp_partial_join next1 next2 in let shared' = exp_list_partial_join shared1 shared2 in Prop.mk_lseg tenv (kind_join k1 k2) hpara' e next' shared' - | ( Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) - , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> + | ( Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) + , Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> let fwd1 = Exp.equal e1 iF1 in let fwd2 = Exp.equal e2 iF2 in let hpara' = hpara_dll_partial_join tenv para1 para2 in let iF', iB' = if fwd1 && fwd2 then (e, exp_partial_join iB1 iB2) else if (not fwd1) && not fwd2 then (exp_partial_join iF1 iF2, e) - else (L.d_strln "failure reason 57" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 57" ; raise Predicates.JoinFail) in let oF' = exp_partial_join oF1 oF2 in let oB' = exp_partial_join oB1 oB2 in @@ -1337,28 +1337,28 @@ let hpred_partial_join tenv mode (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hp assert false -let hpred_partial_meet tenv (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) - : Sil.hpred = +let hpred_partial_meet tenv (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Predicates.hpred) + (hpred2 : Predicates.hpred) : Predicates.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with - | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Exp.equal te1 te2 -> + | Hpointsto (_, se1, te1), Hpointsto (_, se2, te2) when Exp.equal te1 te2 -> Prop.mk_ptsto tenv e (strexp_partial_meet se1 se2) te1 - | Sil.Hpointsto _, _ | _, Sil.Hpointsto _ -> - L.d_strln "failure reason 58" ; raise Sil.JoinFail - | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) -> + | Hpointsto _, _ | _, Hpointsto _ -> + L.d_strln "failure reason 58" ; raise Predicates.JoinFail + | Hlseg (k1, hpara1, _, next1, shared1), Hlseg (k2, hpara2, _, next2, shared2) -> let hpara' = hpara_partial_meet tenv hpara1 hpara2 in let next' = exp_partial_meet next1 next2 in let shared' = exp_list_partial_meet shared1 shared2 in Prop.mk_lseg tenv (kind_meet k1 k2) hpara' e next' shared' - | ( Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) - , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> + | ( Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) + , Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> let fwd1 = Exp.equal e1 iF1 in let fwd2 = Exp.equal e2 iF2 in let hpara' = hpara_dll_partial_meet tenv para1 para2 in let iF', iB' = if fwd1 && fwd2 then (e, exp_partial_meet iB1 iB2) else if (not fwd1) && not fwd2 then (exp_partial_meet iF1 iF2, e) - else (L.d_strln "failure reason 59" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 59" ; raise Predicates.JoinFail) in let oF' = exp_partial_meet oF1 oF2 in let oB' = exp_partial_meet oB1 oB2 in @@ -1370,16 +1370,17 @@ let hpred_partial_meet tenv (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hpred) (** {2 Join and Meet for Sigma} *) -let find_hpred_by_address tenv (e : Exp.t) (sigma : Prop.sigma) : Sil.hpred option * Prop.sigma = +let find_hpred_by_address tenv (e : Exp.t) (sigma : Prop.sigma) : + Predicates.hpred option * Prop.sigma = let is_root_for_e e' = match Prover.is_root tenv Prop.prop_emp e' e with None -> false | Some _ -> true in let contains_e = function - | Sil.Hpointsto (e', _, _) -> + | Predicates.Hpointsto (e', _, _) -> is_root_for_e e' - | Sil.Hlseg (_, _, e', _, _) -> + | Predicates.Hlseg (_, _, e', _, _) -> is_root_for_e e' - | Sil.Hdllseg (_, _, iF, _, _, iB, _) -> + | Predicates.Hdllseg (_, _, iF, _, _, iB, _) -> is_root_for_e iF || is_root_for_e iB in let rec f sigma_acc = function @@ -1392,13 +1393,13 @@ let find_hpred_by_address tenv (e : Exp.t) (sigma : Prop.sigma) : Sil.hpred opti f [] sigma -let same_pred (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : bool = +let same_pred (hpred1 : Predicates.hpred) (hpred2 : Predicates.hpred) : bool = match (hpred1, hpred2) with - | Sil.Hpointsto _, Sil.Hpointsto _ -> + | Hpointsto _, Hpointsto _ -> true - | Sil.Hlseg _, Sil.Hlseg _ -> + | Hlseg _, Hlseg _ -> true - | Sil.Hdllseg _, Sil.Hdllseg _ -> + | Hdllseg _, Hdllseg _ -> true | _ -> false @@ -1425,20 +1426,20 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop let lookup_and_expand side e e' = match (Rename.get_others side e, side) with | None, _ -> - L.d_strln "failure reason 60" ; raise Sil.JoinFail + L.d_strln "failure reason 60" ; raise Predicates.JoinFail | Some (e_res, e_op), Lhs -> (e_res, exp_partial_join e' e_op) | Some (e_res, e_op), Rhs -> (e_res, exp_partial_join e_op e') in - let join_list_and_non side root' hlseg e opposite = - match hlseg with - | Sil.Hlseg (_, hpara, root, next, shared) -> + let join_list_and_non side root' hlseg e opposite : Predicates.hpred = + match (hlseg : Predicates.hpred) with + | Hlseg (_, hpara, root, next, shared) -> let next' = do_side side exp_partial_join next opposite in let shared' = Rename.lookup_list side shared in CheckJoin.add side root next ; - Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') - | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iF e -> + Hlseg (Lseg_PE, hpara, root', next', shared') + | Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iF e -> let oF' = do_side side exp_partial_join oF opposite in let shared' = Rename.lookup_list side shared in let oB', iB' = lookup_and_expand side oB iB in @@ -1448,8 +1449,8 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop *) CheckJoin.add side iF oF ; CheckJoin.add side oB iB ; - Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared') - | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iB e -> + Hdllseg (Lseg_PE, hpara, root', oB', oF', iB', shared') + | Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iB e -> let oB' = do_side side exp_partial_join oB opposite in let shared' = Rename.lookup_list side shared in let oF', iF' = lookup_and_expand side oF iF in @@ -1459,25 +1460,25 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop *) CheckJoin.add side iF oF ; CheckJoin.add side oB iB ; - Sil.Hdllseg (Sil.Lseg_PE, hpara, iF', oB', oF', root', shared') + Hdllseg (Lseg_PE, hpara, iF', oB', oF', root', shared') | _ -> assert false in - let update_list side lseg root' = - match lseg with - | Sil.Hlseg (k, hpara, _, next, shared) -> + let update_list side lseg root' : Predicates.hpred = + match (lseg : Predicates.hpred) with + | Hlseg (k, hpara, _, next, shared) -> let next' = Rename.lookup side next and shared' = Rename.lookup_list_todo side shared in - Sil.Hlseg (k, hpara, root', next', shared') + Hlseg (k, hpara, root', next', shared') | _ -> assert false in - let update_dllseg side dllseg iF iB = - match dllseg with - | Sil.Hdllseg (k, hpara, _, oB, oF, _, shared) -> + let update_dllseg side dllseg iF iB : Predicates.hpred = + match (dllseg : Predicates.hpred) with + | Hdllseg (k, hpara, _, oB, oF, _, shared) -> let oB' = Rename.lookup side oB and oF' = Rename.lookup side oF and shared' = Rename.lookup_list_todo side shared in - Sil.Hdllseg (k, hpara, iF, oB', oF', iB, shared') + Hdllseg (k, hpara, iF, oB', oF', iB, shared') | _ -> assert false in @@ -1485,7 +1486,9 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop 'side' describes that target is Lhs or Rhs. 'todo' describes the start point. *) let cut_sigma side todo (target : Prop.sigma) (other : Prop.sigma) = - let list_is_empty l = if l <> [] then (L.d_strln "failure reason 61" ; raise Sil.JoinFail) in + let list_is_empty l = + if l <> [] then (L.d_strln "failure reason 61" ; raise Predicates.JoinFail) + in let x = Todo.take () in Todo.push todo ; let res = @@ -1504,17 +1507,17 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop Todo.set x ; res in let cut_lseg side todo lseg sigma = - match lseg with - | Sil.Hlseg (_, hpara, root, next, shared) -> - let _, sigma_lseg = Sil.hpara_instantiate hpara root next shared in + match (lseg : Predicates.hpred) with + | Hlseg (_, hpara, root, next, shared) -> + let _, sigma_lseg = Predicates.hpara_instantiate hpara root next shared in cut_sigma side todo sigma_lseg sigma | _ -> assert false in let cut_dllseg side todo root lseg sigma = - match lseg with - | Sil.Hdllseg (_, hpara, _, oB, oF, _, shared) -> - let _, sigma_dllseg = Sil.hpara_dll_instantiate hpara root oB oF shared in + match (lseg : Predicates.hpred) with + | Hdllseg (_, hpara, _, oB, oF, _, shared) -> + let _, sigma_dllseg = Predicates.hpara_dll_instantiate hpara root oB oF shared in cut_sigma side todo sigma_dllseg sigma | _ -> assert false @@ -1543,39 +1546,40 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop match (hpred_opt1, hpred_opt2) with | None, None -> sigma_partial_join' tenv mode sigma_acc sigma1 sigma2 - | Some (Sil.Hlseg (k, _, _, _, _) as lseg), None - | Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg), None -> - if (not Config.nelseg) || Sil.equal_lseg_kind k Sil.Lseg_PE then + | Some (Predicates.Hlseg (k, _, _, _, _) as lseg), None + | Some (Predicates.Hdllseg (k, _, _, _, _, _, _) as lseg), None -> + if (not Config.nelseg) || Predicates.equal_lseg_kind k Lseg_PE then let sigma_acc' = join_list_and_non Lhs e lseg e1 e2 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 - else (L.d_strln "failure reason 62" ; raise Sil.JoinFail) - | None, Some (Sil.Hlseg (k, _, _, _, _) as lseg) - | None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) -> - if (not Config.nelseg) || Sil.equal_lseg_kind k Sil.Lseg_PE then + else (L.d_strln "failure reason 62" ; raise Predicates.JoinFail) + | None, Some (Predicates.Hlseg (k, _, _, _, _) as lseg) + | None, Some (Predicates.Hdllseg (k, _, _, _, _, _, _) as lseg) -> + if (not Config.nelseg) || Predicates.equal_lseg_kind k Lseg_PE then let sigma_acc' = join_list_and_non Rhs e lseg e2 e1 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 - else (L.d_strln "failure reason 63" ; raise Sil.JoinFail) + else (L.d_strln "failure reason 63" ; raise Predicates.JoinFail) | None, _ | _, None -> - L.d_strln "failure reason 64" ; raise Sil.JoinFail + L.d_strln "failure reason 64" ; raise Predicates.JoinFail | Some hpred1, Some hpred2 when same_pred hpred1 hpred2 -> let hpred_res1 = hpred_partial_join tenv mode todo_curr hpred1 hpred2 in sigma_partial_join' tenv mode (hpred_res1 :: sigma_acc) sigma1 sigma2 - | Some (Sil.Hlseg _ as lseg), Some hpred2 -> + | Some (Predicates.Hlseg _ as lseg), Some hpred2 -> let sigma2' = cut_lseg Lhs todo_curr lseg (hpred2 :: sigma2) in let sigma_acc' = update_list Lhs lseg e :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' - | Some hpred1, Some (Sil.Hlseg _ as lseg) -> + | Some hpred1, Some (Predicates.Hlseg _ as lseg) -> let sigma1' = cut_lseg Rhs todo_curr lseg (hpred1 :: sigma1) in let sigma_acc' = update_list Rhs lseg e :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 when Exp.equal e1 iF1 -> + | Some (Predicates.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 + when Exp.equal e1 iF1 -> let iB_res = exp_partial_join iB1 e2 in let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2 :: sigma2) in let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in CheckJoin.add Lhs iF1 iB1 ; (* add equality iF1=iB1 *) sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' - | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 + | Some (Predicates.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 (* when Exp.equal e1 iB1 *) -> let iF_res = exp_partial_join iF1 e2 in let sigma2' = cut_dllseg Lhs todo_curr iB1 dllseg (hpred2 :: sigma2) in @@ -1583,28 +1587,29 @@ let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop CheckJoin.add Lhs iF1 iB1 ; (* add equality iF1=iB1 *) sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' - | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) when Exp.equal e2 iF2 -> + | Some hpred1, Some (Predicates.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) + when Exp.equal e2 iF2 -> let iB_res = exp_partial_join e1 iB2 in let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1 :: sigma1) in let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in CheckJoin.add Rhs iF2 iB2 ; (* add equality iF2=iB2 *) sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) -> + | Some hpred1, Some (Predicates.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) -> let iF_res = exp_partial_join e1 iF2 in let sigma1' = cut_dllseg Rhs todo_curr iB2 dllseg (hpred1 :: sigma1) in let sigma_acc' = update_dllseg Rhs dllseg iF_res e :: sigma_acc in CheckJoin.add Rhs iF2 iB2 ; (* add equality iF2=iB2 *) sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some (Sil.Hpointsto _), Some (Sil.Hpointsto _) -> + | Some (Predicates.Hpointsto _), Some (Predicates.Hpointsto _) -> assert false (* Should be handled by a guarded case *) with Todo.Empty -> ( match (sigma1_in, sigma2_in) with | _ :: _, _ :: _ -> L.d_strln "todo is empty, but the sigmas are not" ; - raise Sil.JoinFail + raise Predicates.JoinFail | _ -> (sigma_acc, sigma1_in, sigma2_in) ) @@ -1617,7 +1622,7 @@ let sigma_partial_join tenv mode (sigma1 : Prop.sigma) (sigma2 : Prop.sigma) : SymOp.try_finally ~f:(fun () -> if Rename.check lost_little then (s1, s2, s3) - else (L.d_strln "failed Rename.check" ; raise Sil.JoinFail) ) + else (L.d_strln "failed Rename.check" ; raise Predicates.JoinFail) ) ~finally:CheckJoin.final @@ -1658,14 +1663,14 @@ let rec sigma_partial_meet' tenv (sigma_acc : Prop.sigma) (sigma1_in : Prop.sigm let hpred' = hpred_partial_meet tenv todo_curr hpred1 hpred2 in sigma_partial_meet' tenv (hpred' :: sigma_acc) sigma1 sigma2 | Some _, Some _ -> - L.d_strln "failure reason 65" ; raise Sil.JoinFail + L.d_strln "failure reason 65" ; raise Predicates.JoinFail with Todo.Empty -> ( match (sigma1_in, sigma2_in) with | [], [] -> sigma_acc | _, _ -> L.d_strln "todo is empty, but the sigmas are not" ; - raise Sil.JoinFail ) + raise Predicates.JoinFail ) let sigma_partial_meet tenv (sigma1 : Prop.sigma) (sigma2 : Prop.sigma) : Prop.sigma = @@ -1689,7 +1694,7 @@ let pi_partial_join tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Pr (* find some array length in the prop, to be used as heuritic for upper bound in widening *) let len_list = ref [] in let do_hpred = function - | Sil.Hpointsto (_, Sil.Earray (Exp.Const (Const.Cint n), _, _), _) -> + | Predicates.Hpointsto (_, Earray (Exp.Const (Const.Cint n), _, _), _) -> if IntLit.geq n IntLit.one then len_list := n :: !len_list | _ -> () @@ -1747,17 +1752,17 @@ let pi_partial_join tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Pr let not_a = Prover.atom_negate tenv a in if Prover.check_atom tenv p not_a then ( L.d_str "join_atom_check failed on " ; - Sil.d_atom a ; + Predicates.d_atom a ; L.d_ln () ; - raise Sil.JoinFail ) + raise Predicates.JoinFail ) in let join_atom_check_attribute p a = (* check for attribute: fail if the attribute is not in the other side *) if not (Prover.check_atom tenv p a) then ( L.d_str "join_atom_check_attribute failed on " ; - Sil.d_atom a ; + Predicates.d_atom a ; L.d_ln () ; - raise Sil.JoinFail ) + raise Predicates.JoinFail ) in let join_atom side p_op pi_op a = (* try to find the atom corresponding to a on the other side, and check if it is implied *) @@ -1805,7 +1810,7 @@ let pi_partial_join tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Pr List.fold ~f:(handle_atom_with_widening Rhs p1 pi1) ~init:[] pi2 in if Config.trace_join then (L.d_str "atom_list2: " ; Prop.d_pi atom_list2 ; L.d_ln ()) ; - let atom_list_combined = IList.inter ~cmp:Sil.compare_atom atom_list1 atom_list2 in + let atom_list_combined = IList.inter ~cmp:Predicates.compare_atom atom_list1 atom_list2 in if Config.trace_join then ( L.d_str "atom_list_combined: " ; Prop.d_pi atom_list_combined ; L.d_ln () ) ; atom_list_combined @@ -1815,12 +1820,16 @@ let pi_partial_meet tenv (p : Prop.normal Prop.t) (ep1 : 'a Prop.t) (ep2 : 'b Pr Prop.normal Prop.t = let sub1 = Rename.to_subst_emb Lhs in let sub2 = Rename.to_subst_emb Rhs in - let dom1 = Ident.idlist_to_idset (Sil.sub_domain sub1) in - let dom2 = Ident.idlist_to_idset (Sil.sub_domain sub2) in + let dom1 = Ident.idlist_to_idset (Predicates.sub_domain sub1) in + let dom2 = Ident.idlist_to_idset (Predicates.sub_domain sub2) in let handle_atom sub dom atom = - if Sil.atom_free_vars atom |> Sequence.for_all ~f:(fun id -> Ident.Set.mem id dom) then - Sil.atom_sub sub atom - else (L.d_str "handle_atom failed on " ; Sil.d_atom atom ; L.d_ln () ; raise Sil.JoinFail) + if Predicates.atom_free_vars atom |> Sequence.for_all ~f:(fun id -> Ident.Set.mem id dom) then + Predicates.atom_sub sub atom + else ( + L.d_str "handle_atom failed on " ; + Predicates.d_atom atom ; + L.d_ln () ; + raise Predicates.JoinFail ) in let f1 p' atom = Prop.prop_atom_and tenv p' (handle_atom sub1 dom1 atom) in let f2 p' atom = Prop.prop_atom_and tenv p' (handle_atom sub2 dom2 atom) in @@ -1832,7 +1841,7 @@ let pi_partial_meet tenv (p : Prop.normal Prop.t) (ep1 : 'a Prop.t) (ep2 : 'b Pr let p_pi3 = List.fold ~f:f3 ~init:p_pi2 (Rename.get_unify_eqs ()) in if Prover.check_inconsistency_base tenv p_pi3 then ( L.d_strln "check_inconsistency_base failed" ; - raise Sil.JoinFail ) + raise Predicates.JoinFail ) else p_pi3 @@ -1849,11 +1858,11 @@ let eprop_partial_meet tenv (ep1 : 'a Prop.t) (ep2 : 'b Prop.t) : 'c Prop.t = let sub_check _ = let sub1 = ep1.Prop.sub in let sub2 = ep2.Prop.sub in - let range1 = Sil.sub_range sub1 in + let range1 = Predicates.sub_range sub1 in let f e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in - Sil.equal_subst sub1 sub2 && List.for_all ~f range1 + Predicates.equal_subst sub1 sub2 && List.for_all ~f range1 in - if not (sub_check ()) then (L.d_strln "sub_check() failed" ; raise Sil.JoinFail) + if not (sub_check ()) then (L.d_strln "sub_check() failed" ; raise Predicates.JoinFail) else let todos = List.map ~f:(fun x -> (x, x, x)) es in List.iter ~f:Todo.push todos ; @@ -1874,7 +1883,7 @@ let prop_partial_meet tenv p1 p2 = SymOp.try_finally ~f:(fun () -> Some (eprop_partial_meet tenv p1 p2)) ~finally:(fun () -> Rename.final () ; FreshVarExp.final () ; Todo.final ()) - with Sil.JoinFail -> None + with Predicates.JoinFail -> None let eprop_partial_join' tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Prop.t) : @@ -1898,14 +1907,14 @@ let eprop_partial_join' tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.expose let sub_common, eqs_from_sub1, eqs_from_sub2 = let sub1 = ep1.Prop.sub in let sub2 = ep2.Prop.sub in - let sub_common, sub1_only, sub2_only = Sil.sub_symmetric_difference sub1 sub2 in + let sub_common, sub1_only, sub2_only = Predicates.sub_symmetric_difference sub1 sub2 in let sub_common_normal, sub_common_other = let f e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in - Sil.sub_range_partition f sub_common + Predicates.sub_range_partition f sub_common in let eqs1, eqs2 = let sub_to_eqs sub = - List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list sub) + List.map ~f:(fun (id, e) -> Predicates.Aeq (Exp.Var id, e)) (Predicates.sub_to_list sub) in let eqs1 = sub_to_eqs sub1_only @ sub_to_eqs sub_common_other in let eqs2 = sub_to_eqs sub2_only in @@ -1915,7 +1924,7 @@ let eprop_partial_join' tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.expose in if not (simple_check && expensive_check es1 es2) then ( if not simple_check then L.d_strln "simple_check failed" else L.d_strln "expensive_check failed" ; - raise Sil.JoinFail ) ; + raise Predicates.JoinFail ) ; let todos = List.map ~f:(fun x -> (x, x, x)) es1 in List.iter ~f:Todo.push todos ; match sigma_partial_join tenv mode sigma1 sigma2 with @@ -1937,7 +1946,7 @@ let eprop_partial_join' tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.expose in p_sub_sigma_pi | _ -> - L.d_strln "leftovers not empty" ; raise Sil.JoinFail + L.d_strln "leftovers not empty" ; raise Predicates.JoinFail let footprint_partial_join' tenv (p1 : Prop.normal Prop.t) (p2 : Prop.normal Prop.t) : @@ -1949,13 +1958,15 @@ let footprint_partial_join' tenv (p1 : Prop.normal Prop.t) (p2 : Prop.normal Pro let efp = eprop_partial_join' tenv JoinState.Pre fp1 fp2 in let pi_fp = let pi_fp0 = Prop.get_pure efp in - let f a = Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint in + let f a = Predicates.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint in List.filter ~f pi_fp0 in let sigma_fp = let sigma_fp0 = efp.Prop.sigma in - let f a = Sil.hpred_free_vars a |> Sequence.exists ~f:(fun a -> not (Ident.is_footprint a)) in - if List.exists ~f sigma_fp0 then (L.d_strln "failure reason 66" ; raise Sil.JoinFail) ; + let f a = + Predicates.hpred_free_vars a |> Sequence.exists ~f:(fun a -> not (Ident.is_footprint a)) + in + if List.exists ~f sigma_fp0 then (L.d_strln "failure reason 66" ; raise Predicates.JoinFail) ; sigma_fp0 in let ep1' = Prop.set p1 ~pi_fp ~sigma_fp in @@ -1986,7 +1997,7 @@ let prop_partial_join pname tenv mode p1 p2 = if !BiabductionConfig.footprint then JoinState.set_footprint false ; Some res ) ~finally:(fun () -> Rename.final () ; FreshVarExp.final () ; Todo.final ()) - with Sil.JoinFail -> None ) + with Predicates.JoinFail -> None ) | Some _ -> res_by_implication_only @@ -2057,7 +2068,7 @@ let jprop_partial_join tenv mode jp1 jp2 = let p = eprop_partial_join tenv mode p1 p2 in let p_renamed = Prop.prop_rename_primed_footprint_vars tenv p in Some (BiabductionSummary.Jprop.Joined (0, p_renamed, jp1, jp2)) - with Sil.JoinFail -> None + with Predicates.JoinFail -> None let jplist_collapse tenv mode jplist = diff --git a/infer/src/biabduction/DotBiabduction.ml b/infer/src/biabduction/DotBiabduction.ml index 8cdfe2611..0025de884 100644 --- a/infer/src/biabduction/DotBiabduction.ml +++ b/infer/src/biabduction/DotBiabduction.ml @@ -53,15 +53,22 @@ type dotty_node = (* Dotpointsto(coo,e,c): basic memory cell box for expression e at coordinate coo and color c *) | Dotpointsto of coordinate * Exp.t * string (* Dotstruct(coo,e,l,c): struct box for expression e with field list l at coordinate coo and color c *) - | Dotstruct of coordinate * Exp.t * (Typ.Fieldname.t * Sil.strexp) list * string * Exp.t + | Dotstruct of coordinate * Exp.t * (Typ.Fieldname.t * Predicates.strexp) list * string * Exp.t (* Dotarray(coo,e1,e2,l,t,c): array box for expression e1 with field list l at coordinate coo and color c*) (* e2 is the len and t is the type *) - | Dotarray of coordinate * Exp.t * Exp.t * (Exp.t * Sil.strexp) list * Typ.t * string + | Dotarray of coordinate * Exp.t * Exp.t * (Exp.t * Predicates.strexp) list * Typ.t * string (* Dotlseg(coo,e1,e2,k,h,c): list box from e1 to e2 at coordinate coo and color c*) - | Dotlseg of coordinate * Exp.t * Exp.t * Sil.lseg_kind * Sil.hpred list * string + | Dotlseg of coordinate * Exp.t * Exp.t * Predicates.lseg_kind * Predicates.hpred list * string (* Dotlseg(coo,e1,e2,e3,e4,k,h,c): doubly linked-list box from with parameters (e1,e2,e3,e4) at coordinate coo and color c*) | Dotdllseg of - coordinate * Exp.t * Exp.t * Exp.t * Exp.t * Sil.lseg_kind * Sil.hpred list * string + coordinate + * Exp.t + * Exp.t + * Exp.t + * Exp.t + * Predicates.lseg_kind + * Predicates.hpred list + * string let mk_coordinate i l = {id= i; lambda= l} @@ -126,16 +133,16 @@ let strip_special_chars b = let rec strexp_to_string pe coo f se = - match se with - | Sil.Eexp (Exp.Lvar pvar, _) -> + match (se : Predicates.strexp) with + | Eexp (Exp.Lvar pvar, _) -> (Pvar.pp pe) f pvar - | Sil.Eexp (Exp.Var id, _) -> + | Eexp (Exp.Var id, _) -> if !print_full_prop then Ident.pp f id else () - | Sil.Eexp (e, _) -> + | Eexp (e, _) -> if !print_full_prop then (Exp.pp_diff pe) f e else F.pp_print_char f '_' - | Sil.Estruct (ls, _) -> + | Estruct (ls, _) -> F.fprintf f " STRUCT | { %a } " (struct_to_dotty_str pe coo) ls - | Sil.Earray (e, idx, _) -> + | Earray (e, idx, _) -> F.fprintf f " ARRAY[%a] | { %a } " (Exp.pp_diff pe) e (get_contents pe coo) idx @@ -152,14 +159,14 @@ and struct_to_dotty_str pe coo f ls : unit = and get_contents_sexp pe coo f se = - match se with - | Sil.Eexp (e', _) -> + match (se : Predicates.strexp) with + | Eexp (e', _) -> (Exp.pp_diff pe) f e' - | Sil.Estruct (se', _) -> + | Estruct (se', _) -> F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se' - | Sil.Earray (e', [], _) -> + | Earray (e', [], _) -> F.fprintf f "(ARRAY Size: %a) | { }" (Exp.pp_diff pe) e' - | Sil.Earray (e', (idx, a) :: linner, _) -> + | Earray (e', (idx, a) :: linner, _) -> F.fprintf f "(ARRAY Size: %a) | { %a: %a | %a }" (Exp.pp_diff pe) e' (Exp.pp_diff pe) idx (strexp_to_string pe coo) a (get_contents pe coo) linner @@ -257,7 +264,7 @@ let color_to_str (c : Pp.color) = "red" -let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) list) = +let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Predicates.hpred * int) list) = let exp_color hpred (exp : Exp.t) = if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red else pe.Pp.cmap_norm (Obj.repr exp) @@ -266,21 +273,21 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis let n = !dotty_state_count in incr dotty_state_count ; let coo = mk_coordinate n lambda in - match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop -> + match (hpred : Predicates.hpred) with + | Hpointsto (_, Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop -> let e_color_str = color_to_str (exp_color hpred e) in [Dotdangling (coo, e, e_color_str)] - | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> + | Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> let e2_color_str = color_to_str (exp_color hpred e2) in [Dotdangling (coo, e2, e2_color_str)] - | Sil.Hdllseg (_, _, _, e2, e3, _, _) -> + | Hdllseg (_, _, _, e2, e3, _, _) -> let e2_color_str = color_to_str (exp_color hpred e2) in let e3_color_str = color_to_str (exp_color hpred e3) in let ll = if not (Exp.equal e2 Exp.zero) then [Dotdangling (coo, e2, e2_color_str)] else [] in if not (Exp.equal e3 Exp.zero) then Dotdangling (coo, e3, e3_color_str) :: ll else ll - | Sil.Hpointsto (_, _, _) | _ -> + | Hpointsto (_, _, _) | _ -> [] (* arrays and struct do not give danglings*) in @@ -329,36 +336,36 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis let rec dotty_mk_node pe sigma = let n = !dotty_state_count in incr dotty_state_count ; - let do_hpred_lambda exp_color = function - | ( Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}}) - , lambda ) -> + let do_hpred_lambda exp_color (hpred : Predicates.hpred) lambda = + match (hpred, lambda) with + | Hpointsto (e, Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray {elt= t}}}), lambda -> incr dotty_state_count ; (* increment once more n+1 is the box for the array *) let e_color_str = color_to_str (exp_color e) in let e_color_str' = color_to_str (exp_color e') in [ Dotpointsto (mk_coordinate n lambda, e, e_color_str) ; Dotarray (mk_coordinate (n + 1) lambda, e, e', l, t, e_color_str') ] - | Sil.Hpointsto (e, Sil.Estruct (l, _), te), lambda -> + | Hpointsto (e, Estruct (l, _), te), lambda -> incr dotty_state_count ; (* increment once more n+1 is the box for the struct *) let e_color_str = color_to_str (exp_color e) in (* [Dotpointsto((mk_coordinate n lambda), e, l, true, e_color_str)] *) [ Dotpointsto (mk_coordinate n lambda, e, e_color_str) ; Dotstruct (mk_coordinate (n + 1) lambda, e, l, e_color_str, te) ] - | Sil.Hpointsto (e, _, _), lambda -> + | Hpointsto (e, _, _), lambda -> let e_color_str = color_to_str (exp_color e) in if List.mem ~equal:Exp.equal !struct_exp_nodes e then [] else [Dotpointsto (mk_coordinate n lambda, e, e_color_str)] - | Sil.Hlseg (k, hpara, e1, e2, _), lambda -> + | Hlseg (k, hpara, e1, e2, _), lambda -> incr dotty_state_count ; (* increment once more n+1 is the box for last element of the list *) let eq_color_str = color_to_str (exp_color e1) in - [Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.Sil.body, eq_color_str)] - | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda -> + [Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.body, eq_color_str)] + | Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda -> let e1_color_str = color_to_str (exp_color e1) in incr dotty_state_count ; (* increment once more n+1 is the box for e4 *) - [Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str)] + [Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.body_dll, e1_color_str)] in match sigma with | [] -> @@ -368,12 +375,12 @@ let rec dotty_mk_node pe sigma = if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red else pe.Pp.cmap_norm (Obj.repr exp) in - do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma' + do_hpred_lambda exp_color hpred lambda @ dotty_mk_node pe sigma' let set_exps_neq_zero pi = let f = function - | Sil.Aneq (e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> + | Predicates.Aneq (e, Const (Cint i)) when IntLit.iszero i -> exps_neq_zero := e :: !exps_neq_zero | _ -> () @@ -403,19 +410,19 @@ let make_nil_node lambda = let compute_fields_struct sigma = fields_structs := [] ; let rec do_strexp se in_struct = - match se with - | Sil.Eexp (e, _) -> + match (se : Predicates.strexp) with + | Eexp (e, _) -> if in_struct then fields_structs := e :: !fields_structs else () - | Sil.Estruct (l, _) -> + | Estruct (l, _) -> List.iter ~f:(fun e -> do_strexp e true) (snd (List.unzip l)) - | Sil.Earray (_, l, _) -> + | Earray (_, l, _) -> List.iter ~f:(fun e -> do_strexp e false) (snd (List.unzip l)) in let rec fs s = match s with | [] -> () - | Sil.Hpointsto (_, se, _) :: s' -> + | Predicates.Hpointsto (_, se, _) :: s' -> do_strexp se false ; fs s' | _ :: s' -> fs s' @@ -429,7 +436,7 @@ let compute_struct_exp_nodes sigma = match s with | [] -> () - | Sil.Hpointsto (e, Sil.Estruct _, _) :: s' -> + | Predicates.Hpointsto (e, Estruct _, _) :: s' -> struct_exp_nodes := e :: !struct_exp_nodes ; sen s' | _ :: s' -> @@ -449,7 +456,7 @@ let in_cycle cycle edge = | Some cycle' -> let fn, se = edge in List.exists - ~f:(fun (_, fn', se') -> Typ.Fieldname.equal fn fn' && Sil.equal_strexp se se') + ~f:(fun (_, fn', se') -> Typ.Fieldname.equal fn fn' && Predicates.equal_strexp se se') cycle' | _ -> false @@ -467,8 +474,8 @@ let node_in_cycle cycle node = (* compute a list of (kind of link, field name, coo.id target, name_target) *) let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = let find_target_one_fld (fn, se) = - match se with - | Sil.Eexp (e, _) -> ( + match (se : Predicates.strexp) with + | Eexp (e, _) -> ( if is_nil e p then let n' = make_nil_node lambda in if !print_full_prop then [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] else [] @@ -495,9 +502,9 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = (* by construction there must be at most 2 nodes for an expression*) L.internal_error "@\n Too many nodes! Error! @\n@." ; assert false ) - | Sil.Estruct (_, _) -> + | Estruct (_, _) -> [] (* inner struct are printed by print_struc function *) - | Sil.Earray _ -> + | Earray _ -> [] (* inner arrays are printed by print_array function *) in @@ -512,8 +519,8 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = (* compute a list of (kind of link, field name, coo.id target, name_target) *) let rec compute_target_array_elements dotnodes list_elements p f lambda = let find_target_one_element (idx, se) = - match se with - | Sil.Eexp (e, _) -> ( + match (se : Predicates.strexp) with + | Eexp (e, _) -> ( if is_nil e p then let n' = make_nil_node lambda in [(LinkArrayToExp, Exp.to_string idx, n', "")] @@ -536,9 +543,9 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda = (* by construction there must be at most 2 nodes for an expression*) L.internal_error "@\nToo many nodes! Error!@\n@." ; assert false ) - | Sil.Estruct (_, _) -> + | Estruct (_, _) -> [] (* inner struct are printed by print_struc function *) - | Sil.Earray _ -> + | Earray _ -> [] (* inner arrays are printed by print_array function *) in @@ -595,9 +602,9 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = match sigma with | [] -> [] - | (Sil.Hpointsto (e, Sil.Earray (_, lie, _), _), lambda) :: sigma' -> + | (Predicates.Hpointsto (e, Earray (_, lie, _), _), lambda) :: sigma' -> make_links_for_arrays e lie lambda sigma' - | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda) :: sigma' -> ( + | (Predicates.Hpointsto (e, Estruct (lfld, _), _), lambda) :: sigma' -> ( let src = look_up dotnodes e lambda in match src with | [] -> @@ -630,7 +637,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = in lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' -> ( + | (Predicates.Hpointsto (e, Eexp (e', _), _), lambda) :: sigma' -> ( let src = look_up dotnodes e lambda in match src with | [] -> @@ -648,7 +655,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = let ll = List.concat_map ~f:ff nl in ll @ dotty_mk_set_links dotnodes sigma' p f cycle else dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hlseg (_, _, e1, e2, _), lambda) :: sigma' -> ( + | (Predicates.Hlseg (_, _, e1, e2, _), lambda) :: sigma' -> ( let src = look_up dotnodes e1 lambda in match src with | [] -> @@ -659,7 +666,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in lnk :: dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> ( + | (Predicates.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> ( let src = look_up dotnodes e1 lambda in match src with | [] -> @@ -856,11 +863,11 @@ and print_sll f pe nesting k e1 coo = let lambda = coo.lambda in let n' = !dotty_state_count in incr dotty_state_count ; - ( match k with - | Sil.Lseg_NE -> + ( match (k : Predicates.lseg_kind) with + | Lseg_NE -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";" n' lambda "style=filled; color=lightgrey;" - | Sil.Lseg_PE -> + | Lseg_PE -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n' lambda "style=filled; color=lightgrey;" ) ; @@ -883,11 +890,11 @@ and print_dll f pe nesting k e1 e4 coo = let lambda = coo.lambda in let n' = !dotty_state_count in incr dotty_state_count ; - ( match k with - | Sil.Lseg_NE -> + ( match (k : Predicates.lseg_kind) with + | Lseg_NE -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' lambda "style=filled; color=lightgrey;" "doubly-linked list NE" - | Sil.Lseg_PE -> + | Lseg_PE -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' lambda "style=filled; color=lightgrey;" "doubly-linked list PE" ) ; F.fprintf f "state%iL%i [label=\"%a\"]@\n" n lambda (Exp.pp_diff pe) e1 ; @@ -927,14 +934,14 @@ and dotty_pp_state f pe cycle dotnode = print_struct f pe e1 te l' coo c | Dotarray (coo, e1, e2, l, _, c) when !print_full_prop -> print_array f pe e1 e2 l coo c - | Dotlseg (coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop -> - print_sll f pe nesting Sil.Lseg_NE e1 coo - | Dotlseg (coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop -> - print_sll f pe nesting Sil.Lseg_PE e1 coo - | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop -> - print_dll f pe nesting Sil.Lseg_NE e1 e4 coo - | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop -> - print_dll f pe nesting Sil.Lseg_PE e1 e4 coo + | Dotlseg (coo, e1, _, Lseg_NE, nesting, _) when !print_full_prop -> + print_sll f pe nesting Predicates.Lseg_NE e1 coo + | Dotlseg (coo, e1, _, Lseg_PE, nesting, _) when !print_full_prop -> + print_sll f pe nesting Predicates.Lseg_PE e1 coo + | Dotdllseg (coo, e1, _, _, e4, Lseg_NE, nesting, _) when !print_full_prop -> + print_dll f pe nesting Predicates.Lseg_NE e1 e4 coo + | Dotdllseg (coo, e1, _, _, e4, Lseg_PE, nesting, _) when !print_full_prop -> + print_dll f pe nesting Predicates.Lseg_PE e1 e4 coo | _ -> () diff --git a/infer/src/biabduction/Match.ml b/infer/src/biabduction/Match.ml index bb0d84ffa..a506647db 100644 --- a/infer/src/biabduction/Match.ml +++ b/infer/src/biabduction/Match.ml @@ -16,20 +16,20 @@ let mem_idlist i l = List.exists ~f:(Ident.equal i) l (** Type for a hpred pattern. flag=false means that the implication between hpreds is not considered, and flag = true means that it is considered during pattern matching *) -type hpred_pat = {hpred: Sil.hpred; flag: bool} +type hpred_pat = {hpred: Predicates.hpred; flag: bool} (** Checks [e1 = e2\[sub ++ sub'\]] for some [sub'] with [dom(sub') subseteq vars]. Returns [(sub ++ sub', vars - dom(sub'))]. *) -let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option = +let rec exp_match e1 sub vars e2 : (Predicates.subst * Ident.t list) option = let check_equal sub vars e1 e2 = - let e2_inst = Sil.exp_sub sub e2 in + let e2_inst = Predicates.exp_sub sub e2 in if Exp.equal e1 e2_inst then Some (sub, vars) else None in match (e1, e2) with | _, Exp.Var id2 when Ident.is_primed id2 && mem_idlist id2 vars -> let vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in let sub_new = - match Sil.extend_sub sub id2 e1 with + match Predicates.extend_sub sub id2 e1 with | None -> assert false (* happens when vars contains the same variable twice. *) | Some sub_new -> @@ -97,17 +97,18 @@ let exp_list_match es1 sub vars es2 = (** Checks [sexp1 = sexp2\[sub ++ sub'\]] for some [sub'] with [dom(sub') subseteq vars]. Returns [(sub ++ sub', vars - dom(sub'))]. WARNING: This function does not consider the fact that the analyzer sometimes forgets fields of hpred. It can possibly cause a problem. *) -let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option = +let rec strexp_match (sexp1 : Predicates.strexp) sub vars (sexp2 : Predicates.strexp) : + (Predicates.subst * Ident.t list) option = match (sexp1, sexp2) with - | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> + | Eexp (exp1, _), Eexp (exp2, _) -> exp_match exp1 sub vars exp2 - | Sil.Eexp _, _ | _, Sil.Eexp _ -> + | Eexp _, _ | _, Eexp _ -> None - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> + | Estruct (fsel1, _), Estruct (fsel2, _) -> fsel_match fsel1 sub vars fsel2 - | Sil.Estruct _, _ | _, Sil.Estruct _ -> + | Estruct _, _ | _, Estruct _ -> None - | Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> ( + | Earray (len1, isel1, _), Earray (len2, isel2, _) -> ( match exp_match len1 sub vars len2 with | Some (sub', vars') -> isel_match isel1 sub' vars' isel2 @@ -148,15 +149,15 @@ and isel_match isel1 sub vars isel2 = | [], _ | _, [] -> None | (idx1, se1') :: isel1', (idx2, se2') :: isel2' -> - let idx2 = Sil.exp_sub sub idx2 in + let idx2 = Predicates.exp_sub sub idx2 in let sanity_check = not (List.exists ~f:(fun id -> Exp.ident_mem idx2 id) vars) in if not sanity_check then ( let pe = Pp.text in L.internal_error "@[.... Sanity Check Failure while Matching Index-Strexps ....@\n" ; - L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Exp.pp_diff pe) idx1 (Sil.pp_sexp pe) - se1' ; + L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Exp.pp_diff pe) idx1 + (Predicates.pp_sexp pe) se1' ; L.internal_error "@[<4> IDX2: %a, STREXP2: %a@\n@." (Exp.pp_diff pe) idx2 - (Sil.pp_sexp pe) se2' ; + (Predicates.pp_sexp pe) se2' ; assert false ) else if Exp.equal idx1 idx2 then match strexp_match se1' sub vars se2' with @@ -168,13 +169,13 @@ and isel_match isel1 sub vars isel2 = (* extends substitution sub by creating a new substitution for vars *) -let sub_extend_with_ren (sub : Sil.subst) vars = +let sub_extend_with_ren (sub : Predicates.subst) vars = let f id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in - let renaming_for_vars = Sil.subst_of_list (List.map ~f vars) in - Sil.sub_join sub renaming_for_vars + let renaming_for_vars = Predicates.subst_of_list (List.map ~f vars) in + Predicates.sub_join sub renaming_for_vars -type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool +type sidecondition = Prop.normal Prop.t -> Predicates.subst -> bool let rec execute_with_backtracking = function | [] -> @@ -186,35 +187,33 @@ let rec execute_with_backtracking = function match res_f with None -> execute_with_backtracking fs | Some _ -> res_f ) -let rec instantiate_to_emp p condition (sub : Sil.subst) vars = function +let rec instantiate_to_emp p condition (sub : Predicates.subst) vars = function | [] -> if condition p sub then Some (sub, p) else None | hpat :: hpats -> ( if not hpat.flag then None else - match hpat.hpred with - | Sil.Hpointsto _ - | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) - | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> + match (hpat.hpred : Predicates.hpred) with + | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) -> None - | Sil.Hlseg (_, _, e1, e2, _) -> ( + | Hlseg (_, _, e1, e2, _) -> ( let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem e1 id) vars) in if not fully_instantiated then None else - let e1' = Sil.exp_sub sub e1 in + let e1' = Predicates.exp_sub sub e1 in match exp_match e1' sub vars e2 with | None -> None | Some (sub_new, vars_leftover) -> instantiate_to_emp p condition sub_new vars_leftover hpats ) - | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> ( + | Hdllseg (_, _, iF, oB, oF, iB, _) -> ( let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem iF id || Exp.ident_mem oB id) vars) in if not fully_instantiated then None else - let iF' = Sil.exp_sub sub iF in - let oB' = Sil.exp_sub sub oB in + let iF' = Predicates.exp_sub sub iF in + let oB' = Predicates.exp_sub sub oB in match exp_list_match [iF'; oB'] sub vars [oF; iB] with | None -> None @@ -268,7 +267,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = prop_match_with_impl_sub tenv p_rest condition sub_new vars_leftover hpat_next hpats_rest in let gen_filter_pointsto lexp2 strexp2 te2 = function - | Sil.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 -> ( + | Predicates.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 -> ( match exp_match lexp1 sub vars lexp2 with | None -> None @@ -277,15 +276,16 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = | _ -> None in - let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function - | Sil.Hpointsto _ -> + let gen_filter_lseg (k2 : Predicates.lseg_kind) para2 e_start2 e_end2 es_shared2 hpred = + match (hpred : Predicates.hpred) with + | Hpointsto _ -> None - | Sil.Hlseg (k1, para1, e_start1, e_end1, es_shared1) -> + | Hlseg (k1, para1, e_start1, e_end1, es_shared1) -> let do_kinds_match = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> + | Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_PE -> true - | Sil.Lseg_PE, Sil.Lseg_NE -> + | Lseg_PE, Lseg_NE -> false in (* let do_paras_match = hpara_match_with_impl tenv hpat.flag para1 para2 *) @@ -295,18 +295,19 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let es1 = [e_start1; e_end1] @ es_shared1 in let es2 = [e_start2; e_end2] @ es_shared2 in exp_list_match es1 sub vars es2 - | Sil.Hdllseg _ -> + | Hdllseg _ -> None in - let gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 = function - | Sil.Hpointsto _ | Sil.Hlseg _ -> + let gen_filter_dllseg (k2 : Predicates.lseg_kind) para2 iF2 oB2 oF2 iB2 es_shared2 hpred = + match (hpred : Predicates.hpred) with + | Hpointsto _ | Hlseg _ -> None - | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) -> + | Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) -> let do_kinds_match = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> + | Lseg_NE, Lseg_NE | Lseg_NE, Lseg_PE | Lseg_PE, Lseg_PE -> true - | Sil.Lseg_PE, Sil.Lseg_NE -> + | Lseg_PE, Lseg_NE -> false in (* let do_paras_match = hpara_dll_match_with_impl tenv hpat.flag para1 para2 *) @@ -318,7 +319,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = exp_list_match es1 sub vars es2 in match hpat.hpred with - | Sil.Hpointsto (lexp2, strexp2, te2) -> ( + | Hpointsto (lexp2, strexp2, te2) -> ( let filter = gen_filter_pointsto lexp2 strexp2 te2 in match (Prop.prop_iter_find iter filter, hpats) with | None, _ -> @@ -327,7 +328,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = do_empty_hpats iter_cur () | Some iter_cur, _ -> execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) - | Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) -> ( + | Hlseg (k2, para2, e_start2, e_end2, es_shared2) -> ( let filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in let do_emp_lseg _ = let fully_instantiated_start2 = @@ -335,7 +336,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = in if not fully_instantiated_start2 then None else - let e_start2' = Sil.exp_sub sub e_start2 in + let e_start2' = Predicates.exp_sub sub e_start2 in match (exp_match e_start2' sub vars e_end2, hpats) with | None, _ -> (* @@ -354,7 +355,9 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest in let do_para_lseg _ = - let para2_exist_vars, para2_inst = Sil.hpara_instantiate para2 e_start2 e_end2 es_shared2 in + let para2_exist_vars, para2_inst = + Predicates.hpara_instantiate para2 e_start2 e_end2 es_shared2 + in (* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *) let allow_impl hpred = {hpred; flag= true} in let para2_hpat, para2_hpats = @@ -373,7 +376,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let not_in_para2_exist_vars id = not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) in - let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in + let sub_res' = Predicates.sub_filter not_in_para2_exist_vars sub_res in Some (sub_res', p_leftover) | Some _ -> None @@ -382,7 +385,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = | None, _ when not hpat.flag -> (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) None - | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE -> + | None, _ when Predicates.equal_lseg_kind k2 Lseg_NE -> (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) do_para_lseg () | None, _ -> @@ -394,7 +397,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = | Some iter_cur, _ -> (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) - | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> ( + | Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> ( let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in let do_emp_dllseg _ = let fully_instantiated_iFoB2 = @@ -402,8 +405,8 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = in if not fully_instantiated_iFoB2 then None else - let iF2' = Sil.exp_sub sub iF2 in - let oB2' = Sil.exp_sub sub oB2 in + let iF2' = Predicates.exp_sub sub iF2 in + let oB2' = Predicates.exp_sub sub oB2 in match (exp_list_match [iF2'; oB2'] sub vars [oF2; iB2], hpats) with | None, _ -> None @@ -419,13 +422,13 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let fully_instantiated_iF2 = not (List.exists ~f:(fun id -> Exp.ident_mem iF2 id) vars) in if not fully_instantiated_iF2 then None else - let iF2' = Sil.exp_sub sub iF2 in + let iF2' = Predicates.exp_sub sub iF2 in match exp_match iF2' sub vars iB2 with | None -> None | Some (sub_new, vars_leftover) -> ( let para2_exist_vars, para2_inst = - Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2 + Predicates.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2 in (* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *) let allow_impl hpred = {hpred; flag= true} in @@ -448,7 +451,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let not_in_para2_exist_vars id = not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) in - let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in + let sub_res' = Predicates.sub_filter not_in_para2_exist_vars sub_res in Some (sub_res', p_leftover) | Some _ -> None ) @@ -456,7 +459,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = match (Prop.prop_iter_find iter filter, hpats) with | None, _ when not hpat.flag -> None - | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE -> + | None, _ when Predicates.equal_lseg_kind k2 Lseg_NE -> do_para_dllseg () | None, _ -> execute_with_backtracking [do_emp_dllseg; do_para_dllseg] @@ -495,19 +498,23 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = let sub_eids = List.map ~f:(fun (id2, id1) -> (id2, Exp.Var id1)) ren_eids in (sub_eids, eids_fresh) in - let sub = Sil.subst_of_list (sub_ids @ sub_eids) in + let sub = Predicates.subst_of_list (sub_ids @ sub_eids) in match sigma2 with | [] -> if List.is_empty sigma1 then true else false | hpred2 :: sigma2 -> ( let hpat2, hpats2 = - let hpred2_ren, sigma2_ren = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in + let hpred2_ren, sigma2_ren = + (Predicates.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) + in let allow_impl hpred = {hpred; flag= impl_ok} in (allow_impl hpred2_ren, List.map ~f:allow_impl sigma2_ren) in let condition _ _ = true in let p1 = Prop.normalize tenv (Prop.from_sigma sigma1) in - match prop_match_with_impl_sub tenv p1 condition Sil.sub_empty eids_fresh hpat2 hpats2 with + match + prop_match_with_impl_sub tenv p1 condition Predicates.sub_empty eids_fresh hpat2 hpats2 + with | None -> false | Some (_, p1') when Prop.prop_is_emp p1' -> @@ -517,28 +524,19 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = with Invalid_argument _ -> false -and hpara_match_with_impl tenv impl_ok para1 para2 : bool = - (* - L.out "@[.... hpara_match_with_impl_sub ....@."; - L.out "@[<4> HPARA1: %a@\n@." pp_hpara para1; - L.out "@[<4> HPARA2: %a@\n@." pp_hpara para2; - *) - let ids1 = para1.Sil.root :: para1.Sil.next :: para1.Sil.svars in - let ids2 = para2.Sil.root :: para2.Sil.next :: para2.Sil.svars in - let eids2 = para2.Sil.evars in - hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body eids2 ids2 para2.Sil.body +and hpara_match_with_impl tenv impl_ok (para1 : Predicates.hpara) (para2 : Predicates.hpara) = + let ids1 = para1.root :: para1.next :: para1.svars in + let ids2 = para2.root :: para2.next :: para2.svars in + let eids2 = para2.evars in + hpara_common_match_with_impl tenv impl_ok ids1 para1.body eids2 ids2 para2.body -and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool = - (* - L.out "@[.... hpara_dll_match_with_impl_sub ....@."; - L.out "@[<4> HPARA1: %a@\n@." pp_hpara_dll para1; - L.out "@[<4> HPARA2: %a@\n@." pp_hpara_dll para2; - *) - let ids1 = para1.Sil.cell :: para1.Sil.blink :: para1.Sil.flink :: para1.Sil.svars_dll in - let ids2 = para2.Sil.cell :: para2.Sil.blink :: para2.Sil.flink :: para2.Sil.svars_dll in - let eids2 = para2.Sil.evars_dll in - hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body_dll eids2 ids2 para2.Sil.body_dll +and hpara_dll_match_with_impl tenv impl_ok (para1 : Predicates.hpara_dll) + (para2 : Predicates.hpara_dll) = + let ids1 = para1.cell :: para1.blink :: para1.flink :: para1.svars_dll in + let ids2 = para2.cell :: para2.blink :: para2.flink :: para2.svars_dll in + let eids2 = para2.evars_dll in + hpara_common_match_with_impl tenv impl_ok ids1 para1.body_dll eids2 ids2 para2.body_dll (** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that @@ -547,14 +545,13 @@ and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool = + [p |- (hpat.hpred * hpats.hpred)\[subst\] * p_leftover]. Using the flag [field], we can control the strength of |-. *) let prop_match_with_impl tenv p condition vars hpat hpats = - prop_match_with_impl_sub tenv p condition Sil.sub_empty vars hpat hpats + prop_match_with_impl_sub tenv p condition Predicates.sub_empty vars hpat hpats let sigma_remove_hpred eq sigma e = - let filter = function - | Sil.Hpointsto (root, _, _) - | Sil.Hlseg (_, _, root, _, _) - | Sil.Hdllseg (_, _, root, _, _, _, _) -> + let filter hpred = + match (hpred : Predicates.hpred) with + | Hpointsto (root, _, _) | Hlseg (_, _, root, _, _) | Hdllseg (_, _, root, _, _, _, _) -> eq root e in let sigma_e, sigma_no_e = List.partition_tf ~f:filter sigma in @@ -573,23 +570,24 @@ type iso_mode = Exact | LFieldForget | RFieldForget [@@deriving compare] let equal_iso_mode = [%compare.equal: iso_mode] -let rec generate_todos_from_strexp mode todos sexp1 sexp2 = +let rec generate_todos_from_strexp mode todos (sexp1 : Predicates.strexp) + (sexp2 : Predicates.strexp) = match (sexp1, sexp2) with - | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> + | Eexp (exp1, _), Eexp (exp2, _) -> let new_todos = (exp1, exp2) :: todos in Some new_todos - | Sil.Eexp _, _ -> + | Eexp _, _ -> None - | Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> + | Estruct (fel1, _), Estruct (fel2, _) -> (* assume sorted w.r.t. fields *) if List.length fel1 <> List.length fel2 && equal_iso_mode mode Exact then None else generate_todos_from_fel mode todos fel1 fel2 - | Sil.Estruct _, _ -> + | Estruct _, _ -> None - | Sil.Earray (len1, iel1, _), Sil.Earray (len2, iel2, _) -> + | Earray (len1, iel1, _), Earray (len2, iel2, _) -> if (not (Exp.equal len1 len2)) || List.length iel1 <> List.length iel2 then None else generate_todos_from_iel mode todos iel1 iel2 - | Sil.Earray _, _ -> + | Earray _, _ -> None @@ -697,10 +695,11 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) | None, _ | _, None -> None - | Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2)) + | Some (Predicates.Hpointsto (_, _, te1)), Some (Predicates.Hpointsto (_, _, te2)) when not (Exp.equal te1 te2) -> None - | Some (Sil.Hpointsto (_, se1, _) as hpred1), Some (Sil.Hpointsto (_, se2, _) as hpred2) -> ( + | ( Some (Predicates.Hpointsto (_, se1, _) as hpred1) + , Some (Predicates.Hpointsto (_, se2, _) as hpred2) ) -> ( match generate_todos_from_strexp mode [] se1 se2 with | None -> None @@ -721,8 +720,8 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm let new_todos = todos'' @ todos' in generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo ) - | ( Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1) - , Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> ( + | ( Some (Predicates.Hlseg (k1, para1, root1, next1, shared1) as hpred1) + , Some (Predicates.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> ( if k1 <> k2 || not (hpara_iso tenv para1 para2) then None else try @@ -746,8 +745,8 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo with Invalid_argument _ -> None ) - | ( Some (Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1) - , Some (Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) -> ( + | ( Some (Predicates.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1) + , Some (Predicates.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) -> ( if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None else try @@ -794,14 +793,14 @@ let find_partial_iso tenv eq corres todos sigma = (** Lift the kind of list segment predicates to PE *) -let hpred_lift_to_pe hpred = +let hpred_lift_to_pe (hpred : Predicates.hpred) : Predicates.hpred = match hpred with - | Sil.Hpointsto _ -> + | Hpointsto _ -> hpred - | Sil.Hlseg (_, para, root, next, shared) -> - Sil.Hlseg (Sil.Lseg_PE, para, root, next, shared) - | Sil.Hdllseg (_, para, iF, oB, oF, iB, shared) -> - Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) + | Hlseg (_, para, root, next, shared) -> + Hlseg (Lseg_PE, para, root, next, shared) + | Hdllseg (_, para, iF, oB, oF, iB, shared) -> + Hdllseg (Lseg_PE, para, iF, oB, oF, iB, shared) (** Lift the kind of list segment predicates to PE in a given sigma *) @@ -855,7 +854,7 @@ let hpara_create tenv corres sigma1 root1 next1 = let id_root = get_id1 root1 in let id_next = get_id1 next1 in let hpara = - {Sil.root= id_root; Sil.next= id_next; Sil.svars= ids_shared; Sil.evars= ids_exists; Sil.body} + {Predicates.root= id_root; next= id_next; svars= ids_shared; evars= ids_exists; body} in (hpara, es_shared) @@ -875,11 +874,11 @@ let hpara_dll_create tenv corres sigma1 root1 blink1 flink1 = let id_blink = get_id1 blink1 in let id_flink = get_id1 flink1 in let hpara_dll = - { Sil.cell= id_root - ; Sil.blink= id_blink - ; Sil.flink= id_flink - ; Sil.svars_dll= ids_shared - ; Sil.evars_dll= ids_exists - ; Sil.body_dll= body } + { Predicates.cell= id_root + ; blink= id_blink + ; flink= id_flink + ; svars_dll= ids_shared + ; evars_dll= ids_exists + ; body_dll= body } in (hpara_dll, es_shared) diff --git a/infer/src/biabduction/Match.mli b/infer/src/biabduction/Match.mli index fa6009412..dc853aaa8 100644 --- a/infer/src/biabduction/Match.mli +++ b/infer/src/biabduction/Match.mli @@ -17,15 +17,16 @@ open! IStd (* TODO: missing documentation *) -val hpara_match_with_impl : Tenv.t -> bool -> Sil.hpara -> Sil.hpara -> bool +val hpara_match_with_impl : Tenv.t -> bool -> Predicates.hpara -> Predicates.hpara -> bool -val hpara_dll_match_with_impl : Tenv.t -> bool -> Sil.hpara_dll -> Sil.hpara_dll -> bool +val hpara_dll_match_with_impl : + Tenv.t -> bool -> Predicates.hpara_dll -> Predicates.hpara_dll -> bool (** Type for a hpred pattern. [flag=false] means that the implication between hpreds is not considered, and [flag = true] means that it is considered during pattern matching. *) -type hpred_pat = {hpred: Sil.hpred; flag: bool} +type hpred_pat = {hpred: Predicates.hpred; flag: bool} -type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool +type sidecondition = Prop.normal Prop.t -> Predicates.subst -> bool val prop_match_with_impl : Tenv.t @@ -34,7 +35,7 @@ val prop_match_with_impl : -> Ident.t list -> hpred_pat -> hpred_pat list - -> (Sil.subst * Prop.normal Prop.t) option + -> (Predicates.subst * Prop.normal Prop.t) option (** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that + [dom(subst) = vars] @@ -47,22 +48,28 @@ val find_partial_iso : -> (Exp.t -> Exp.t -> bool) -> (Exp.t * Exp.t) list -> (Exp.t * Exp.t) list - -> Sil.hpred list - -> ((Exp.t * Exp.t) list * Sil.hpred list * Sil.hpred list * Sil.hpred list) option + -> Predicates.hpred list + -> ((Exp.t * Exp.t) list * Predicates.hpred list * Predicates.hpred list * Predicates.hpred list) + option (** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. The first argument is an equality checker. The function returns a partial iso and three sigmas. The first sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of the returned isomorphism. The second is the second copy of the two isomorphic sigmas, and it uses expressions in the range of the isomorphism. The third is the unused part of the input sigma. *) -val hpara_iso : Tenv.t -> Sil.hpara -> Sil.hpara -> bool +val hpara_iso : Tenv.t -> Predicates.hpara -> Predicates.hpara -> bool (** [hpara_iso] soundly checks whether two hparas are isomorphic. *) -val hpara_dll_iso : Tenv.t -> Sil.hpara_dll -> Sil.hpara_dll -> bool +val hpara_dll_iso : Tenv.t -> Predicates.hpara_dll -> Predicates.hpara_dll -> bool (** [hpara_dll_iso] soundly checks whether two hpara_dlls are isomorphic. *) val hpara_create : - Tenv.t -> (Exp.t * Exp.t) list -> Sil.hpred list -> Exp.t -> Exp.t -> Sil.hpara * Exp.t list + Tenv.t + -> (Exp.t * Exp.t) list + -> Predicates.hpred list + -> Exp.t + -> Exp.t + -> Predicates.hpara * Exp.t list (** [hpara_create] takes a correspondence, and a sigma, a root and a next for the first part of this correspondence. Then, it creates a hpara and discovers a list of shared expressions that are passed as arguments to hpara. Both of them are returned as a result. *) @@ -70,11 +77,11 @@ val hpara_create : val hpara_dll_create : Tenv.t -> (Exp.t * Exp.t) list - -> Sil.hpred list + -> Predicates.hpred list -> Exp.t -> Exp.t -> Exp.t - -> Sil.hpara_dll * Exp.t list + -> Predicates.hpara_dll * Exp.t list (** [hpara_dll_create] takes a correspondence, and a sigma, a root, a blink and a flink for the first part of this correspondence. Then, it creates a hpara_dll and discovers a list of shared expressions that are passed as arguments to hpara. Both of them are returned as a result. *) diff --git a/infer/src/biabduction/Predicates.ml b/infer/src/biabduction/Predicates.ml new file mode 100644 index 000000000..f3944dafb --- /dev/null +++ b/infer/src/biabduction/Predicates.ml @@ -0,0 +1,1257 @@ +(* + * 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 Hashtbl = Caml.Hashtbl +module F = Format +module L = Logging + +(** 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] + +let equal_atom = [%compare.equal: atom] + +let atom_has_local_addr a = + match a with + | Aeq (e0, e1) | Aneq (e0, e1) -> + Exp.has_local_addr e0 || Exp.has_local_addr e1 + | Apred _ | Anpred _ -> + false + + +(** kind of lseg or dllseg predicates *) +type lseg_kind = + | Lseg_NE (** nonempty (possibly circular) listseg *) + | Lseg_PE (** possibly empty (possibly circular) listseg *) +[@@deriving compare] + +let equal_lseg_kind = [%compare.equal: lseg_kind] + +(** The boolean is true when the pointer was dereferenced without testing for zero. *) +type zero_flag = bool option [@@deriving compare] + +(** True when the value was obtained by doing case analysis on null in a procedure call. *) +type null_case_flag = bool [@@deriving compare] + +(** 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] + +let equal_inst = [%compare.equal: inst] + +(** 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 + +let compare_strexp ?(inst = false) se1 se2 = + compare_strexp0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) se1 se2 + + +let equal_strexp ?(inst = false) se1 se2 = Int.equal (compare_strexp ~inst se1 se2) 0 + +(** 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 + +(** Comparison between heap predicates. Reverse natural order, and order first by anchor exp. *) +let compare_hpred ?(inst = false) hpred1 hpred2 = + compare_hpred0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) hpred1 hpred2 + + +let equal_hpred ?(inst = false) hpred1 hpred2 = Int.equal (compare_hpred ~inst hpred1 hpred2) 0 + +type hpara = inst hpara0 + +let compare_hpara = compare_hpara0 (fun _ _ -> 0) + +let equal_hpara = [%compare.equal: hpara] + +type hpara_dll = inst hpara_dll0 + +let compare_hpara_dll = compare_hpara_dll0 (fun _ _ -> 0) + +let equal_hpara_dll = [%compare.equal: hpara_dll] + +(** {2 Comparision and Inspection Functions} *) + +let is_objc_object = function Hpointsto (_, _, Sizeof {typ}) -> Typ.is_objc_class typ | _ -> false + +(** Sets of heap predicates *) +module HpredSet = Caml.Set.Make (struct + type t = hpred + + let compare = compare_hpred ~inst:false +end) + +(** Pretty print an offset *) +let pp_offset pe f = function + | Off_fld (fld, _) -> + Typ.Fieldname.pp f fld + | Off_index exp -> + (Exp.pp_diff pe) f exp + + +(** Pretty print a list of offsets *) +let rec pp_offset_list pe f = function + | [] -> + () + | [off1; off2] -> + F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 + | off :: off_list -> + F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list + + +(** Dump a list of offsets *) +let d_offset_list (offl : offset list) = L.d_pp_with_pe pp_offset_list offl + +let color_wrapper ~f = if Config.print_using_diff then Pp.color_wrapper ~f else f + +let pp_seq_diff pp print_env fmt l = + if Config.print_using_diff then Pp.comma_seq_diff pp print_env fmt l + else Pp.comma_seq ~print_env pp fmt l + + +let pp_atom = + color_wrapper ~f:(fun pe f a -> + match a with + | Aeq (BinOp (op, e1, e2), Const (Cint i)) when IntLit.isone i -> + (Exp.pp_diff pe) f (Exp.BinOp (op, e1, e2)) + | Aeq (e1, e2) -> + F.fprintf f "%a = %a" (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 + | Aneq (e1, e2) -> + F.fprintf f "%a != %a" (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 + | Apred (a, es) -> + F.fprintf f "%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (Exp.pp_diff pe)) es + | Anpred (a, es) -> + F.fprintf f "!%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (Exp.pp_diff pe)) es ) + + +(** dump an atom *) +let d_atom (a : atom) = L.d_pp_with_pe pp_atom a + +let pp_lseg_kind f = function Lseg_NE -> F.pp_print_string f "ne" | Lseg_PE -> () + +(** Print a *-separated sequence. *) +let pp_star_seq pp f l = Pp.seq ~sep:" * " pp f l + +(** 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 get_hpara_id : t -> hpara -> int + (** return the id of the hpara *) + + val get_hpara_dll_id : t -> hpara_dll -> int + (** return the id of the hpara_dll *) + + 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 = struct + (** hash tables for hpara *) + module HparaHash = Hashtbl.Make (struct + type t = hpara + + let equal = equal_hpara + + let hash = Hashtbl.hash + end) + + (** hash tables for hpara_dll *) + module HparaDllHash = Hashtbl.Make (struct + type t = hpara_dll + + let equal = equal_hpara_dll + + let hash = Hashtbl.hash + end) + + (** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, + also keep a list of hparas still to be emitted. Same for hpara_dll. *) + type t = + { mutable num: int + ; hash: (int * bool) HparaHash.t + ; mutable todo: hpara list + ; hash_dll: (int * bool) HparaDllHash.t + ; mutable todo_dll: hpara_dll list } + + (** return true if the environment is empty *) + let is_empty env = Int.equal env.num 0 + + (** return the id of the hpara *) + let get_hpara_id env hpara = fst (HparaHash.find env.hash hpara) + + (** return the id of the hpara_dll *) + let get_hpara_dll_id env hpara_dll = fst (HparaDllHash.find env.hash_dll hpara_dll) + + (** Process one hpara, updating the map from hparas to numbers, and the todo list *) + let process_hpara env hpara = + if not (HparaHash.mem env.hash hpara) then ( + HparaHash.add env.hash hpara (env.num, false) ; + env.num <- env.num + 1 ; + env.todo <- env.todo @ [hpara] ) + + + (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) + let process_hpara_dll env hpara_dll = + if not (HparaDllHash.mem env.hash_dll hpara_dll) then ( + HparaDllHash.add env.hash_dll hpara_dll (env.num, false) ; + env.num <- env.num + 1 ; + env.todo_dll <- env.todo_dll @ [hpara_dll] ) + + + (** Process a sexp, updating env *) + let rec process_sexp env = function + | Eexp _ -> + () + | Earray (_, esel, _) -> + List.iter ~f:(fun (_, se) -> process_sexp env se) esel + | Estruct (fsel, _) -> + List.iter ~f:(fun (_, se) -> process_sexp env se) fsel + + + (** Process one hpred, updating env *) + let rec process_hpred env = function + | Hpointsto (_, se, _) -> + process_sexp env se + | Hlseg (_, hpara, _, _, _) -> + List.iter ~f:(process_hpred env) hpara.body ; + process_hpara env hpara + | Hdllseg (_, hpara_dll, _, _, _, _, _) -> + List.iter ~f:(process_hpred env) hpara_dll.body_dll ; + process_hpara_dll env hpara_dll + + + (** create an empty predicate environment *) + let mk_empty () = + {num= 0; hash= HparaHash.create 3; todo= []; hash_dll= HparaDllHash.create 3; todo_dll= []} + + + (** iterator for predicates which are marked as todo in env, unless they have been visited + already. This can in turn extend the todo list for the nested predicates, which are then + visited as well. Can be applied only once, as it destroys the todo list *) + let iter (env : t) f f_dll = + while env.todo <> [] || env.todo_dll <> [] do + match env.todo with + | hpara :: todo' -> + env.todo <- todo' ; + let n, emitted = HparaHash.find env.hash hpara in + if not emitted then f n hpara + | [] -> ( + match env.todo_dll with + | hpara_dll :: todo_dll' -> + env.todo_dll <- todo_dll' ; + let n, emitted = HparaDllHash.find env.hash_dll hpara_dll in + if not emitted then f_dll n hpara_dll + | [] -> + () ) + done +end + +let pp_texp_simple pe = + match pe.Pp.opt with SIM_DEFAULT -> Exp.pp_texp pe | SIM_WITH_TYP -> Exp.pp_texp_full pe + + +let inst_actual_precondition = Iactual_precondition + +(** for formal parameters *) +let inst_formal = Iformal (None, false) + +(** for initial values *) +let inst_initial = Iinitial + +let inst_lookup = Ilookup + +let inst_none = Inone + +let inst_nullify = Inullify + +let inst_rearrange b loc pos = Irearrange (Some b, false, loc.Location.line, pos) + +let inst_update loc pos = Iupdate (None, false, loc.Location.line, pos) + +(** update the location of the instrumentation *) +let inst_new_loc loc inst = + match inst with + | Iabstraction -> + inst + | Iactual_precondition -> + inst + | Ialloc -> + inst + | Iformal _ -> + inst + | Iinitial -> + inst + | Ilookup -> + inst + | Inone -> + inst + | Inullify -> + inst + | Irearrange (zf, ncf, _, pos) -> + Irearrange (zf, ncf, loc.Location.line, pos) + | Itaint -> + inst + | Iupdate (zf, ncf, _, pos) -> + Iupdate (zf, ncf, loc.Location.line, pos) + | Ireturn_from_call _ -> + Ireturn_from_call loc.Location.line + + +(** pretty-print an inst *) +let pp_inst f inst = + let pp_zero_flag f = function Some true -> F.pp_print_string f "(z)" | _ -> () in + let pp_null_case_flag f ncf = if ncf then F.pp_print_string f "(ncf)" in + match inst with + | Iabstraction -> + F.pp_print_string f "abstraction" + | Iactual_precondition -> + F.pp_print_string f "actual_precondition" + | Ialloc -> + F.pp_print_string f "alloc" + | Iformal (zf, ncf) -> + F.fprintf f "formal%a%a" pp_zero_flag zf pp_null_case_flag ncf + | Iinitial -> + F.pp_print_string f "initial" + | Ilookup -> + F.pp_print_string f "lookup" + | Inone -> + F.pp_print_string f "none" + | Inullify -> + F.pp_print_string f "nullify" + | Irearrange (zf, ncf, n, _) -> + F.fprintf f "rearrange:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n + | Itaint -> + F.pp_print_string f "taint" + | Iupdate (zf, ncf, n, _) -> + F.fprintf f "update:%a%a%d" pp_zero_flag zf pp_null_case_flag ncf n + | Ireturn_from_call n -> + F.fprintf f "return_from_call: %d" n + + +exception JoinFail + +(** join of instrumentations, can raise JoinFail *) +let inst_partial_join inst1 inst2 = + let fail () = + L.d_printfln "inst_partial_join failed on %a %a" pp_inst inst1 pp_inst inst2 ; + raise JoinFail + in + if equal_inst inst1 inst2 then inst1 + else + match (inst1, inst2) with + | _, Inone | Inone, _ -> + inst_none + | _, Ialloc | Ialloc, _ -> + fail () + | _, Iinitial | Iinitial, _ -> + fail () + | _, Iupdate _ | Iupdate _, _ -> + fail () + | _ -> + inst_none + + +(** meet of instrumentations *) +let inst_partial_meet inst1 inst2 = if equal_inst inst1 inst2 then inst1 else inst_none + +(** Return the zero flag of the inst *) +let inst_zero_flag = function + | Iabstraction -> + None + | Iactual_precondition -> + None + | Ialloc -> + None + | Iformal (zf, _) -> + zf + | Iinitial -> + None + | Ilookup -> + None + | Inone -> + None + | Inullify -> + None + | Irearrange (zf, _, _, _) -> + zf + | Itaint -> + None + | Iupdate (zf, _, _, _) -> + zf + | Ireturn_from_call _ -> + None + + +(** Set the null case flag of the inst. *) +let inst_set_null_case_flag = function + | Iformal (zf, false) -> + Iformal (zf, true) + | Irearrange (zf, false, n, pos) -> + Irearrange (zf, true, n, pos) + | Iupdate (zf, false, n, pos) -> + Iupdate (zf, true, n, pos) + | inst -> + inst + + +(** Update [inst_old] to [inst_new] preserving the zero flag *) +let update_inst inst_old inst_new = + let combine_zero_flags z1 z2 = + match (z1, z2) with + | Some b1, Some b2 -> + Some (b1 || b2) + | Some b, None -> + Some b + | None, Some b -> + Some b + | None, None -> + None + in + match inst_new with + | Iabstraction -> + inst_new + | Iactual_precondition -> + inst_new + | Ialloc -> + inst_new + | Iformal (zf, ncf) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + Iformal (zf', ncf) + | Iinitial -> + inst_new + | Ilookup -> + inst_new + | Inone -> + inst_new + | Inullify -> + inst_new + | Irearrange (zf, ncf, n, pos) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + Irearrange (zf', ncf, n, pos) + | Itaint -> + inst_new + | Iupdate (zf, ncf, n, pos) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + Iupdate (zf', ncf, n, pos) + | Ireturn_from_call _ -> + inst_new + + +(** describe an instrumentation with a string *) +let pp_inst_if_trace pe f inst = + if Config.trace_error then + if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Pp.html_with_color Orange pp_inst f inst + else F.fprintf f "%s%a%s" (Binop.str pe Lt) pp_inst inst (Binop.str pe Gt) + + +(** pretty print a strexp with an optional predicate env *) +let rec pp_sexp_env pe0 envo f se = + color_wrapper pe0 f se ~f:(fun pe f se -> + match se with + | Eexp (e, inst) -> + F.fprintf f "%a%a" (Exp.pp_diff pe) e (pp_inst_if_trace pe) inst + | Estruct (fel, inst) -> + let pp_diff f (n, se) = F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se in + F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst + | Earray (len, nel, inst) -> + let pp_diff f (i, se) = F.fprintf f "%a:%a" (Exp.pp_diff pe) i (pp_sexp_env pe envo) se in + F.fprintf f "[%a|%a]%a" (Exp.pp_diff pe) len (pp_seq_diff pp_diff pe) nel + (pp_inst_if_trace pe) inst ) + + +(** Pretty print an hpred with an optional predicate env *) +let rec pp_hpred_env pe0 envo f hpred = + color_wrapper pe0 f hpred ~f:(fun pe f hpred -> + match hpred with + | Hpointsto (e, se, te) -> + let pe' = + match (e, se) with + | Lvar pvar, Eexp (Var _, _) when not (Pvar.is_global pvar) -> + Pp.{pe with obj_sub= None} (* dont use obj sub on the var defining it *) + | _ -> + pe + in + F.fprintf f "%a|->%a:%a" (Exp.pp_diff pe') e (pp_sexp_env pe' envo) se + (pp_texp_simple pe') te + | Hlseg (k, hpara, e1, e2, elist) -> + F.fprintf f "lseg%a(%a,%a,[%a],%a)" pp_lseg_kind k (Exp.pp_diff pe) e1 (Exp.pp_diff pe) e2 + (Pp.comma_seq (Exp.pp_diff pe)) + elist (pp_hpara_env pe envo) hpara + | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> + F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k (Exp.pp_diff pe) iF + (Exp.pp_diff pe) oB (Exp.pp_diff pe) oF (Exp.pp_diff pe) iB + (Pp.comma_seq (Exp.pp_diff pe)) + elist (pp_hpara_dll_env pe envo) hpara_dll ) + + +and pp_hpara_env pe envo f hpara = + match envo with + | None -> + let r, n, svars, evars, b = (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body) in + F.fprintf f "lam [%a,%a,%a]. exists [%a]. %a" Ident.pp r Ident.pp n (Pp.seq Ident.pp) svars + (Pp.seq Ident.pp) evars + (pp_star_seq (pp_hpred_env pe envo)) + b + | Some env -> + F.fprintf f "P%d" (Env.get_hpara_id env hpara) + + +and pp_hpara_dll_env pe envo f hpara_dll = + match envo with + | None -> + let iF, oB, oF, svars, evars, b = + ( hpara_dll.cell + , hpara_dll.blink + , hpara_dll.flink + , hpara_dll.svars_dll + , hpara_dll.evars_dll + , hpara_dll.body_dll ) + in + F.fprintf f "lam [%a,%a,%a,%a]. exists [%a]. %a" Ident.pp iF Ident.pp oB Ident.pp oF + (Pp.seq Ident.pp) svars (Pp.seq Ident.pp) evars + (pp_star_seq (pp_hpred_env pe envo)) + b + | Some env -> + F.fprintf f "P%d" (Env.get_hpara_dll_id env hpara_dll) + + +(** pretty print a strexp *) +let pp_sexp pe f = pp_sexp_env pe None f + +(** pretty print a hpara *) +let pp_hpara pe f = pp_hpara_env pe None f + +(** pretty print a hpara_dll *) +let pp_hpara_dll pe f = pp_hpara_dll_env pe None f + +(** pretty print a hpred *) +let pp_hpred pe f = pp_hpred_env pe None f + +(** dump a strexp. *) +let d_sexp (se : strexp) = L.d_pp_with_pe pp_sexp se + +(** dump a hpred. *) +let d_hpred (hpred : hpred) = L.d_pp_with_pe pp_hpred hpred + +(** {2 Functions for traversing SIL data types} *) + +let rec strexp_expmap (f : Exp.t * inst option -> Exp.t * inst option) = + let fe e = fst (f (e, None)) in + let fei (e, inst) = + match f (e, Some inst) with e', None -> (e', inst) | e', Some inst' -> (e', inst') + in + function + | Eexp (e, inst) -> + let e', inst' = fei (e, inst) in + Eexp (e', inst') + | Estruct (fld_se_list, inst) -> + let f_fld_se (fld, se) = (fld, strexp_expmap f se) in + Estruct (List.map ~f:f_fld_se fld_se_list, inst) + | Earray (len, idx_se_list, inst) -> + let len' = fe len in + let f_idx_se (idx, se) = + let idx' = fe idx in + (idx', strexp_expmap f se) + in + Earray (len', List.map ~f:f_idx_se idx_se_list, inst) + + +let hpred_expmap (f : Exp.t * inst option -> Exp.t * inst option) = + let fe e = fst (f (e, None)) in + function + | Hpointsto (e, se, te) -> + let e' = fe e in + let se' = strexp_expmap f se in + let te' = fe te in + Hpointsto (e', se', te') + | Hlseg (k, hpara, root, next, shared) -> + let root' = fe root in + let next' = fe next in + let shared' = List.map ~f:fe shared in + Hlseg (k, hpara, root', next', shared') + | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> + let iF' = fe iF in + let oB' = fe oB in + let oF' = fe oF in + let iB' = fe iB in + let shared' = List.map ~f:fe shared in + Hdllseg (k, hpara, iF', oB', oF', iB', shared') + + +let rec strexp_instmap (f : inst -> inst) strexp = + match strexp with + | Eexp (e, inst) -> + Eexp (e, f inst) + | Estruct (fld_se_list, inst) -> + let f_fld_se (fld, se) = (fld, strexp_instmap f se) in + Estruct (List.map ~f:f_fld_se fld_se_list, f inst) + | Earray (len, idx_se_list, inst) -> + let f_idx_se (idx, se) = (idx, strexp_instmap f se) in + Earray (len, List.map ~f:f_idx_se idx_se_list, f inst) + + +let rec hpara_instmap (f : inst -> inst) hpara = + {hpara with body= List.map ~f:(hpred_instmap f) hpara.body} + + +and hpara_dll_instmap (f : inst -> inst) hpara_dll = + {hpara_dll with body_dll= List.map ~f:(hpred_instmap f) hpara_dll.body_dll} + + +and hpred_instmap (fn : inst -> inst) (hpred : hpred) : hpred = + match hpred with + | Hpointsto (e, se, te) -> + let se' = strexp_instmap fn se in + Hpointsto (e, se', te) + | Hlseg (k, hpara, e, f, el) -> + Hlseg (k, hpara_instmap fn hpara, e, f, el) + | Hdllseg (k, hpar_dll, e, f, g, h, el) -> + Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) + + +let hpred_list_expmap (f : Exp.t * inst option -> Exp.t * inst option) (hlist : hpred list) = + List.map ~f:(hpred_expmap f) hlist + + +let atom_expmap (f : Exp.t -> Exp.t) = function + | Aeq (e1, e2) -> + Aeq (f e1, f e2) + | Aneq (e1, e2) -> + Aneq (f e1, f e2) + | Apred (a, es) -> + Apred (a, List.map ~f es) + | Anpred (a, es) -> + Anpred (a, List.map ~f es) + + +(** {2 Function for computing lexps in sigma} *) + +let hpred_get_lexp acc = function + | Hpointsto (e, _, _) -> + e :: acc + | Hlseg (_, _, e, _, _) -> + e :: acc + | Hdllseg (_, _, e1, _, _, e2, _) -> + e1 :: e2 :: acc + + +let hpred_list_get_lexps (filter : Exp.t -> bool) (hlist : hpred list) : Exp.t list = + let lexps = List.fold ~f:hpred_get_lexp ~init:[] hlist in + List.filter ~f:filter lexps + + +let hpred_entries hpred = hpred_get_lexp [] hpred + +(** {2 Functions for computing free non-program variables} *) + +let atom_gen_free_vars = + let open Sequence.Generator in + function + | Aeq (e1, e2) | Aneq (e1, e2) -> + Exp.gen_free_vars e1 >>= fun () -> Exp.gen_free_vars e2 + | Apred (_, es) | Anpred (_, es) -> + ISequence.gen_sequence_list es ~f:Exp.gen_free_vars + + +let atom_free_vars a = Sequence.Generator.run (atom_gen_free_vars a) + +let rec strexp_gen_free_vars = + let open Sequence.Generator in + function + | Eexp (e, _) -> + Exp.gen_free_vars e + | Estruct (fld_se_list, _) -> + ISequence.gen_sequence_list fld_se_list ~f:(fun (_, se) -> strexp_gen_free_vars se) + | Earray (len, idx_se_list, _) -> + Exp.gen_free_vars len + >>= fun () -> + ISequence.gen_sequence_list idx_se_list ~f:(fun (e, se) -> + Exp.gen_free_vars e >>= fun () -> strexp_gen_free_vars se ) + + +let hpred_gen_free_vars = + let open Sequence.Generator in + function + | Hpointsto (base, sexp, te) -> + Exp.gen_free_vars base + >>= fun () -> strexp_gen_free_vars sexp >>= fun () -> Exp.gen_free_vars te + | Hlseg (_, _, e1, e2, elist) -> + Exp.gen_free_vars e1 + >>= fun () -> + Exp.gen_free_vars e2 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars + | Hdllseg (_, _, e1, e2, e3, e4, elist) -> + Exp.gen_free_vars e1 + >>= fun () -> + Exp.gen_free_vars e2 + >>= fun () -> + Exp.gen_free_vars e3 + >>= fun () -> + Exp.gen_free_vars e4 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars + + +let hpred_free_vars h = Sequence.Generator.run (hpred_gen_free_vars h) + +(** {2 Functions for computing all free or bound non-program variables} *) + +(** Variables in hpara, excluding bound vars in the body *) +let hpara_shallow_gen_free_vars {body; root; next; svars; evars} = + let open Sequence.Generator in + ISequence.gen_sequence_list ~f:hpred_gen_free_vars body + >>= fun () -> + yield root + >>= fun () -> + yield next + >>= fun () -> + ISequence.gen_sequence_list ~f:yield svars + >>= fun () -> ISequence.gen_sequence_list ~f:yield evars + + +let hpara_shallow_free_vars h = Sequence.Generator.run (hpara_shallow_gen_free_vars h) + +(** Variables in hpara_dll, excluding bound vars in the body *) +let hpara_dll_shallow_gen_free_vars {body_dll; cell; blink; flink; svars_dll; evars_dll} = + let open Sequence.Generator in + ISequence.gen_sequence_list ~f:hpred_gen_free_vars body_dll + >>= fun () -> + yield cell + >>= fun () -> + yield blink + >>= fun () -> + yield flink + >>= fun () -> + ISequence.gen_sequence_list ~f:yield svars_dll + >>= fun () -> ISequence.gen_sequence_list ~f:yield evars_dll + + +let hpara_dll_shallow_free_vars h = Sequence.Generator.run (hpara_dll_shallow_gen_free_vars h) + +(** {2 Functions for Substitution} *) + +(** substitution *) +type ident_exp = Ident.t * Exp.t [@@deriving compare] + +let compare_ident_exp_ids (id1, _) (id2, _) = Ident.compare id1 id2 + +type subst = ident_exp list [@@deriving compare] + +type subst_fun = Ident.t -> Exp.t + +let equal_subst = [%compare.equal: subst] + +let sub_no_duplicated_ids sub = not (List.contains_dup ~compare:compare_ident_exp_ids sub) + +(** Create a substitution from a list of pairs. For all (id1, e1), (id2, e2) in the input list, if + id1 = id2, then e1 = e2. *) +let subst_of_list sub = + let sub' = List.dedup_and_sort ~compare:compare_ident_exp sub in + assert (sub_no_duplicated_ids sub') ; + sub' + + +(** like subst_of_list, but allow duplicate ids and only keep the first occurrence *) +let subst_of_list_duplicates sub = List.dedup_and_sort ~compare:compare_ident_exp_ids sub + +(** Convert a subst to a list of pairs. *) +let sub_to_list sub = sub + +(** The empty substitution. *) +let sub_empty = subst_of_list [] + +let is_sub_empty = List.is_empty + +(** Join two substitutions into one. For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) +let sub_join sub1 sub2 = + let sub = IList.merge_dedup ~compare:compare_ident_exp sub1 sub2 in + assert (sub_no_duplicated_ids sub) ; + sub + + +(** 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. *) +let sub_symmetric_difference sub1_in sub2_in = + let rec diff sub_common sub1_only sub2_only sub1 sub2 = + match (sub1, sub2) with + | [], _ | _, [] -> + let sub1_only' = List.rev_append sub1_only sub1 in + let sub2_only' = List.rev_append sub2_only sub2 in + let sub_common = List.rev sub_common in + (sub_common, sub1_only', sub2_only') + | id_e1 :: sub1', id_e2 :: sub2' -> + let n = compare_ident_exp id_e1 id_e2 in + if Int.equal n 0 then diff (id_e1 :: sub_common) sub1_only sub2_only sub1' sub2' + else if n < 0 then diff sub_common (id_e1 :: sub1_only) sub2_only sub1' sub2 + else diff sub_common sub1_only (id_e2 :: sub2_only) sub1 sub2' + in + diff [] [] [] sub1_in sub2_in + + +(** [sub_find filter sub] returns the expression associated to the first identifier that satisfies + [filter]. Raise [Not_found] if there isn't one. *) +let sub_find filter (sub : subst) = snd (List.find_exn ~f:(fun (i, _) -> filter i) sub) + +(** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *) +let sub_filter filter (sub : subst) = List.filter ~f:(fun (i, _) -> filter i) sub + +(** [sub_filter_pair filter sub] restricts the domain of [sub] to the identifiers satisfying + [filter(id, sub(id))]. *) +let sub_filter_pair = List.filter + +(** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy + [filter]. *) +let sub_range_partition filter (sub : subst) = List.partition_tf ~f:(fun (_, e) -> filter e) sub + +(** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers + satisfy [filter]. *) +let sub_domain_partition filter (sub : subst) = List.partition_tf ~f:(fun (i, _) -> filter i) sub + +(** Return the list of identifiers in the domain of the substitution. *) +let sub_domain sub = List.map ~f:fst sub + +(** Return the list of expressions in the range of the substitution. *) +let sub_range sub = List.map ~f:snd sub + +(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *) +let sub_range_map f sub = subst_of_list (List.map ~f:(fun (i, e) -> (i, f e)) sub) + +(** [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]. *) +let sub_map f g sub = subst_of_list (List.map ~f:(fun (i, e) -> (f i, g e)) sub) + +let mem_sub id sub = List.exists ~f:(fun (id1, _) -> Ident.equal id id1) sub + +(** Extend substitution and return [None] if not possible. *) +let extend_sub sub id exp : subst option = + let compare (id1, _) (id2, _) = Ident.compare id1 id2 in + if mem_sub id sub then None else Some (List.merge ~compare sub [(id, exp)]) + + +(** Free auxilary variables in the domain and range of the substitution. *) +let subst_gen_free_vars sub = + let open Sequence.Generator in + ISequence.gen_sequence_list sub ~f:(fun (id, e) -> yield id >>= fun () -> Exp.gen_free_vars e) + + +let subst_free_vars sub = Sequence.Generator.run (subst_gen_free_vars sub) + +let rec exp_sub_ids (f : subst_fun) exp = + match (exp : Exp.t) with + | Var id -> ( + match f id with + | Exp.Var id' when Ident.equal id id' -> + exp (* it will preserve physical equality when needed *) + | exp' -> + exp' ) + | Lvar _ -> + exp + | Exn e -> + let e' = exp_sub_ids f e in + if phys_equal e' e then exp else Exp.Exn e' + | Closure c -> + let captured_vars = + IList.map_changed ~equal:[%compare.equal: Exp.t * Pvar.t * Typ.t] + ~f:(fun ((e, pvar, typ) as captured) -> + let e' = exp_sub_ids f e in + if phys_equal e' e then captured else (e', pvar, typ) ) + c.captured_vars + in + if phys_equal captured_vars c.captured_vars then exp else Exp.Closure {c with captured_vars} + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) -> + exp + | Cast (t, e) -> + let e' = exp_sub_ids f e in + if phys_equal e' e then exp else Exp.Cast (t, e') + | UnOp (op, e, typ_opt) -> + let e' = exp_sub_ids f e in + if phys_equal e' e then exp else Exp.UnOp (op, e', typ_opt) + | BinOp (op, e1, e2) -> + let e1' = exp_sub_ids f e1 in + let e2' = exp_sub_ids f e2 in + if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.BinOp (op, e1', e2') + | Lfield (e, fld, typ) -> + let e' = exp_sub_ids f e in + if phys_equal e' e then exp else Exp.Lfield (e', fld, typ) + | Lindex (e1, e2) -> + let e1' = exp_sub_ids f e1 in + let e2' = exp_sub_ids f e2 in + if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.Lindex (e1', e2') + | Sizeof ({dynamic_length= Some l} as sizeof_data) -> + let l' = exp_sub_ids f l in + if phys_equal l' l then exp else Exp.Sizeof {sizeof_data with dynamic_length= Some l'} + | Sizeof {dynamic_length= None} -> + exp + + +let apply_sub subst : subst_fun = + fun id -> match List.Assoc.find subst ~equal:Ident.equal id with Some x -> x | None -> Exp.Var id + + +let exp_sub (subst : subst) e = exp_sub_ids (apply_sub subst) e + +(** apply [f] to id's in [instr]. if [sub_id_binders] is false, [f] is only applied to bound id's *) +let instr_sub_ids ~sub_id_binders f (instr : Sil.instr) : Sil.instr = + let sub_id id = + match exp_sub_ids f (Var id) with Var id' when not (Ident.equal id id') -> id' | _ -> id + in + match instr with + | Load {id; e= rhs_exp; root_typ; typ; loc} -> + let id' = if sub_id_binders then sub_id id else id in + let rhs_exp' = exp_sub_ids f rhs_exp in + if phys_equal id' id && phys_equal rhs_exp' rhs_exp then instr + else Load {id= id'; e= rhs_exp'; root_typ; typ; loc} + | Store {e1= lhs_exp; root_typ; typ; e2= rhs_exp; loc} -> + let lhs_exp' = exp_sub_ids f lhs_exp in + let rhs_exp' = exp_sub_ids f rhs_exp in + if phys_equal lhs_exp' lhs_exp && phys_equal rhs_exp' rhs_exp then instr + else Store {e1= lhs_exp'; root_typ; typ; e2= rhs_exp'; loc} + | Call (((id, typ) as ret_id_typ), fun_exp, actuals, call_flags, loc) -> + let ret_id' = + if sub_id_binders then + let id' = sub_id id in + if Ident.equal id id' then ret_id_typ else (id', typ) + else ret_id_typ + in + let fun_exp' = exp_sub_ids f fun_exp in + let actuals' = + IList.map_changed ~equal:[%compare.equal: Exp.t * Typ.t] + ~f:(fun ((actual, typ) as actual_pair) -> + let actual' = exp_sub_ids f actual in + if phys_equal actual' actual then actual_pair else (actual', typ) ) + actuals + in + if phys_equal ret_id' ret_id_typ && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals + then instr + else Call (ret_id', fun_exp', actuals', call_flags, loc) + | Prune (exp, loc, true_branch, if_kind) -> + let exp' = exp_sub_ids f exp in + if phys_equal exp' exp then instr else Prune (exp', loc, true_branch, if_kind) + | Metadata (ExitScope (vars, loc)) -> + let sub_var var = + match var with + | Var.ProgramVar _ -> + var + | Var.LogicalVar ident -> + let ident' = sub_id ident in + if phys_equal ident ident' then var else Var.of_id ident' + in + let vars' = IList.map_changed ~equal:phys_equal ~f:sub_var vars in + if phys_equal vars vars' then instr else Metadata (ExitScope (vars', loc)) + | Metadata (Abstract _ | Nullify _ | Skip | VariableLifetimeBegins _) -> + instr + + +(** apply [subst] to all id's in [instr], including binder id's *) +let instr_sub (subst : subst) instr = instr_sub_ids ~sub_id_binders:true (apply_sub subst) instr + +let atom_sub subst = atom_expmap (exp_sub subst) + +let hpred_sub subst = + let f (e, inst_opt) = (exp_sub subst e, inst_opt) in + hpred_expmap f + + +(** {2 Functions for replacing occurrences of expressions.} *) + +(** The first parameter should define a partial function. No parts of hpara are replaced by these + functions. *) +let rec exp_replace_exp epairs e = + (* First we check if there is an exact match *) + match List.find ~f:(fun (e1, _) -> Exp.equal e e1) epairs with + | Some (_, e2) -> + e2 + | None -> ( + (* If e is a compound expression, we need to check for its subexpressions as well *) + match e with + | Exp.UnOp (op, e0, ty) -> + let e0' = exp_replace_exp epairs e0 in + if phys_equal e0 e0' then e else Exp.UnOp (op, e0', ty) + | Exp.BinOp (op, lhs, rhs) -> + let lhs' = exp_replace_exp epairs lhs in + let rhs' = exp_replace_exp epairs rhs in + if phys_equal lhs lhs' && phys_equal rhs rhs' then e else Exp.BinOp (op, lhs', rhs') + | Exp.Cast (ty, e0) -> + let e0' = exp_replace_exp epairs e0 in + if phys_equal e0 e0' then e else Exp.Cast (ty, e0') + | Exp.Lfield (e0, fname, ty) -> + let e0' = exp_replace_exp epairs e0 in + if phys_equal e0 e0' then e else Exp.Lfield (e0', fname, ty) + | Exp.Lindex (base, index) -> + let base' = exp_replace_exp epairs base in + let index' = exp_replace_exp epairs index in + if phys_equal base base' && phys_equal index index' then e else Exp.Lindex (base', index') + | _ -> + e ) + + +let atom_replace_exp epairs atom = atom_expmap (fun e -> exp_replace_exp epairs e) atom + +let rec strexp_replace_exp epairs = function + | Eexp (e, inst) -> + Eexp (exp_replace_exp epairs e, inst) + | Estruct (fsel, inst) -> + let f (fld, se) = (fld, strexp_replace_exp epairs se) in + Estruct (List.map ~f fsel, inst) + | Earray (len, isel, inst) -> + let len' = exp_replace_exp epairs len in + let f (idx, se) = + let idx' = exp_replace_exp epairs idx in + (idx', strexp_replace_exp epairs se) + in + Earray (len', List.map ~f isel, inst) + + +let hpred_replace_exp epairs = function + | Hpointsto (root, se, te) -> + let root_repl = exp_replace_exp epairs root in + let strexp_repl = strexp_replace_exp epairs se in + let te_repl = exp_replace_exp epairs te in + Hpointsto (root_repl, strexp_repl, te_repl) + | Hlseg (k, para, root, next, shared) -> + let root_repl = exp_replace_exp epairs root in + let next_repl = exp_replace_exp epairs next in + let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in + Hlseg (k, para, root_repl, next_repl, shared_repl) + | Hdllseg (k, para, e1, e2, e3, e4, shared) -> + let e1' = exp_replace_exp epairs e1 in + let e2' = exp_replace_exp epairs e2 in + let e3' = exp_replace_exp epairs e3 in + let e4' = exp_replace_exp epairs e4 in + let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in + Hdllseg (k, para, e1', e2', e3', e4', shared_repl) + + +(** {2 Compaction} *) +module HpredInstHash = Hashtbl.Make (struct + type t = hpred + + let equal = equal_hpred ~inst:true + + let hash = Hashtbl.hash +end) + +type sharing_env = {exph: Exp.t Exp.Hash.t; hpredh: hpred HpredInstHash.t} + +(** Create a sharing env to store canonical representations *) +let create_sharing_env () = {exph= Exp.Hash.create 3; hpredh= HpredInstHash.create 3} + +(** Return a canonical representation of the exp *) +let exp_compact sh e = + try Exp.Hash.find sh.exph e with Caml.Not_found -> Exp.Hash.add sh.exph e e ; e + + +let rec sexp_compact sh se = + match se with + | Eexp (e, inst) -> + Eexp (exp_compact sh e, inst) + | Estruct (fsel, inst) -> + Estruct (List.map ~f:(fun (f, se) -> (f, sexp_compact sh se)) fsel, inst) + | Earray _ -> + se + + +(** Return a compact representation of the hpred *) +let hpred_compact_ sh hpred = + match hpred with + | Hpointsto (e1, se, e2) -> + let e1' = exp_compact sh e1 in + let e2' = exp_compact sh e2 in + let se' = sexp_compact sh se in + Hpointsto (e1', se', e2') + | Hlseg _ -> + hpred + | Hdllseg _ -> + hpred + + +let hpred_compact sh hpred = + try HpredInstHash.find sh.hpredh hpred + with Caml.Not_found -> + let hpred' = hpred_compact_ sh hpred in + HpredInstHash.add sh.hpredh hpred' hpred' ; + hpred' + + +(** {2 Functions for constructing or destructing entities in this module} *) + +(** Compute the offset list of an expression *) +let exp_get_offsets exp = + let rec f offlist_past e = + match (e : Exp.t) with + | Var _ | Const _ | UnOp _ | BinOp _ | Exn _ | Closure _ | Lvar _ | Sizeof {dynamic_length= None} + -> + offlist_past + | Sizeof {dynamic_length= Some l} -> + f offlist_past l + | Cast (_, sub_exp) -> + f offlist_past sub_exp + | Lfield (sub_exp, fldname, typ) -> + f (Off_fld (fldname, typ) :: offlist_past) sub_exp + | Lindex (sub_exp, e) -> + f (Off_index e :: offlist_past) sub_exp + in + f [] exp + + +let exp_add_offsets exp offsets = + let rec f acc = function + | [] -> + acc + | Off_fld (fld, typ) :: offs' -> + f (Exp.Lfield (acc, fld, typ)) offs' + | Off_index e :: offs' -> + f (Exp.Lindex (acc, e)) offs' + in + f exp offsets + + +(** Convert all the lseg's in sigma to nonempty lsegs. *) +let sigma_to_sigma_ne sigma : (atom list * hpred list) list = + if Config.nelseg then + let f eqs_sigma_list hpred = + match hpred with + | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) -> + let g (eqs, sigma) = (eqs, hpred :: sigma) in + List.map ~f:g eqs_sigma_list + | Hlseg (Lseg_PE, para, e1, e2, el) -> + let g (eqs, sigma) = + [(Aeq (e1, e2) :: eqs, sigma); (eqs, Hlseg (Lseg_NE, para, e1, e2, el) :: sigma)] + in + List.concat_map ~f:g eqs_sigma_list + | Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, el) -> + let g (eqs, sigma) = + [ (Aeq (e1, e3) :: Aeq (e2, e4) :: eqs, sigma) + ; (eqs, Hdllseg (Lseg_NE, para_dll, e1, e2, e3, e4, el) :: sigma) ] + in + List.concat_map ~f:g eqs_sigma_list + in + List.fold ~f ~init:[([], [])] sigma + else [([], sigma)] + + +(** [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'].*) +let hpara_instantiate para e1 e2 elist = + let subst_for_svars = + let g id e = (id, e) in + try List.map2_exn ~f:g para.svars elist with Invalid_argument _ -> assert false + in + let ids_evars = + let g _ = Ident.create_fresh Ident.kprimed in + List.map ~f:g para.evars + in + let subst_for_evars = + let g id id' = (id, Exp.Var id') in + try List.map2_exn ~f:g para.evars ids_evars with Invalid_argument _ -> assert false + in + let subst = + subst_of_list (((para.root, e1) :: (para.next, e2) :: subst_for_svars) @ subst_for_evars) + in + (ids_evars, List.map ~f:(hpred_sub subst) para.body) + + +(** [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'].*) +let hpara_dll_instantiate (para : hpara_dll) cell blink flink elist = + let subst_for_svars = + let g id e = (id, e) in + try List.map2_exn ~f:g para.svars_dll elist with Invalid_argument _ -> assert false + in + let ids_evars = + let g _ = Ident.create_fresh Ident.kprimed in + List.map ~f:g para.evars_dll + in + let subst_for_evars = + let g id id' = (id, Exp.Var id') in + try List.map2_exn ~f:g para.evars_dll ids_evars with Invalid_argument _ -> assert false + in + let subst = + subst_of_list + ( ((para.cell, cell) :: (para.blink, blink) :: (para.flink, flink) :: subst_for_svars) + @ subst_for_evars ) + in + (ids_evars, List.map ~f:(hpred_sub subst) para.body_dll) + + +let custom_error = Pvar.mk_global (Mangled.from_string "INFER_CUSTOM_ERROR") diff --git a/infer/src/biabduction/Predicates.mli b/infer/src/biabduction/Predicates.mli new file mode 100644 index 000000000..a7efb969d --- /dev/null +++ b/infer/src/biabduction/Predicates.mli @@ -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 diff --git a/infer/src/biabduction/Prop.ml b/infer/src/biabduction/Prop.ml index 18b6ce0c2..d7b752331 100644 --- a/infer/src/biabduction/Prop.ml +++ b/infer/src/biabduction/Prop.ml @@ -29,9 +29,9 @@ type exposed (** kind for sorted props *) type sorted -type pi = Sil.atom list [@@deriving compare] +type pi = Predicates.atom list [@@deriving compare] -type sigma = Sil.hpred list [@@deriving compare] +type sigma = Predicates.hpred list [@@deriving compare] let equal_pi = [%compare.equal: pi] @@ -41,7 +41,7 @@ module Core : sig (** the kind 'a should range over [normal] and [exposed] *) type 'a t = private { sigma: sigma (** spatial part *) - ; sub: Sil.subst (** substitution *) + ; sub: Predicates.subst (** substitution *) ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } @@ -53,7 +53,13 @@ module Core : sig (** Proposition [true /\ emp]. *) val set : - ?sub:Sil.subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t + ?sub:Predicates.subst + -> ?pi:pi + -> ?sigma:sigma + -> ?pi_fp:pi + -> ?sigma_fp:sigma + -> 'a t + -> exposed t (** Set individual fields of the prop. *) val unsafe_cast_to_normal : exposed t -> normal t @@ -68,7 +74,7 @@ end = struct [sigma] is sorted and normalized. *) type 'a t = { sigma: sigma (** spatial part *) - ; sub: Sil.subst (** substitution *) + ; sub: Predicates.subst (** substitution *) ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } @@ -77,7 +83,7 @@ end = struct let has_footprint {sigma_fp; pi_fp} = not (List.is_empty sigma_fp && List.is_empty pi_fp) (** Proposition [true /\ emp]. *) - let prop_emp : normal t = {sub= Sil.sub_empty; pi= []; sigma= []; pi_fp= []; sigma_fp= []} + let prop_emp : normal t = {sub= Predicates.sub_empty; pi= []; sigma= []; pi_fp= []; sigma_fp= []} let set ?sub ?pi ?sigma ?pi_fp ?sigma_fp p = let set_ p ?(sub = p.sub) ?(pi = p.pi) ?(sigma = p.sigma) ?(pi_fp = p.pi_fp) @@ -113,7 +119,7 @@ let pp_texp_simple pe = (** Pretty print a pointsto representing a stack variable as an equality *) let pp_hpred_stackvar = - Pp.color_wrapper ~f:(fun pe f (hpred : Sil.hpred) -> + Pp.color_wrapper ~f:(fun pe f (hpred : Predicates.hpred) -> match hpred with | Hpointsto (Exp.Lvar pvar, se, te) -> let pe' = @@ -123,7 +129,8 @@ let pp_hpred_stackvar = | _ -> pe in - F.fprintf f "%a = %a:%a" Pvar.pp_value pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te + F.fprintf f "%a = %a:%a" Pvar.pp_value pvar (Predicates.pp_sexp pe') se + (pp_texp_simple pe') te | Hpointsto _ | Hlseg _ | Hdllseg _ -> assert false (* should not happen *) ) @@ -131,12 +138,14 @@ let pp_hpred_stackvar = (** Pretty print a substitution. *) let pp_sub pe f sub = - let pi_sub = List.map ~f:(fun (id, e) -> Sil.Aeq (Var id, e)) (Sil.sub_to_list sub) in - Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Sil.pp_atom pe) f pi_sub + let pi_sub = + List.map ~f:(fun (id, e) -> Predicates.Aeq (Var id, e)) (Predicates.sub_to_list sub) + in + Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Predicates.pp_atom pe) f pi_sub (** Dump a substitution. *) -let d_sub (sub : Sil.subst) = L.d_pp_with_pe pp_sub sub +let d_sub (sub : Predicates.subst) = L.d_pp_with_pe pp_sub sub let pp_sub_entry = Pp.color_wrapper ~f:(fun pe f entry -> @@ -152,21 +161,21 @@ let pp_subl pe = (** Pretty print a pi. *) let pp_pi pe = - if Config.smt_output then Pp.semicolon_seq ~print_env:pe (Sil.pp_atom pe) - else Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Sil.pp_atom pe) + if Config.smt_output then Pp.semicolon_seq ~print_env:pe (Predicates.pp_atom pe) + else Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Predicates.pp_atom pe) (** Dump a pi. *) let d_pi (pi : pi) = L.d_pp_with_pe pp_pi pi (** Pretty print a sigma. *) -let pp_sigma pe = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred pe) +let pp_sigma pe = Pp.semicolon_seq ~print_env:pe (Predicates.pp_hpred pe) (** Split sigma into stack and nonstack parts. The boolean indicates whether the stack should only include local variales. *) let sigma_get_stack_nonstack only_local_vars sigma = let hpred_is_stack_var = function - | Sil.Hpointsto (Lvar pvar, _, _) -> + | Predicates.Hpointsto (Lvar pvar, _, _) -> (not only_local_vars) || Pvar.is_local pvar | _ -> false @@ -178,11 +187,13 @@ let sigma_get_stack_nonstack only_local_vars sigma = let pp_sigma_simple pe env fmt sigma = let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in let pp_stack fmt sg_ = - let sg = List.sort ~compare:Sil.compare_hpred sg_ in + let sg = List.sort ~compare:Predicates.compare_hpred sg_ in if sg <> [] then (Pp.semicolon_seq ~print_env:pe (pp_hpred_stackvar pe)) fmt sg in let pp_nl fmt doit = if doit then Format.fprintf fmt " ;@\n" in - let pp_nonstack fmt = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env)) fmt in + let pp_nonstack fmt = + Pp.semicolon_seq ~print_env:pe (Predicates.pp_hpred_env pe (Some env)) fmt + in if sigma_stack <> [] || sigma_nonstack <> [] then Format.fprintf fmt "%a%a%a" pp_stack sigma_stack pp_nl (sigma_stack <> [] && sigma_nonstack <> []) @@ -198,7 +209,9 @@ let d_pi_sigma pi sigma = d_pi pi ; d_separator () ; d_sigma sigma -let pi_of_subst sub = List.map ~f:(fun (id1, e2) -> Sil.Aeq (Var id1, e2)) (Sil.sub_to_list sub) +let pi_of_subst sub = + List.map ~f:(fun (id1, e2) -> Predicates.Aeq (Var id1, e2)) (Predicates.sub_to_list sub) + (** Return the pure part of [prop]. *) let get_pure (p : 'a t) : pi = pi_of_subst p.sub @ p.pi @@ -213,16 +226,16 @@ let get_pure_extended p = let extend_atoms id pid = try let old_id = Ident.Map.find pid primed_map in - let new_atom = Sil.Aeq (Var id, Var old_id) in + let new_atom = Predicates.Aeq (Var id, Var old_id) in (new_atom :: atoms, primed_map) with Caml.Not_found -> (atoms, Ident.Map.add pid id primed_map) in match base_atom with - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id0 && not (Ident.is_primed id1) - -> + | Predicates.Aeq (Exp.Var id0, Exp.Var id1) + when Ident.is_primed id0 && not (Ident.is_primed id1) -> extend_atoms id1 id0 - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id1 && not (Ident.is_primed id0) - -> + | Predicates.Aeq (Exp.Var id0, Exp.Var id1) + when Ident.is_primed id1 && not (Ident.is_primed id0) -> extend_atoms id0 id1 | _ -> acc ) @@ -237,25 +250,25 @@ let pp_evars f evars = if evars <> [] then F.fprintf f "exists [%a]. " (Pp.comma let pp_hpara_simple pe_ env n f pred = let pe = Pp.reset_obj_sub pe_ in (* no free vars: disable object substitution *) - F.fprintf f "P%d = %a%a" n pp_evars pred.Sil.evars - (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) - pred.Sil.body + F.fprintf f "P%d = %a%a" n pp_evars pred.Predicates.evars + (Pp.semicolon_seq ~print_env:pe (Predicates.pp_hpred_env pe (Some env))) + pred.Predicates.body (** Print an hpara_dll in simple mode *) let pp_hpara_dll_simple pe_ env n f pred = let pe = Pp.reset_obj_sub pe_ in (* no free vars: disable object substitution *) - F.fprintf f "P%d = %a%a" n pp_evars pred.Sil.evars_dll - (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) - pred.Sil.body_dll + F.fprintf f "P%d = %a%a" n pp_evars pred.Predicates.evars_dll + (Pp.semicolon_seq ~print_env:pe (Predicates.pp_hpred_env pe (Some env))) + pred.Predicates.body_dll (** Create an environment mapping (ident) expressions to the program variables containing them *) let create_pvar_env (sigma : sigma) : Exp.t -> Exp.t = let env = ref [] in let filter = function - | Sil.Hpointsto (Lvar pvar, Eexp (Var v, _), _) -> + | Predicates.Hpointsto (Lvar pvar, Eexp (Var v, _), _) -> if not (Pvar.is_global pvar) then env := (Exp.Var v, Exp.Lvar pvar) :: !env | _ -> () @@ -282,9 +295,9 @@ let pp_footprint_simple pe_ env f fp = (** Create a predicate environment for a prop *) let prop_pred_env prop = - let env = Sil.Predicates.empty_env () in - List.iter ~f:(Sil.Predicates.process_hpred env) prop.sigma ; - List.iter ~f:(Sil.Predicates.process_hpred env) prop.sigma_fp ; + let env = Predicates.Env.mk_empty () in + List.iter ~f:(Predicates.Env.process_hpred env) prop.sigma ; + List.iter ~f:(Predicates.Env.process_hpred env) prop.sigma_fp ; env @@ -292,7 +305,7 @@ let prop_pred_env prop = let pp_prop pe0 f prop = let pe = prop_update_obj_sub pe0 prop in let do_print f () = - let subl = Sil.sub_to_list prop.sub in + let subl = Predicates.sub_to_list prop.sub in (* since prop diff is based on physical equality, we need to extract the sub verbatim *) let pi = prop.pi in let pp_pure f () = @@ -305,10 +318,10 @@ let pp_prop pe0 f prop = F.fprintf f "@,@[%a@]" (pp_hpara_dll_simple pe env n) hpara_dll in let pp_predicates _ () = - if Sil.Predicates.is_empty env then () + if Predicates.Env.is_empty env then () else ( F.fprintf f "@,where" ; - Sil.Predicates.iter env iter_f iter_f_dll ) + Predicates.Env.iter env iter_f iter_f_dll ) in F.fprintf f "%a%a%a%a" pp_pure () (pp_sigma_simple pe env) prop.sigma (pp_footprint_simple pe env) prop pp_predicates () @@ -339,11 +352,11 @@ let d_proplist_with_typ (pl : 'a t list) = L.d_pp_with_pe pp_proplist_with_typ p (** {1 Functions for computing free non-program variables} *) -let pi_gen_free_vars pi = ISequence.gen_sequence_list pi ~f:Sil.atom_gen_free_vars +let pi_gen_free_vars pi = ISequence.gen_sequence_list pi ~f:Predicates.atom_gen_free_vars let pi_free_vars pi = Sequence.Generator.run (pi_gen_free_vars pi) -let sigma_gen_free_vars sigma = ISequence.gen_sequence_list sigma ~f:Sil.hpred_gen_free_vars +let sigma_gen_free_vars sigma = ISequence.gen_sequence_list sigma ~f:Predicates.hpred_gen_free_vars let sigma_free_vars sigma = Sequence.Generator.run (sigma_gen_free_vars sigma) @@ -353,7 +366,8 @@ let gen_free_vars {sigma; sigma_fp; sub; pi; pi_fp} = >>= fun () -> sigma_gen_free_vars sigma_fp >>= fun () -> - Sil.subst_gen_free_vars sub >>= fun () -> pi_gen_free_vars pi >>= fun () -> pi_gen_free_vars pi_fp + Predicates.subst_gen_free_vars sub + >>= fun () -> pi_gen_free_vars pi >>= fun () -> pi_gen_free_vars pi_fp let free_vars prop = Sequence.Generator.run (gen_free_vars prop) @@ -383,18 +397,18 @@ let non_pure_free_vars prop = Sequence.Generator.run (non_pure_gen_free_vars pro (** {2 Functions for Subsitition} *) -let pi_sub (subst : Sil.subst) pi = - let f = Sil.atom_sub subst in +let pi_sub (subst : Predicates.subst) pi = + let f = Predicates.atom_sub subst in List.map ~f pi let sigma_sub subst sigma = - let f = Sil.hpred_sub subst in + let f = Predicates.hpred_sub subst in List.map ~f sigma (** Return [true] if the atom is an inequality *) -let atom_is_inequality (atom : Sil.atom) = +let atom_is_inequality (atom : Predicates.atom) = match atom with | Aeq (BinOp ((Le | Lt), _, _), Const (Cint i)) when IntLit.isone i -> true @@ -403,7 +417,7 @@ let atom_is_inequality (atom : Sil.atom) = (** If the atom is [e<=n] return [e,n] *) -let atom_exp_le_const (atom : Sil.atom) = +let atom_exp_le_const (atom : Predicates.atom) = match atom with | Aeq (BinOp (Le, e1, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> Some (e1, n) @@ -412,7 +426,7 @@ let atom_exp_le_const (atom : Sil.atom) = (** If the atom is [n Some (n, e1) @@ -431,7 +445,8 @@ let rec pp_path f = function (** create a strexp of the given type, populating the structures if [struct_init_mode] is [Fld_init] *) -let rec create_strexp_of_type ~path tenv struct_init_mode (typ : Typ.t) len inst : Sil.strexp = +let rec create_strexp_of_type ~path tenv struct_init_mode (typ : Typ.t) len inst : Predicates.strexp + = let init_value () = let create_fresh_var () = let fresh_id = @@ -439,7 +454,7 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ : Typ.t) len inst in Exp.Var fresh_id in - if Language.curr_language_is Java && Sil.equal_inst inst Sil.Ialloc then + if Language.curr_language_is Java && Predicates.equal_inst inst Predicates.Ialloc then match typ.desc with Tfloat _ -> Exp.Const (Cfloat 0.0) | _ -> Exp.zero else create_fresh_var () in @@ -478,13 +493,13 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ : Typ.t) len inst assert false -let create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil.strexp = +let create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Predicates.strexp = create_strexp_of_type ~path:[] tenv struct_init_mode (typ : Typ.t) len inst -let replace_array_contents (hpred : Sil.hpred) esel : Sil.hpred = +let replace_array_contents (hpred : Predicates.hpred) esel : Predicates.hpred = match hpred with - | Hpointsto (root, Sil.Earray (len, [], inst), te) -> + | Hpointsto (root, Predicates.Earray (len, [], inst), te) -> Hpointsto (root, Earray (len, esel, inst), te) | _ -> assert false @@ -504,7 +519,7 @@ let rec pi_sorted_remove_redundant (pi : pi) = (* first inequality redundant *) pi_sorted_remove_redundant (a2 :: rest) | a1 :: a2 :: rest -> - if Sil.equal_atom a1 a2 then pi_sorted_remove_redundant (a2 :: rest) + if Predicates.equal_atom a1 a2 then pi_sorted_remove_redundant (a2 :: rest) else a1 :: pi_sorted_remove_redundant (a2 :: rest) | [a] -> [a] @@ -515,7 +530,7 @@ let rec pi_sorted_remove_redundant (pi : pi) = (** find the unsigned expressions in sigma (immediately inside a pointsto, for now) *) let sigma_get_unsigned_exps sigma = let uexps = ref [] in - let do_hpred (hpred : Sil.hpred) = + let do_hpred (hpred : Predicates.hpred) = match hpred with | Hpointsto (_, Eexp (e, _), Sizeof {typ= {desc= Tint ik}}) when Typ.ikind_is_unsigned ik -> uexps := e :: !uexps @@ -550,7 +565,7 @@ let exp_collapse_consecutive_indices_prop (typ : Typ.t) exp = (** Return a compact representation of the prop *) let prop_compact sh (prop : normal t) : normal t = - let sigma' = List.map ~f:(Sil.hpred_compact sh) prop.sigma in + let sigma' = List.map ~f:(Predicates.hpred_compact sh) prop.sigma in unsafe_cast_to_normal (set prop ~sigma:sigma') @@ -562,7 +577,7 @@ let prop_is_emp p = match p.sigma with [] -> true | _ -> false (** {2 Functions for changing and generating propositions} *) (** Conjoin a heap predicate by separating conjunction. *) -let prop_hpred_star (p : 'a t) (h : Sil.hpred) : exposed t = +let prop_hpred_star (p : 'a t) (h : Predicates.hpred) : exposed t = let sigma' = h :: p.sigma in set p ~sigma:sigma' @@ -586,9 +601,9 @@ module Normalize = struct match sigma1 with | [] -> set - | Hpointsto (e, _, _) :: sigma' | Hlseg (Sil.Lseg_NE, _, e, _, _) :: sigma' -> + | Hpointsto (e, _, _) :: sigma' | Hlseg (Predicates.Lseg_NE, _, e, _, _) :: sigma' -> f_alloc (Exp.Set.add e set) sigma' - | Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma' -> + | Hdllseg (Predicates.Lseg_NE, _, iF, _, _, iB, _) :: sigma' -> f_alloc (Exp.Set.add iF (Exp.Set.add iB set)) sigma' | _ :: sigma' -> f_alloc set sigma' @@ -603,13 +618,13 @@ module Normalize = struct f eqs_zero (hpred :: sigma_passed) sigma' | Hlseg (Lseg_PE, _, e1, e2, _) :: sigma' when Exp.equal e1 Exp.zero || Exp.Set.mem e1 alloc_set -> - f (Sil.Aeq (e1, e2) :: eqs_zero) sigma_passed sigma' + f (Predicates.Aeq (e1, e2) :: eqs_zero) sigma_passed sigma' | (Hlseg _ as hpred) :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' | Hdllseg (Lseg_PE, _, iF, oB, oF, iB, _) :: sigma' when Exp.equal iF Exp.zero || Exp.Set.mem iF alloc_set || Exp.equal iB Exp.zero || Exp.Set.mem iB alloc_set -> - f (Sil.Aeq (iF, oF) :: Sil.Aeq (iB, oB) :: eqs_zero) sigma_passed sigma' + f (Predicates.Aeq (iF, oF) :: Predicates.Aeq (iB, oB) :: eqs_zero) sigma_passed sigma' | (Hdllseg _ as hpred) :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' in @@ -625,7 +640,7 @@ module Normalize = struct f (hpred :: sigma_passed) sigma' | Hlseg (Lseg_PE, para, f1, f2, shared) :: sigma' when (Exp.equal e1 f1 && Exp.equal e2 f2) || (Exp.equal e2 f1 && Exp.equal e1 f2) -> - f (Sil.Hlseg (Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' + f (Predicates.Hlseg (Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' | (Hlseg _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' | Hdllseg (Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma' @@ -633,7 +648,7 @@ module Normalize = struct || (Exp.equal e2 iF && Exp.equal e1 oF) || (Exp.equal e1 iB && Exp.equal e2 oB) || (Exp.equal e2 iB && Exp.equal e1 oB) -> - f (Sil.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' + f (Predicates.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' | (Hdllseg _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' in @@ -647,7 +662,7 @@ module Normalize = struct let sym_eval ?(destructive = false) tenv abs e = let lookup = Tenv.lookup tenv in let rec eval (e : Exp.t) : Exp.t = - (* L.d_str " ["; Sil.d_exp e; L.d_str"] "; *) + (* L.d_str " ["; Predicates.d_exp e; L.d_str"] "; *) match e with | Var _ -> e @@ -1044,12 +1059,12 @@ module Normalize = struct Lindex (e1', e2') in let e' = eval e in - (* L.d_str "sym_eval "; Sil.d_exp e; L.d_str" --> "; Sil.d_exp e'; L.d_ln (); *) + (* L.d_str "sym_eval "; Predicates.d_exp e; L.d_str" --> "; Predicates.d_exp e'; L.d_ln (); *) if Exp.equal e e' then e else e' let exp_normalize ?destructive tenv sub exp = - let exp' = Sil.exp_sub sub exp in + let exp' = Predicates.exp_sub sub exp in let abstract_expressions = !BiabductionConfig.abs_val >= 1 in sym_eval ?destructive tenv abstract_expressions exp' @@ -1071,11 +1086,11 @@ module Normalize = struct (** Turn an inequality expression into an atom *) - let mk_inequality tenv (e : Exp.t) : Sil.atom = + let mk_inequality tenv (e : Exp.t) : Predicates.atom = match e with | BinOp (Le, base, Const (Cint n)) -> ( (* base <= n case *) - let nbase = exp_normalize_noabs tenv Sil.sub_empty base in + let nbase = exp_normalize_noabs tenv Predicates.sub_empty base in match nbase with | BinOp (PlusA _, base', Const (Cint n')) -> let new_offset = Exp.int (n -- n') in @@ -1102,7 +1117,7 @@ module Normalize = struct Aeq (e, Exp.one) ) | BinOp (Lt, Const (Cint n), base) -> ( (* n < base case *) - let nbase = exp_normalize_noabs tenv Sil.sub_empty base in + let nbase = exp_normalize_noabs tenv Predicates.sub_empty base in match nbase with | BinOp (PlusA _, base', Const (Cint n')) -> let new_offset = Exp.int (n -- n') in @@ -1132,7 +1147,7 @@ module Normalize = struct (** Normalize an inequality *) - let inequality_normalize tenv (a : Sil.atom) = + let inequality_normalize tenv (a : Predicates.atom) = (* turn an expression into a triple (pos,neg,off) of positive and negative occurrences, and integer offset representing inequality [sum(pos) - sum(neg) + off <= 0] *) let rec exp_to_posnegoff (e : Exp.t) = @@ -1210,7 +1225,7 @@ module Normalize = struct (** Normalize an atom. We keep the convention that inequalities with constants are only of the form [e <= n] and [n < e]. *) let atom_normalize tenv sub a0 = - let a = Sil.atom_sub sub a0 in + let a = Predicates.atom_sub sub a0 in let rec normalize_eq (eq : Exp.t * Exp.t) = match eq with | BinOp (PlusA _, e1, Const (Cint n1)), Const (Cint n2) @@ -1249,7 +1264,7 @@ module Normalize = struct | _ -> (e1, e2, false) in - let handle_boolean_operation orig_a from_equality e1 e2 : Sil.atom = + let handle_boolean_operation orig_a from_equality e1 e2 : Predicates.atom = let ne1 = exp_normalize tenv sub e1 in let ne2 = exp_normalize tenv sub e2 in let ne1', ne2', op_negated = handle_unary_negation ne1 ne2 in @@ -1261,7 +1276,7 @@ module Normalize = struct else if use_equality then Aeq (e1'', e2'') else Aneq (e1'', e2'') in - let a' : Sil.atom = + let a' : Predicates.atom = match a with | Aeq (e1, e2) -> handle_boolean_operation a true e1 e2 @@ -1277,24 +1292,25 @@ module Normalize = struct if atom_is_inequality a' then inequality_normalize tenv a' else a' - let normalize_and_strengthen_atom tenv (p : normal t) (a : Sil.atom) : Sil.atom = + let normalize_and_strengthen_atom tenv (p : normal t) (a : Predicates.atom) : Predicates.atom = let a' = atom_normalize tenv p.sub a in match a' with | Aeq (BinOp (Le, Var id, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> let lower = Exp.int (n -- IntLit.one) in - let a_lower : Sil.atom = Aeq (BinOp (Lt, lower, Var id), Exp.one) in - if not (List.mem ~equal:Sil.equal_atom p.pi a_lower) then a' else Aeq (Var id, Exp.int n) + let a_lower : Predicates.atom = Aeq (BinOp (Lt, lower, Var id), Exp.one) in + if not (List.mem ~equal:Predicates.equal_atom p.pi a_lower) then a' + else Aeq (Var id, Exp.int n) | Aeq (BinOp (Lt, Const (Cint n), Var id), Const (Cint i)) when IntLit.isone i -> let upper = Exp.int (n ++ IntLit.one) in - let a_upper : Sil.atom = Aeq (BinOp (Le, Var id, upper), Exp.one) in - if not (List.mem ~equal:Sil.equal_atom p.pi a_upper) then a' else Aeq (Var id, upper) + let a_upper : Predicates.atom = Aeq (BinOp (Le, Var id, upper), Exp.one) in + if not (List.mem ~equal:Predicates.equal_atom p.pi a_upper) then a' else Aeq (Var id, upper) | Aeq (BinOp (Ne, e1, e2), Const (Cint i)) when IntLit.isone i -> Aneq (e1, e2) | _ -> a' - let rec strexp_normalize tenv sub (se : Sil.strexp) : Sil.strexp = + let rec strexp_normalize tenv sub (se : Predicates.strexp) : Predicates.strexp = match se with | Eexp (e, inst) -> let e' = exp_normalize tenv sub e in @@ -1305,18 +1321,18 @@ module Normalize = struct se | _ :: _ -> let fld_cnts' = - IList.map_changed fld_cnts ~equal:[%compare.equal: Typ.Fieldname.t * Sil.strexp] + IList.map_changed fld_cnts ~equal:[%compare.equal: Typ.Fieldname.t * Predicates.strexp] ~f:(fun ((fld, cnt) as x) -> let cnt' = strexp_normalize tenv sub cnt in if phys_equal cnt cnt' then x else (fld, cnt') ) in if phys_equal fld_cnts fld_cnts' - && List.is_sorted ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] fld_cnts + && List.is_sorted ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp] fld_cnts then se else let fld_cnts'' = - List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] fld_cnts' + List.sort ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp] fld_cnts' in Estruct (fld_cnts'', inst) ) | Earray (len, idx_cnts, inst) -> ( @@ -1326,7 +1342,7 @@ module Normalize = struct if Exp.equal len len' then se else Earray (len', idx_cnts, inst) | _ :: _ -> let idx_cnts' = - IList.map_changed idx_cnts ~equal:[%compare.equal: Exp.t * Sil.strexp] + IList.map_changed idx_cnts ~equal:[%compare.equal: Exp.t * Predicates.strexp] ~f:(fun ((idx, cnt) as x) -> let idx' = exp_normalize tenv sub idx in let cnt' = strexp_normalize tenv sub cnt in @@ -1334,24 +1350,24 @@ module Normalize = struct in if phys_equal idx_cnts idx_cnts' - && List.is_sorted ~compare:[%compare: Exp.t * Sil.strexp] idx_cnts + && List.is_sorted ~compare:[%compare: Exp.t * Predicates.strexp] idx_cnts then se else - let idx_cnts'' = List.sort ~compare:[%compare: Exp.t * Sil.strexp] idx_cnts' in + let idx_cnts'' = List.sort ~compare:[%compare: Exp.t * Predicates.strexp] idx_cnts' in Earray (len', idx_cnts'', inst) ) (** Exp.Construct a pointsto. *) - let mk_ptsto tenv lexp sexp te : Sil.hpred = - let nsexp = strexp_normalize tenv Sil.sub_empty sexp in + let mk_ptsto tenv lexp sexp te : Predicates.hpred = + let nsexp = strexp_normalize tenv Predicates.sub_empty sexp in Hpointsto (lexp, nsexp, te) (** Construct a points-to predicate for an expression using either the provided expression [name] as base for fresh identifiers. If [struct_init_mode] is [Fld_init], initialize the fields of structs with fresh variables. *) - let mk_ptsto_exp tenv struct_init_mode (exp, (te : Exp.t), expo) inst : Sil.hpred = - let default_strexp () : Sil.strexp = + let mk_ptsto_exp tenv struct_init_mode (exp, (te : Exp.t), expo) inst : Predicates.hpred = + let default_strexp () : Predicates.strexp = match te with | Sizeof {typ; dynamic_length} -> create_strexp_of_type tenv struct_init_mode typ dynamic_length inst @@ -1361,7 +1377,7 @@ module Normalize = struct L.internal_error "trying to create ptsto with type: %a@." (Exp.pp_texp_full Pp.text) te ; assert false in - let strexp : Sil.strexp = + let strexp : Predicates.strexp = match expo with Some e -> Eexp (e, inst) | None -> default_strexp () in mk_ptsto tenv exp strexp te @@ -1373,10 +1389,9 @@ module Normalize = struct particular, we have &var -> id iff we also have the pair (id, var) as part of captured variables. *) let make_captured_in_closures_consistent sigma = - let open Sil in let find_correct_captured captured = let find_captured_variable_in_the_heap captured' hpred = - match hpred with + match (hpred : Predicates.hpred) with | Hpointsto (Exp.Lvar var, Eexp (Exp.Var id, _), _) -> IList.map_changed ~equal:phys_equal ~f:(fun ((e_captured, var_captured, t) as captured_item) -> @@ -1403,7 +1418,7 @@ module Normalize = struct | _ -> exp in - let rec process_closures_in_se se = + let rec process_closures_in_se (se : Predicates.strexp) : Predicates.strexp = match se with | Eexp (exp, inst) -> let new_exp = process_closures exp in @@ -1420,7 +1435,7 @@ module Normalize = struct | _ -> se in - let process_closures_in_the_heap hpred = + let process_closures_in_the_heap (hpred : Predicates.hpred) : Predicates.hpred = match hpred with | Hpointsto (e, se, inst) -> let new_se = process_closures_in_se se in @@ -1431,14 +1446,14 @@ module Normalize = struct List.map ~f:process_closures_in_the_heap sigma - let rec hpred_normalize tenv sub (hpred : Sil.hpred) : Sil.hpred = + let rec hpred_normalize tenv sub (hpred : Predicates.hpred) : Predicates.hpred = let replace_hpred hpred' = L.d_strln "found array with sizeof(..) size" ; L.d_str "converting original hpred: " ; - Sil.d_hpred hpred ; + Predicates.d_hpred hpred ; L.d_ln () ; L.d_str "into the following: " ; - Sil.d_hpred hpred' ; + Predicates.d_hpred hpred' ; L.d_ln () ; hpred' in @@ -1507,15 +1522,15 @@ module Normalize = struct Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist) - and hpara_normalize tenv (para : Sil.hpara) = - let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body in - let sorted_body = List.sort ~compare:Sil.compare_hpred normalized_body in + and hpara_normalize tenv (para : Predicates.hpara) = + let normalized_body = List.map ~f:(hpred_normalize tenv Predicates.sub_empty) para.body in + let sorted_body = List.sort ~compare:Predicates.compare_hpred normalized_body in {para with body= sorted_body} - and hpara_dll_normalize tenv (para : Sil.hpara_dll) = - let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body_dll in - let sorted_body = List.sort ~compare:Sil.compare_hpred normalized_body in + and hpara_dll_normalize tenv (para : Predicates.hpara_dll) = + let normalized_body = List.map ~f:(hpred_normalize tenv Predicates.sub_empty) para.body_dll in + let sorted_body = List.sort ~compare:Predicates.compare_hpred normalized_body in {para with body_dll= sorted_body} @@ -1523,7 +1538,7 @@ module Normalize = struct let sigma' = List.map ~f:(hpred_normalize tenv sub) sigma |> make_captured_in_closures_consistent - |> List.stable_sort ~compare:Sil.compare_hpred + |> List.stable_sort ~compare:Predicates.compare_hpred in if equal_sigma sigma sigma' then sigma else sigma' @@ -1531,7 +1546,7 @@ module Normalize = struct let pi_tighten_ineq tenv pi = let ineq_list, nonineq_list = List.partition_tf ~f:atom_is_inequality pi in let diseq_list = - let get_disequality_info acc (a : Sil.atom) = + let get_disequality_info acc (a : Predicates.atom) = match a with | Aneq (Const (Cint n), e) | Aneq (e, Const (Cint n)) -> (e, n) :: acc @@ -1584,7 +1599,7 @@ module Normalize = struct in let nonineq_list' = List.filter - ~f:(fun (a : Sil.atom) -> + ~f:(fun (a : Predicates.atom) -> match a with | Aneq (Const (Cint n), e) | Aneq (e, Const (Cint n)) -> (not @@ -1617,7 +1632,7 @@ module Normalize = struct | _ -> false in - let filter_useful_atom : Sil.atom -> bool = + let filter_useful_atom : Predicates.atom -> bool = let unsigned_exps = lazy (sigma_get_unsigned_exps sigma) in function | Aneq ((Var _ as e), Const (Cint n)) when IntLit.isnegative n -> @@ -1630,7 +1645,7 @@ module Normalize = struct true in let pi' = - List.stable_sort ~compare:Sil.compare_atom + List.stable_sort ~compare:Predicates.compare_atom (List.filter ~f:filter_useful_atom nonineq_list @ ineq_list) in let pi'' = pi_sorted_remove_redundant pi' in @@ -1640,8 +1655,8 @@ module Normalize = struct (** normalize the footprint part, and rename any primed vars in the footprint with fresh footprint vars *) let footprint_normalize tenv prop = - let nsigma = sigma_normalize tenv Sil.sub_empty prop.sigma_fp in - let npi = pi_normalize tenv Sil.sub_empty nsigma prop.pi_fp in + let nsigma = sigma_normalize tenv Predicates.sub_empty prop.sigma_fp in + let npi = pi_normalize tenv Predicates.sub_empty nsigma prop.pi_fp in let ids_primed = let fav = pi_free_vars npi |> Sequence.filter ~f:Ident.is_primed |> Ident.hashqueue_of_sequence @@ -1660,10 +1675,11 @@ module Normalize = struct List.map ~f:(fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in let ren_sub = - Sil.subst_of_list (List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_footprint) + Predicates.subst_of_list + (List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_footprint) in - let nsigma' = sigma_normalize tenv Sil.sub_empty (sigma_sub ren_sub nsigma) in - let npi' = pi_normalize tenv Sil.sub_empty nsigma' (pi_sub ren_sub npi) in + let nsigma' = sigma_normalize tenv Predicates.sub_empty (sigma_sub ren_sub nsigma) in + let npi' = pi_normalize tenv Predicates.sub_empty nsigma' (pi_sub ren_sub npi) in (npi', nsigma') in set prop ~pi_fp:npi' ~sigma_fp:nsigma' @@ -1672,14 +1688,14 @@ module Normalize = struct (** This function assumes that if (x,Exp.Var(y)) in sub, then compare x y = 1 *) let sub_normalize sub = let f (id, e) = (not (Ident.is_primed id)) && not (Exp.ident_mem e id) in - let sub' = Sil.sub_filter_pair ~f sub in - if Sil.equal_subst sub sub' then sub else sub' + let sub' = Predicates.sub_filter_pair ~f sub in + if Predicates.equal_subst sub sub' then sub else sub' (** Conjoin a pure atomic predicate by normal conjunction. *) let rec prop_atom_and tenv ?(footprint = false) (p : normal t) a : normal t = let a' = normalize_and_strengthen_atom tenv p a in - if List.mem ~equal:Sil.equal_atom p.pi a' then p + if List.mem ~equal:Predicates.equal_atom p.pi a' then p else let p' = match a' with @@ -1687,9 +1703,11 @@ module Normalize = struct p | Aeq (Var i, e) -> let sub_list = [(i, e)] in - let mysub = Sil.subst_of_list sub_list in - let p_sub = Sil.sub_filter (fun i' -> not (Ident.equal i i')) p.sub in - let sub' = Sil.sub_join mysub (Sil.sub_range_map (Sil.exp_sub mysub) p_sub) in + let mysub = Predicates.subst_of_list sub_list in + let p_sub = Predicates.sub_filter (fun i' -> not (Ident.equal i i')) p.sub in + let sub' = + Predicates.sub_join mysub (Predicates.sub_range_map (Predicates.exp_sub mysub) p_sub) + in let nsub', npi', nsigma' = let nsigma' = sigma_normalize tenv sub' p.sigma in (sub_normalize sub', pi_normalize tenv sub' nsigma' p.pi, nsigma') @@ -1710,14 +1728,14 @@ module Normalize = struct if not footprint then p' else let predicate_warning = - not (Sil.atom_free_vars a' |> Sequence.for_all ~f:Ident.is_footprint) + not (Predicates.atom_free_vars a' |> Sequence.for_all ~f:Ident.is_footprint) in let p'' = if predicate_warning then footprint_normalize tenv p' else match a' with | Aeq (Exp.Var i, e) when not (Exp.ident_mem e i) -> - let mysub = Sil.subst_of_list [(i, e)] in + let mysub = Predicates.subst_of_list [(i, e)] in let sigma_fp' = sigma_normalize tenv mysub p'.sigma_fp in let pi_fp' = a' :: pi_normalize tenv mysub sigma_fp' p'.pi_fp in footprint_normalize tenv (set p' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp') @@ -1726,7 +1744,7 @@ module Normalize = struct in if predicate_warning then ( L.d_warning "dropping non-footprint " ; - Sil.d_atom a' ; + Predicates.d_atom a' ; L.d_ln () ) ; unsafe_cast_to_normal p'' @@ -1734,7 +1752,8 @@ module Normalize = struct (** normalize a prop *) let normalize tenv (eprop : 'a t) : normal t = let p0 = - unsafe_cast_to_normal (set prop_emp ~sigma:(sigma_normalize tenv Sil.sub_empty eprop.sigma)) + unsafe_cast_to_normal + (set prop_emp ~sigma:(sigma_normalize tenv Predicates.sub_empty eprop.sigma)) in let nprop = List.fold ~f:(prop_atom_and tenv) ~init:p0 (get_pure_extended eprop) in unsafe_cast_to_normal @@ -1751,15 +1770,19 @@ let exp_normalize_prop ?destructive tenv prop exp = let lexp_normalize_prop tenv p lexp = let root = Exp.root_of_lexp lexp in - let offsets = Sil.exp_get_offsets lexp in + let offsets = Predicates.exp_get_offsets lexp in let nroot = exp_normalize_prop tenv p root in let noffsets = List.map - ~f:(fun (n : Sil.offset) -> - match n with Off_fld _ -> n | Off_index e -> Sil.Off_index (exp_normalize_prop tenv p e) ) + ~f:(fun (n : Predicates.offset) -> + match n with + | Off_fld _ -> + n + | Off_index e -> + Predicates.Off_index (exp_normalize_prop tenv p e) ) offsets in - Sil.exp_add_offsets nroot noffsets + Predicates.exp_add_offsets nroot noffsets let atom_normalize_prop tenv prop atom = @@ -1771,14 +1794,14 @@ let sigma_normalize_prop tenv prop sigma = let sigma_replace_exp tenv epairs sigma = - let sigma' = List.map ~f:(Sil.hpred_replace_exp epairs) sigma in - Normalize.sigma_normalize tenv Sil.sub_empty sigma' + let sigma' = List.map ~f:(Predicates.hpred_replace_exp epairs) sigma in + Normalize.sigma_normalize tenv Predicates.sub_empty sigma' (** Construct an atom. *) let mk_atom tenv atom = BiabductionConfig.run_with_abs_val_equal_zero - (fun () -> Normalize.atom_normalize tenv Sil.sub_empty atom) + (fun () -> Normalize.atom_normalize tenv Predicates.sub_empty atom) () @@ -1795,20 +1818,20 @@ let mk_pred tenv a es = mk_atom tenv (Apred (a, es)) let mk_npred tenv a es = mk_atom tenv (Anpred (a, es)) (** Exp.Construct a lseg predicate *) -let mk_lseg tenv k para e_start e_end es_shared : Sil.hpred = +let mk_lseg tenv k para e_start e_end es_shared : Predicates.hpred = let npara = Normalize.hpara_normalize tenv para in Hlseg (k, npara, e_start, e_end, es_shared) (** Exp.Construct a dllseg predicate *) -let mk_dllseg tenv k para exp_iF exp_oB exp_oF exp_iB exps_shared : Sil.hpred = +let mk_dllseg tenv k para exp_iF exp_oB exp_oF exp_iB exps_shared : Predicates.hpred = let npara = Normalize.hpara_dll_normalize tenv para in Hdllseg (k, npara, exp_iF, exp_oB, exp_oF, exp_iB, exps_shared) (** Construct a points-to predicate for a single program variable. If [expand_structs] is [Fld_init], initialize the fields of structs with fresh variables. *) -let mk_ptsto_lvar tenv expand_structs inst ((pvar : Pvar.t), texp, expo) : Sil.hpred = +let mk_ptsto_lvar tenv expand_structs inst ((pvar : Pvar.t), texp, expo) : Predicates.hpred = Normalize.mk_ptsto_exp tenv expand_structs (Lvar pvar, texp, expo) inst @@ -1824,8 +1847,8 @@ let conjoin_neq tenv ?(footprint = false) exp1 exp2 prop = (** Reset every inst in the prop using the given map *) let prop_reset_inst inst_map prop = - let sigma' = List.map ~f:(Sil.hpred_instmap inst_map) prop.sigma in - let sigma_fp' = List.map ~f:(Sil.hpred_instmap inst_map) prop.sigma_fp in + let sigma' = List.map ~f:(Predicates.hpred_instmap inst_map) prop.sigma in + let sigma_fp' = List.map ~f:(Predicates.hpred_instmap inst_map) prop.sigma_fp in set prop ~sigma:sigma' ~sigma_fp:sigma_fp' @@ -1876,7 +1899,7 @@ end let sigma_get_start_lexps_sort sigma = let exp_compare_neg e1 e2 = -Exp.compare e1 e2 in let filter e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in - let lexps = Sil.hpred_list_get_lexps filter sigma in + let lexps = Predicates.hpred_list_get_lexps filter sigma in List.sort ~compare:exp_compare_neg lexps @@ -1886,7 +1909,7 @@ let sigma_dfs_sort tenv sigma = ExpStack.init start_lexps in let final () = ExpStack.final () in - let rec handle_strexp (se : Sil.strexp) = + let rec handle_strexp (se : Predicates.strexp) = match se with | Eexp (e, _) -> ExpStack.push e @@ -1918,7 +1941,7 @@ let sigma_dfs_sort tenv sigma = List.rev visited | cur -> if ExpStack.is_empty () then - let cur' = Normalize.sigma_normalize tenv Sil.sub_empty cur in + let cur' = Normalize.sigma_normalize tenv Predicates.sub_empty cur in List.rev_append cur' visited else let e = ExpStack.pop () in @@ -1940,7 +1963,7 @@ let dfs_sort tenv p : sorted t = unsafe_cast_to_sorted p' -let rec strexp_get_array_indices acc (se : Sil.strexp) = +let rec strexp_get_array_indices acc (se : Predicates.strexp) = match se with | Eexp _ -> acc @@ -1953,7 +1976,7 @@ let rec strexp_get_array_indices acc (se : Sil.strexp) = List.fold ~f:strexp_get_array_indices ~init:acc_new se_list -let hpred_get_array_indices acc (hpred : Sil.hpred) = +let hpred_get_array_indices acc (hpred : Predicates.hpred) = match hpred with | Hpointsto (_, se, _) -> strexp_get_array_indices acc se @@ -2000,21 +2023,21 @@ let compute_reindexing_from_indices list = (id, exp_new) in let reindexing = List.map ~f:transform list_passed in - Sil.subst_of_list reindexing + Predicates.subst_of_list reindexing -let apply_reindexing tenv (subst : Sil.subst) prop = +let apply_reindexing tenv (subst : Predicates.subst) prop = let nsigma = Normalize.sigma_normalize tenv subst prop.sigma in let npi = Normalize.pi_normalize tenv subst nsigma prop.pi in let nsub, atoms = - let dom_subst = List.map ~f:fst (Sil.sub_to_list subst) in + let dom_subst = List.map ~f:fst (Predicates.sub_to_list subst) in let in_dom_subst id = List.exists ~f:(Ident.equal id) dom_subst in - let sub' = Sil.sub_filter (fun id -> not (in_dom_subst id)) prop.sub in + let sub' = Predicates.sub_filter (fun id -> not (in_dom_subst id)) prop.sub in let contains_substituted_id e = Exp.free_vars e |> Sequence.exists ~f:in_dom_subst in - let sub_eqs, sub_keep = Sil.sub_range_partition contains_substituted_id sub' in - let eqs = Sil.sub_to_list sub_eqs in + let sub_eqs, sub_keep = Predicates.sub_range_partition contains_substituted_id sub' in + let eqs = Predicates.sub_to_list sub_eqs in let atoms = - List.map ~f:(fun (id, e) -> Sil.Aeq (Var id, Normalize.exp_normalize tenv subst e)) eqs + List.map ~f:(fun (id, e) -> Predicates.Aeq (Var id, Normalize.exp_normalize tenv subst e)) eqs in (sub_keep, atoms) in @@ -2109,7 +2132,7 @@ let rec exp_captured_ren ren (e : Exp.t) : Exp.t = Lindex (e1', e2') -let atom_captured_ren ren (a : Sil.atom) : Sil.atom = +let atom_captured_ren ren (a : Predicates.atom) : Predicates.atom = match a with | Aeq (e1, e2) -> Aeq (exp_captured_ren ren e1, exp_captured_ren ren e2) @@ -2121,7 +2144,7 @@ let atom_captured_ren ren (a : Sil.atom) : Sil.atom = Anpred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) -let rec strexp_captured_ren ren (se : Sil.strexp) : Sil.strexp = +let rec strexp_captured_ren ren (se : Predicates.strexp) : Predicates.strexp = match se with | Eexp (e, inst) -> Eexp (exp_captured_ren ren e, inst) @@ -2137,7 +2160,7 @@ let rec strexp_captured_ren ren (se : Sil.strexp) : Sil.strexp = Earray (len', List.map ~f idx_se_list, inst) -and hpred_captured_ren ren (hpred : Sil.hpred) : Sil.hpred = +and hpred_captured_ren ren (hpred : Predicates.hpred) : Predicates.hpred = match hpred with | Hpointsto (base, se, te) -> let base' = exp_captured_ren ren base in @@ -2160,9 +2183,9 @@ and hpred_captured_ren ren (hpred : Sil.hpred) : Sil.hpred = Hdllseg (k, para', e1', e2', e3', e4', elist') -and hpara_ren (para : Sil.hpara) : Sil.hpara = +and hpara_ren (para : Predicates.hpara) : Predicates.hpara = let av = - Sil.hpara_shallow_free_vars para |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys + Predicates.hpara_shallow_free_vars para |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let ren = compute_renaming av in let root = ident_captured_ren ren para.root in @@ -2173,9 +2196,10 @@ and hpara_ren (para : Sil.hpara) : Sil.hpara = {root; next; svars; evars; body} -and hpara_dll_ren (para : Sil.hpara_dll) : Sil.hpara_dll = +and hpara_dll_ren (para : Predicates.hpara_dll) : Predicates.hpara_dll = let av = - Sil.hpara_dll_shallow_free_vars para |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys + Predicates.hpara_dll_shallow_free_vars para + |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let ren = compute_renaming av in let iF = ident_captured_ren ren para.cell in @@ -2191,7 +2215,9 @@ let pi_captured_ren ren pi = List.map ~f:(atom_captured_ren ren) pi let sigma_captured_ren ren sigma = List.map ~f:(hpred_captured_ren ren) sigma -let sub_captured_ren ren sub = Sil.sub_map (ident_captured_ren ren) (exp_captured_ren ren) sub +let sub_captured_ren ren sub = + Predicates.sub_map (ident_captured_ren ren) (exp_captured_ren ren) sub + (** Canonicalize the names of primed variables and footprint vars. *) let prop_rename_primed_footprint_vars tenv (p : normal t) : normal t = @@ -2207,7 +2233,7 @@ let prop_rename_primed_footprint_vars tenv (p : normal t) : normal t = let sigma' = sigma_captured_ren ren p.sigma in let pi_fp' = pi_captured_ren ren p.pi_fp in let sigma_fp' = sigma_captured_ren ren p.sigma_fp in - let sub_for_normalize = Sil.sub_empty in + let sub_for_normalize = Predicates.sub_empty in (* It is fine to use the empty substituion during normalization because the renaming maintains that a substitution is normalized *) let nsub' = Normalize.sub_normalize sub' in @@ -2230,7 +2256,7 @@ let prop_sub subst (prop : 'a t) : exposed t = (** Apply renaming substitution to a proposition. *) -let prop_ren_sub tenv (ren_sub : Sil.subst) (prop : normal t) : normal t = +let prop_ren_sub tenv (ren_sub : Predicates.subst) (prop : normal t) : normal t = Normalize.normalize tenv (prop_sub ren_sub prop) @@ -2242,7 +2268,7 @@ let exist_quantify tenv ?ids_queue ids (prop : normal t) : normal t = if List.is_empty ids then prop else let gen_fresh_id_sub id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in - let ren_sub = Sil.subst_of_list (List.map ~f:gen_fresh_id_sub ids) in + let ren_sub = Predicates.subst_of_list (List.map ~f:gen_fresh_id_sub ids) in let prop' = (* throw away x=E if x becomes x_ *) let filter = @@ -2253,8 +2279,8 @@ let exist_quantify tenv ?ids_queue ids (prop : normal t) : normal t = | None -> fun id -> not (List.mem ~equal:Ident.equal ids id) in - let sub = Sil.sub_filter filter prop.sub in - if Sil.equal_subst sub prop.sub then prop else unsafe_cast_to_normal (set prop ~sub) + let sub = Predicates.sub_filter filter prop.sub in + if Predicates.equal_subst sub prop.sub then prop else unsafe_cast_to_normal (set prop ~sub) in (* L.out "@[<2>.... Existential Quantification ....@\n"; @@ -2268,10 +2294,10 @@ let exist_quantify tenv ?ids_queue ids (prop : normal t) : normal t = (** Apply the substitution [fe] to all the expressions in the prop. *) let prop_expmap (fe : Exp.t -> Exp.t) prop = let f (e, sil_opt) = (fe e, sil_opt) in - let pi = List.map ~f:(Sil.atom_expmap fe) prop.pi in - let sigma = List.map ~f:(Sil.hpred_expmap f) prop.sigma in - let pi_fp = List.map ~f:(Sil.atom_expmap fe) prop.pi_fp in - let sigma_fp = List.map ~f:(Sil.hpred_expmap f) prop.sigma_fp in + let pi = List.map ~f:(Predicates.atom_expmap fe) prop.pi in + let sigma = List.map ~f:(Predicates.hpred_expmap f) prop.sigma in + let pi_fp = List.map ~f:(Predicates.atom_expmap fe) prop.pi_fp in + let sigma_fp = List.map ~f:(Predicates.hpred_expmap f) prop.sigma_fp in set prop ~pi ~sigma ~pi_fp ~sigma_fp @@ -2291,7 +2317,8 @@ let prop_primed_vars_to_normal_vars tenv (prop : normal t) : normal t = |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let ren_sub = - Sil.subst_of_list (List.map ~f:(fun i -> (i, Exp.Var (Ident.create_fresh Ident.knormal))) ids) + Predicates.subst_of_list + (List.map ~f:(fun i -> (i, Exp.Var (Ident.create_fresh Ident.knormal))) ids) in prop_ren_sub tenv ren_sub prop @@ -2304,12 +2331,12 @@ let from_sigma sigma = set prop_emp ~sigma (** Iterator state over sigma. *) type 'a prop_iter = - { pit_sub: Sil.subst (** substitution for equalities *) + { pit_sub: Predicates.subst (** substitution for equalities *) ; pit_pi: pi (** pure part *) - ; pit_newpi: (bool * Sil.atom) list (** newly added atoms. *) + ; pit_newpi: (bool * Predicates.atom) list (** newly added atoms. *) ; (* The first records !BiabductionConfig.footprint. *) pit_old: sigma (** sigma already visited *) - ; pit_curr: Sil.hpred (** current element *) + ; pit_curr: Predicates.hpred (** current element *) ; pit_state: 'a (** state of current element *) ; pit_new: sigma (** sigma not yet visited *) ; pit_pi_fp: pi (** pure part of the footprint *) @@ -2419,10 +2446,12 @@ let prop_iter_set_state iter state = {iter with pit_state= state} let prop_iter_make_id_primed tenv id iter = let pid = Ident.create_fresh Ident.kprimed in - let sub_id = Sil.subst_of_list [(id, Exp.Var pid)] in + let sub_id = Predicates.subst_of_list [(id, Exp.Var pid)] in let normalize (id, e) = - let eq' : Sil.atom = Aeq (Sil.exp_sub sub_id (Var id), Sil.exp_sub sub_id e) in - Normalize.atom_normalize tenv Sil.sub_empty eq' + let eq' : Predicates.atom = + Aeq (Predicates.exp_sub sub_id (Var id), Predicates.exp_sub sub_id e) + in + Normalize.atom_normalize tenv Predicates.sub_empty eq' in let rec split pairs_unpid pairs_pid = function | [] -> @@ -2446,31 +2475,31 @@ let prop_iter_make_id_primed tenv id iter = | [] | [_] -> List.rev acc | (_, e1) :: ((_, e2) :: _ as pairs) -> - get_eqs (Sil.Aeq (e1, e2) :: acc) pairs + get_eqs (Predicates.Aeq (e1, e2) :: acc) pairs in let sub_new, sub_use, eqs_add = - let eqs = List.map ~f:normalize (Sil.sub_to_list iter.pit_sub) in + let eqs = List.map ~f:normalize (Predicates.sub_to_list iter.pit_sub) in let pairs_unpid, pairs_pid = split [] [] eqs in match pairs_pid with | [] -> - let sub_unpid = Sil.subst_of_list pairs_unpid in + let sub_unpid = Predicates.subst_of_list pairs_unpid in let pairs = (id, Exp.Var pid) :: pairs_unpid in - (sub_unpid, Sil.subst_of_list pairs, []) + (sub_unpid, Predicates.subst_of_list pairs, []) | (id1, e1) :: _ -> - let sub_id1 = Sil.subst_of_list [(id1, e1)] in + let sub_id1 = Predicates.subst_of_list [(id1, e1)] in let pairs_unpid' = - List.map ~f:(fun (id', e') -> (id', Sil.exp_sub sub_id1 e')) pairs_unpid + List.map ~f:(fun (id', e') -> (id', Predicates.exp_sub sub_id1 e')) pairs_unpid in - let sub_unpid = Sil.subst_of_list pairs_unpid' in + let sub_unpid = Predicates.subst_of_list pairs_unpid' in let pairs = (id, e1) :: pairs_unpid' in - (sub_unpid, Sil.subst_of_list pairs, get_eqs [] pairs_pid) + (sub_unpid, Predicates.subst_of_list pairs, get_eqs [] pairs_pid) in let nsub_new = Normalize.sub_normalize sub_new in { iter with pit_sub= nsub_new ; pit_pi= pi_sub sub_use (iter.pit_pi @ eqs_add) ; pit_old= sigma_sub sub_use iter.pit_old - ; pit_curr= Sil.hpred_sub sub_use iter.pit_curr + ; pit_curr= Predicates.hpred_sub sub_use iter.pit_curr ; pit_new= sigma_sub sub_use iter.pit_new } @@ -2482,7 +2511,7 @@ let prop_iter_footprint_gen_free_vars {pit_sigma_fp; pit_pi_fp} = (** Find fav of the iterator *) let prop_iter_gen_free_vars ({pit_sub; pit_pi; pit_newpi; pit_old; pit_new; pit_curr} as iter) = let open Sequence.Generator in - Sil.subst_gen_free_vars pit_sub + Predicates.subst_gen_free_vars pit_sub >>= fun () -> pi_gen_free_vars pit_pi >>= fun () -> @@ -2492,7 +2521,7 @@ let prop_iter_gen_free_vars ({pit_sub; pit_pi; pit_newpi; pit_old; pit_new; pit_ >>= fun () -> sigma_gen_free_vars pit_new >>= fun () -> - Sil.hpred_gen_free_vars pit_curr >>= fun () -> prop_iter_footprint_gen_free_vars iter + Predicates.hpred_gen_free_vars pit_curr >>= fun () -> prop_iter_footprint_gen_free_vars iter let prop_iter_free_vars iter = Sequence.Generator.run (prop_iter_gen_free_vars iter) @@ -2505,7 +2534,7 @@ let prop_iter_get_footprint_sigma iter = iter.pit_sigma_fp (** Replace the sigma part of the footprint *) let prop_iter_replace_footprint_sigma iter sigma = {iter with pit_sigma_fp= sigma} -let rec strexp_gc_fields (se : Sil.strexp) = +let rec strexp_gc_fields (se : Predicates.strexp) = match se with | Eexp _ -> Some se @@ -2515,20 +2544,20 @@ let rec strexp_gc_fields (se : Sil.strexp) = let fselo' = List.filter ~f:(function _, Some _ -> true | _ -> false) fselo in List.map ~f:(function f, seo -> (f, unSome seo)) fselo' in - if [%compare.equal: (Typ.Fieldname.t * Sil.strexp) list] fsel fsel' then Some se - else Some (Sil.Estruct (fsel', inst)) + if [%compare.equal: (Typ.Fieldname.t * Predicates.strexp) list] fsel fsel' then Some se + else Some (Predicates.Estruct (fsel', inst)) | Earray _ -> Some se -let hpred_gc_fields (hpred : Sil.hpred) : Sil.hpred = +let hpred_gc_fields (hpred : Predicates.hpred) : Predicates.hpred = match hpred with | Hpointsto (e, se, te) -> ( match strexp_gc_fields se with | None -> hpred | Some se' -> - if Sil.equal_strexp se se' then hpred else Hpointsto (e, se', te) ) + if Predicates.equal_strexp se se' then hpred else Hpointsto (e, se', te) ) | Hlseg _ | Hdllseg _ -> hpred @@ -2546,7 +2575,7 @@ let prop_iter_gc_fields iter = let prop_expand tenv prop = - let pi_sigma_list = Sil.sigma_to_sigma_ne prop.sigma in + let pi_sigma_list = Predicates.sigma_to_sigma_ne prop.sigma in let f props_acc (pi, sigma) = let sigma' = sigma_normalize_prop tenv prop sigma in let prop' = unsafe_cast_to_normal (set prop ~sigma:sigma') in @@ -2563,11 +2592,11 @@ end = struct and lseg_weight = 3 - let rec hpara_size hpara = sigma_size hpara.Sil.body + let rec hpara_size hpara = sigma_size hpara.Predicates.body - and hpara_dll_size hpara_dll = sigma_size hpara_dll.Sil.body_dll + and hpara_dll_size hpara_dll = sigma_size hpara_dll.Predicates.body_dll - and hpred_size (hpred : Sil.hpred) = + and hpred_size (hpred : Predicates.hpred) = match hpred with | Hpointsto _ -> ptsto_weight @@ -2607,8 +2636,8 @@ module CategorizePreconditions = struct let categorize preconditions = let lhs_is_lvar : Exp.t -> bool = function Lvar _ -> true | _ -> false in let lhs_is_var_lvar : Exp.t -> bool = function Var _ -> true | Lvar _ -> true | _ -> false in - let rhs_is_var : Sil.strexp -> bool = function Eexp (Var _, _) -> true | _ -> false in - let rec rhs_only_vars : Sil.strexp -> bool = function + let rhs_is_var : Predicates.strexp -> bool = function Eexp (Var _, _) -> true | _ -> false in + let rec rhs_only_vars : Predicates.strexp -> bool = function | Eexp (Var _, _) -> true | Estruct (fsel, _) -> @@ -2618,14 +2647,14 @@ module CategorizePreconditions = struct | _ -> false in - let hpred_is_var : Sil.hpred -> bool = function + let hpred_is_var : Predicates.hpred -> bool = function (* stack variable with no constraints *) | Hpointsto (e, se, _) -> lhs_is_lvar e && rhs_is_var se | _ -> false in - let hpred_only_allocation : Sil.hpred -> bool = function + let hpred_only_allocation : Predicates.hpred -> bool = function (* only constraint is allocation *) | Hpointsto (e, se, _) -> lhs_is_var_lvar e && rhs_only_vars se diff --git a/infer/src/biabduction/Prop.mli b/infer/src/biabduction/Prop.mli index 0d42691b4..3d201a9a6 100644 --- a/infer/src/biabduction/Prop.mli +++ b/infer/src/biabduction/Prop.mli @@ -7,11 +7,10 @@ *) open! IStd +open Predicates (** Functions for Propositions (i.e., Symbolic Heaps) *) -open Sil - (** kind for normal props, i.e. normalized *) type normal @@ -23,14 +22,14 @@ type sorted (** Proposition. *) -type pi = Sil.atom list +type pi = atom list -type sigma = Sil.hpred list +type sigma = hpred list (** the kind 'a should range over [normal] and [exposed] *) type 'a t = private { sigma: sigma (** spatial part *) - ; sub: Sil.subst (** substitution *) + ; sub: subst (** substitution *) ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } @@ -77,7 +76,7 @@ val prop_update_obj_sub : Pp.env -> 'a t -> Pp.env val pp_prop : Pp.env -> Format.formatter -> 'a t -> unit (** Pretty print a proposition. *) -val prop_pred_env : 'a t -> Sil.Predicates.env +val prop_pred_env : 'a t -> Predicates.Env.t (** Create a predicate environment for a prop *) val d_prop : 'a t -> unit @@ -119,16 +118,16 @@ val sigma_replace_exp : Tenv.t -> (Exp.t * Exp.t) list -> hpred list -> hpred li (** {2 Normalization} *) -val mk_inequality : Tenv.t -> Exp.t -> Sil.atom +val mk_inequality : Tenv.t -> Exp.t -> atom (** Turn an inequality expression into an atom *) -val atom_is_inequality : Sil.atom -> bool +val atom_is_inequality : atom -> bool (** Return [true] if the atom is an inequality *) -val atom_exp_le_const : Sil.atom -> (Exp.t * IntLit.t) option +val atom_exp_le_const : atom -> (Exp.t * IntLit.t) option (** If the atom is [e<=n] return [e,n] *) -val atom_const_lt_exp : Sil.atom -> (IntLit.t * Exp.t) option +val atom_const_lt_exp : atom -> (IntLit.t * Exp.t) option (** If the atom is [n Tenv.t -> 'a t -> Exp.t -> Exp.t @@ -138,7 +137,7 @@ val exp_normalize_prop : ?destructive:bool -> Tenv.t -> 'a t -> Exp.t -> Exp.t If [destructive] is true then normalize more aggressively, which may lose some useful structure or types. *) -val exp_normalize_noabs : Tenv.t -> Sil.subst -> Exp.t -> Exp.t +val exp_normalize_noabs : Tenv.t -> subst -> Exp.t -> Exp.t (** Normalize the expression without abstracting complex subexpressions *) val exp_collapse_consecutive_indices_prop : Typ.t -> Exp.t -> Exp.t @@ -184,18 +183,17 @@ val mk_pred : Tenv.t -> PredSymb.t -> Exp.t list -> atom val mk_npred : Tenv.t -> PredSymb.t -> Exp.t list -> atom (** Construct a negative pred. *) -val create_strexp_of_type : - Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> Sil.inst -> Sil.strexp +val create_strexp_of_type : Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> inst -> strexp (** create a strexp of the given type, populating the structures if [expand_structs] is true *) val mk_ptsto : Tenv.t -> Exp.t -> strexp -> Exp.t -> hpred (** Construct a pointsto. *) -val mk_ptsto_exp : Tenv.t -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> Sil.inst -> hpred +val mk_ptsto_exp : Tenv.t -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> inst -> hpred (** Construct a points-to predicate for an expression using either the provided expression [name] as base for fresh identifiers. *) -val mk_ptsto_lvar : Tenv.t -> struct_init_mode -> Sil.inst -> Pvar.t * Exp.t * Exp.t option -> hpred +val mk_ptsto_lvar : Tenv.t -> struct_init_mode -> inst -> Pvar.t * Exp.t * Exp.t option -> hpred (** Construct a points-to predicate for a single program variable. If [expand_structs] is true, initialize the fields of structs with fresh variables. *) @@ -209,7 +207,7 @@ val mk_dllseg : val prop_emp : normal t (** Proposition [true /\ emp]. *) -val prop_reset_inst : (Sil.inst -> Sil.inst) -> 'a t -> exposed t +val prop_reset_inst : (inst -> inst) -> 'a t -> exposed t (** Reset every inst in the prop using the given map *) val prop_hpred_star : 'a t -> hpred -> exposed t @@ -260,8 +258,7 @@ val from_pi : pi -> exposed t val from_sigma : sigma -> exposed t (** Build an exposed prop from sigma *) -val set : - ?sub:Sil.subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t +val set : ?sub:subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t -> exposed t (** Set individual fields of the prop. *) (** {2 Prop iterators} *) diff --git a/infer/src/biabduction/PropUtil.ml b/infer/src/biabduction/PropUtil.ml index dc3d3a2a4..b95d25308 100644 --- a/infer/src/biabduction/PropUtil.ml +++ b/infer/src/biabduction/PropUtil.ml @@ -23,7 +23,7 @@ let get_name_of_objc_static_locals (curr_f : Procdesc.t) p = [] in let hpred_local_static hpred = - match hpred with Sil.Hpointsto (e, _, _) -> [local_static e] | _ -> [] + match hpred with Predicates.Hpointsto (e, _, _) -> [local_static e] | _ -> [] in let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in List.concat (List.concat vars_sigma) @@ -35,7 +35,7 @@ let get_name_of_objc_block_locals p = match e with Exp.Lvar pvar when Pvar.is_block_pvar pvar -> [pvar] | _ -> [] in let hpred_local_blocks hpred = - match hpred with Sil.Hpointsto (e, _, _) -> [local_blocks e] | _ -> [] + match hpred with Predicates.Hpointsto (e, _, _) -> [local_blocks e] | _ -> [] in let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in List.concat (List.concat vars_sigma) @@ -45,32 +45,34 @@ let remove_abduced_retvars tenv p = (* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *) let compute_reachable p seed_exps = let sigma, pi = (p.Prop.sigma, p.Prop.pi) in - let rec collect_exps exps = function - | Sil.Eexp (Exp.Exn e, _) -> + let rec collect_exps exps (sexp : Predicates.strexp) = + match sexp with + | Eexp (Exp.Exn e, _) -> Exp.Set.add e exps - | Sil.Eexp (e, _) -> + | Eexp (e, _) -> Exp.Set.add e exps - | Sil.Estruct (flds, _) -> + | Estruct (flds, _) -> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds - | Sil.Earray (_, elems, _) -> + | Earray (_, elems, _) -> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems in let rec compute_reachable_hpreds_rec sigma (reach, exps) = - let add_hpred_if_reachable (reach, exps) = function - | Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps -> - let reach' = Sil.HpredSet.add hpred reach in + let add_hpred_if_reachable (reach, exps) (hpred : Predicates.hpred) = + match hpred with + | Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps -> + let reach' = Predicates.HpredSet.add hpred reach in let exps' = collect_exps exps rhs in (reach', exps') - | Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred -> - let reach' = Sil.HpredSet.add hpred reach in + | Hlseg (_, _, exp1, exp2, exp_l) as hpred -> + let reach' = Predicates.HpredSet.add hpred reach in let exps' = List.fold ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) ~init:exps (exp1 :: exp2 :: exp_l) in (reach', exps') - | Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred -> - let reach' = Sil.HpredSet.add hpred reach in + | Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred -> + let reach' = Predicates.HpredSet.add hpred reach in let exps' = List.fold ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) @@ -82,11 +84,12 @@ let remove_abduced_retvars tenv p = (reach, exps) in let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma in - if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps) + if Int.equal (Predicates.HpredSet.cardinal reach) (Predicates.HpredSet.cardinal reach') then + (reach, exps) else compute_reachable_hpreds_rec sigma (reach', exps') in let reach_hpreds, reach_exps = - compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, seed_exps) + compute_reachable_hpreds_rec sigma (Predicates.HpredSet.empty, seed_exps) in (* filter away the pure atoms without reachable exps *) let reach_pi = @@ -102,20 +105,20 @@ let remove_abduced_retvars tenv p = in List.filter ~f:(function - | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> + | Predicates.Aeq (lhs, rhs) | Predicates.Aneq (lhs, rhs) -> exp_contains lhs || exp_contains rhs - | Sil.Apred (_, es) | Sil.Anpred (_, es) -> + | Predicates.Apred (_, es) | Predicates.Anpred (_, es) -> List.exists ~f:exp_contains es ) pi in - (Sil.HpredSet.elements reach_hpreds, reach_pi) + (Predicates.HpredSet.elements reach_hpreds, reach_pi) in (* separate the abduced pvars from the normal ones, deallocate the abduced ones*) let abduceds, normal_pvars = List.fold ~f:(fun pvars hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pvar, _, _) -> let abduceds, normal_pvars = pvars in if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars) else (abduceds, pvar :: normal_pvars) @@ -180,7 +183,7 @@ let remove_locals_formals tenv (curr_f : Procdesc.t) p = (** remove seed vars from a prop *) let remove_seed_vars tenv (prop : 'a Prop.t) : Prop.normal Prop.t = let hpred_not_seed = function - | Sil.Hpointsto (Exp.Lvar pv, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pv, _, _) -> not (Pvar.is_seed pv) | _ -> true diff --git a/infer/src/biabduction/Propgraph.ml b/infer/src/biabduction/Propgraph.ml index 4b3add06f..6689b12f9 100644 --- a/infer/src/biabduction/Propgraph.ml +++ b/infer/src/biabduction/Propgraph.ml @@ -17,7 +17,7 @@ type 'a t = 'a Prop.t type sub_entry = Ident.t * Exp.t -type edge = Ehpred of Sil.hpred | Eatom of Sil.atom | Esub_entry of sub_entry +type edge = Ehpred of Predicates.hpred | Eatom of Predicates.atom | Esub_entry of sub_entry let from_prop p = p @@ -26,19 +26,19 @@ let edge_is_hpred = function Ehpred _ -> true | Eatom _ -> false | Esub_entry _ (** Return the source of the edge *) let edge_get_source = function - | Ehpred (Sil.Hpointsto (e, _, _)) -> + | Ehpred (Hpointsto (e, _, _)) -> Some e - | Ehpred (Sil.Hlseg (_, _, e, _, _)) -> + | Ehpred (Hlseg (_, _, e, _, _)) -> Some e - | Ehpred (Sil.Hdllseg (_, _, e1, _, _, _, _)) -> + | Ehpred (Hdllseg (_, _, e1, _, _, _, _)) -> Some e1 (* only one direction supported for now *) - | Eatom (Sil.Aeq (e1, _)) -> + | Eatom (Aeq (e1, _)) -> Some e1 - | Eatom (Sil.Aneq (e1, _)) -> + | Eatom (Aneq (e1, _)) -> Some e1 - | Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) -> + | Eatom (Apred (_, e :: _) | Anpred (_, e :: _)) -> Some e - | Eatom (Sil.Apred (_, []) | Anpred (_, [])) -> + | Eatom (Apred (_, []) | Anpred (_, [])) -> None | Esub_entry (x, _) -> Some (Exp.Var x) @@ -48,7 +48,7 @@ let get_sigma footprint_part g = if footprint_part then g.Prop.sigma_fp else g.P let get_pi footprint_part g = if footprint_part then g.Prop.pi_fp else g.Prop.pi -let get_subl footprint_part g = if footprint_part then [] else Sil.sub_to_list g.Prop.sub +let get_subl footprint_part g = if footprint_part then [] else Predicates.sub_to_list g.Prop.sub (** [edge_from_source g n footprint_part is_hpred] finds and edge with the given source [n] in prop [g]. [footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] @@ -80,9 +80,9 @@ let get_edges footprint_part g = let edge_equal e1 e2 = match (e1, e2) with | Ehpred hp1, Ehpred hp2 -> - Sil.equal_hpred hp1 hp2 + Predicates.equal_hpred hp1 hp2 | Eatom a1, Eatom a2 -> - Sil.equal_atom a1 a2 + Predicates.equal_atom a1 a2 | Esub_entry (x1, e1), Esub_entry (x2, e2) -> Ident.equal x1 x2 && Exp.equal e1 e2 | _ -> @@ -109,13 +109,13 @@ let compute_exp_diff (e1 : Exp.t) (e2 : Exp.t) : Obj.t list = (** Compute the subobjects in [se2] which are different from those in [se1] *) -let rec compute_sexp_diff (se1 : Sil.strexp) (se2 : Sil.strexp) : Obj.t list = +let rec compute_sexp_diff (se1 : Predicates.strexp) (se2 : Predicates.strexp) : Obj.t list = match (se1, se2) with - | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> + | Eexp (e1, _), Eexp (e2, _) -> if Exp.equal e1 e2 then [] else [Obj.repr se2] - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> + | Estruct (fsel1, _), Estruct (fsel2, _) -> compute_fsel_diff fsel1 fsel2 - | Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) -> + | Earray (e1, esel1, _), Earray (e2, esel2, _) -> compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2 | _ -> [Obj.repr se2] @@ -156,14 +156,14 @@ and compute_esel_diff esel1 esel2 : Obj.t list = (** Compute the subobjects in [newedge] which are different from those in [oldedge] *) let compute_edge_diff (oldedge : edge) (newedge : edge) : Obj.t list = match (oldedge, newedge) with - | Ehpred (Sil.Hpointsto (_, se1, e1)), Ehpred (Sil.Hpointsto (_, se2, e2)) -> + | Ehpred (Hpointsto (_, se1, e1)), Ehpred (Hpointsto (_, se2, e2)) -> compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2 - | Eatom (Sil.Aeq (_, e1)), Eatom (Sil.Aeq (_, e2)) -> + | Eatom (Aeq (_, e1)), Eatom (Aeq (_, e2)) -> compute_exp_diff e1 e2 - | Eatom (Sil.Aneq (_, e1)), Eatom (Sil.Aneq (_, e2)) -> + | Eatom (Aneq (_, e1)), Eatom (Aneq (_, e2)) -> compute_exp_diff e1 e2 - | Eatom (Sil.Apred (_, es1)), Eatom (Sil.Apred (_, es2)) - | Eatom (Sil.Anpred (_, es1)), Eatom (Sil.Anpred (_, es2)) -> + | Eatom (Apred (_, es1)), Eatom (Apred (_, es2)) + | Eatom (Anpred (_, es1)), Eatom (Anpred (_, es2)) -> List.concat (try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> []) | Esub_entry (_, e1), Esub_entry (_, e2) -> compute_exp_diff e1 e2 diff --git a/infer/src/biabduction/Prover.ml b/infer/src/biabduction/Prover.ml index b6425decd..2a24f870f 100644 --- a/infer/src/biabduction/Prover.ml +++ b/infer/src/biabduction/Prover.ml @@ -46,19 +46,20 @@ let rec is_java_class tenv (typ : Typ.t) = (** Negate an atom *) -let atom_negate tenv = function - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> +let atom_negate tenv (atom : Predicates.atom) : Predicates.atom = + match atom with + | Aeq (BinOp (Le, e1, e2), Const (Cint i)) when IntLit.isone i -> Prop.mk_inequality tenv (Exp.lt e2 e1) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> + | Aeq (BinOp (Lt, e1, e2), Const (Cint i)) when IntLit.isone i -> Prop.mk_inequality tenv (Exp.le e2 e1) - | Sil.Aeq (e1, e2) -> - Sil.Aneq (e1, e2) - | Sil.Aneq (e1, e2) -> - Sil.Aeq (e1, e2) - | Sil.Apred (a, es) -> - Sil.Anpred (a, es) - | Sil.Anpred (a, es) -> - Sil.Apred (a, es) + | Aeq (e1, e2) -> + Aneq (e1, e2) + | Aneq (e1, e2) -> + Aeq (e1, e2) + | Apred (a, es) -> + Anpred (a, es) + | Anpred (a, es) -> + Apred (a, es) (** {2 Ordinary Theorem Proving} *) @@ -391,15 +392,16 @@ end = struct (* < facts *) let neqs = ref [] in (* != facts *) - let process_atom = function - | Sil.Aneq (e1, e2) -> + let process_atom (atom : Predicates.atom) = + match atom with + | Aneq (e1, e2) -> (* != *) neqs := (e1, e2) :: !neqs - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> + | Aeq (BinOp (Le, e1, e2), Const (Cint i)) when IntLit.isone i -> leqs := (e1, e2) :: !leqs (* <= *) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> + | Aeq (BinOp (Lt, e1, e2), Const (Cint i)) when IntLit.isone i -> lts := (e1, e2) :: !lts (* < *) - | Sil.Aeq _ | Sil.Apred _ | Anpred _ -> + | Aeq _ | Apred _ | Anpred _ -> () in List.iter ~f:process_atom pi ; @@ -420,17 +422,17 @@ end = struct in let type_of_texp = function Exp.Sizeof {typ} -> Some typ | _ -> None in let texp_is_unsigned texp = type_opt_is_unsigned @@ type_of_texp texp in - let strexp_lt_minus1 = function Sil.Eexp (e, _) -> add_lt_minus1_e e | _ -> () in + let strexp_lt_minus1 = function Predicates.Eexp (e, _) -> add_lt_minus1_e e | _ -> () in let rec strexp_extract = function - | Sil.Eexp (e, _), t -> + | Predicates.Eexp (e, _), t -> if type_opt_is_unsigned t then add_lt_minus1_e e - | Sil.Estruct (fsel, _), t -> + | Predicates.Estruct (fsel, _), t -> let get_field_type f = Option.bind t ~f:(fun t' -> Option.map ~f:fst @@ Typ.Struct.get_field_type_and_annotation ~lookup f t' ) in List.iter ~f:(fun (f, se) -> strexp_extract (se, get_field_type f)) fsel - | Sil.Earray (len, isel, _), t -> + | Predicates.Earray (len, isel, _), t -> let elt_t = match t with Some {Typ.desc= Tarray {elt}} -> Some elt | _ -> None in add_lt_minus1_e len ; List.iter @@ -440,10 +442,10 @@ end = struct isel in let hpred_extract = function - | Sil.Hpointsto (_, se, texp) -> + | Predicates.Hpointsto (_, se, texp) -> if texp_is_unsigned texp then strexp_lt_minus1 se ; strexp_extract (se, type_of_texp texp) - | Sil.Hlseg _ | Sil.Hdllseg _ -> + | Predicates.Hlseg _ | Predicates.Hdllseg _ -> () in List.iter ~f:hpred_extract sigma ; @@ -471,7 +473,7 @@ end = struct (** Check [t |- e1<=e2]. Result [false] means "don't know". *) let check_le {leqs; lts; neqs= _} e1 e2 = - (* L.d_str "check_le "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) + (* L.d_str "check_le "; Predicates.d_exp e1; L.d_str " "; Predicates.d_exp e2; L.d_ln (); *) match (e1, e2) with | Exp.Const (Const.Cint n1), Exp.Const (Const.Cint n2) -> IntLit.leq n1 n2 @@ -505,7 +507,7 @@ end = struct (** Check [prop |- e1 IntLit.lt n1 n2 @@ -582,27 +584,6 @@ end = struct List.exists ~f:inconsistent_neq neqs || List.exists ~f:inconsistent_leq leqs || List.exists ~f:inconsistent_lt lts - - (* - (** Pretty print inequalities and disequalities *) - let pp pe fmt { leqs = leqs; lts = lts; neqs = neqs } = - let pp_leq fmt (e1, e2) = F.fprintf fmt "%a<=%a" (Sil.pp_exp pe) e1 (Sil.pp_exp pe) e2 in - let pp_lt fmt (e1, e2) = F.fprintf fmt "%a<%a" (Sil.pp_exp pe) e1 (Sil.pp_exp pe) e2 in - let pp_neq fmt (e1, e2) = F.fprintf fmt "%a!=%a" (Sil.pp_exp pe) e1 (Sil.pp_exp pe) e2 in - Format.fprintf fmt "%a %a %a" (pp_seq pp_leq) leqs (pp_seq pp_lt) lts (pp_seq pp_neq) neqs - - let d_leqs { leqs = leqs; lts = lts; neqs = neqs } = - let elist = List.map ~f:(fun (e1, e2) -> Exp.BinOp(Binop.Le, e1, e2)) leqs in - Sil.d_exp_list elist - - let d_lts { leqs = leqs; lts = lts; neqs = neqs } = - let elist = List.map ~f:(fun (e1, e2) -> Exp.BinOp(Binop.Lt, e1, e2)) lts in - Sil.d_exp_list elist - - let d_neqs { leqs = leqs; lts = lts; neqs = neqs } = - let elist = List.map ~f:(fun (e1, e2) -> Exp.BinOp(Binop.Ne, e1, e2)) lts in - Sil.d_exp_list elist -*) end (* End of module Inequalities *) @@ -625,10 +606,10 @@ let check_equal tenv prop e1_0 e2_0 = false in let check_equal_pi () = - let eq = Sil.Aeq (n_e1, n_e2) in + let eq = Predicates.Aeq (n_e1, n_e2) in let n_eq = Prop.atom_normalize_prop tenv prop eq in let pi = prop.Prop.pi in - List.exists ~f:(Sil.equal_atom n_eq) pi + List.exists ~f:(Predicates.equal_atom n_eq) pi in check_equal () || check_equal_const () || check_equal_pi () @@ -654,9 +635,9 @@ let is_root tenv prop base_exp exp = | Exp.Cast (_, sub_exp) -> f offlist_past sub_exp | Exp.Lfield (sub_exp, fldname, typ) -> - f (Sil.Off_fld (fldname, typ) :: offlist_past) sub_exp + f (Predicates.Off_fld (fldname, typ) :: offlist_past) sub_exp | Exp.Lindex (sub_exp, e) -> - f (Sil.Off_index e :: offlist_past) sub_exp + f (Predicates.Off_index e :: offlist_past) sub_exp in f [] exp @@ -732,7 +713,7 @@ let check_disequal tenv prop e1 e2 = let rec f sigma_irrelevant e = function | [] -> None - | (Sil.Hpointsto (base, _, _) as hpred) :: sigma_rest -> ( + | (Predicates.Hpointsto (base, _, _) as hpred) :: sigma_rest -> ( match is_root tenv prop base e with | None -> let sigma_irrelevant' = hpred :: sigma_irrelevant in @@ -740,13 +721,13 @@ let check_disequal tenv prop e1 e2 = | Some _ -> let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') ) - | (Sil.Hlseg (k, _, e1, e2, _) as hpred) :: sigma_rest -> ( + | (Predicates.Hlseg (k, _, e1, e2, _) as hpred) :: sigma_rest -> ( match is_root tenv prop e1 e with | None -> let sigma_irrelevant' = hpred :: sigma_irrelevant in f sigma_irrelevant' e sigma_rest | Some _ -> - if Sil.equal_lseg_kind k Sil.Lseg_NE || check_pi_implies_disequal e1 e2 then + if Predicates.equal_lseg_kind k Lseg_NE || check_pi_implies_disequal e1 e2 then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') else if Exp.equal e2 Exp.zero then @@ -755,14 +736,14 @@ let check_disequal tenv prop e1 e2 = else let sigma_rest' = List.rev_append sigma_irrelevant sigma_rest in f [] e2 sigma_rest' ) - | Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest -> + | Predicates.Hdllseg (Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest -> if is_root tenv prop iF e <> None || is_root tenv prop iB e <> None then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') else let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (false, sigma_irrelevant') - | (Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred) :: sigma_rest -> ( + | (Predicates.Hdllseg (Lseg_PE, _, iF, _, oF, _, _) as hpred) :: sigma_rest -> ( match is_root tenv prop iF e with | None -> let sigma_irrelevant' = hpred :: sigma_irrelevant in @@ -801,7 +782,6 @@ let check_disequal tenv prop e1 e2 = (** Check [prop |- e1<=e2], to be called from normalized atom *) let check_le_normalized tenv prop e1 e2 = - (* L.d_str "check_le_normalized "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) let eL, eR, off = match (e1, e2) with | Exp.BinOp (Binop.MinusA _, f1, f2), Exp.Const (Const.Cint n) -> @@ -824,7 +804,6 @@ let check_le_normalized tenv prop e1 e2 = (** Check [prop |- e1 + match (a : Predicates.atom) with + | Aeq (BinOp (Le, e1, e2), Const (Cint i)) when IntLit.isone i -> check_le_normalized tenv prop e1 e2 - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> + | Aeq (BinOp (Lt, e1, e2), Const (Cint i)) when IntLit.isone i -> check_lt_normalized tenv prop e1 e2 - | Sil.Aeq (e1, e2) -> + | Aeq (e1, e2) -> check_equal tenv prop e1 e2 - | Sil.Aneq (e1, e2) -> + | Aneq (e1, e2) -> check_disequal tenv prop e1 e2 - | Sil.Apred _ | Anpred _ -> - List.exists ~f:(Sil.equal_atom a) prop.Prop.pi + | Apred _ | Anpred _ -> + List.exists ~f:(Predicates.equal_atom a) prop.Prop.pi (** Check whether [prop |- allocated(e)]. *) @@ -890,16 +869,16 @@ let check_allocatedness tenv prop e = let n_e = Prop.exp_normalize_prop ~destructive:true tenv prop e in let spatial_part = prop.Prop.sigma in let f = function - | Sil.Hpointsto (base, _, _) -> + | Predicates.Hpointsto (base, _, _) -> is_root tenv prop base n_e <> None - | Sil.Hlseg (k, _, e1, e2, _) -> - if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop e1 e2 then + | Predicates.Hlseg (k, _, e1, e2, _) -> + if Predicates.equal_lseg_kind k Lseg_NE || check_disequal tenv prop e1 e2 then is_root tenv prop e1 n_e <> None else false - | Sil.Hdllseg (k, _, iF, oB, oF, iB, _) -> + | Predicates.Hdllseg (k, _, iF, oB, oF, iB, _) -> if - Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop iF oF - || check_disequal tenv prop iB oB + Predicates.equal_lseg_kind k Lseg_NE + || check_disequal tenv prop iF oF || check_disequal tenv prop iB oB then is_root tenv prop iF n_e <> None || is_root tenv prop iB n_e <> None else false in @@ -912,15 +891,15 @@ let check_inconsistency_two_hpreds tenv prop = let rec f e sigma_seen = function | [] -> false - | (Sil.Hpointsto (e1, _, _) as hpred) :: sigma_rest - | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> + | (Predicates.Hpointsto (e1, _, _) as hpred) :: sigma_rest + | (Predicates.Hlseg (Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> + | (Predicates.Hdllseg (Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> if Exp.equal iF e || Exp.equal iB e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hlseg (Sil.Lseg_PE, _, e1, Exp.Const (Const.Cint i), _) as hpred) :: sigma_rest + | (Predicates.Hlseg (Lseg_PE, _, e1, Exp.Const (Const.Cint i), _) as hpred) :: sigma_rest when IntLit.iszero i -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) as hpred) :: sigma_rest -> + | (Predicates.Hlseg (Lseg_PE, _, e1, e2, _) as hpred) :: sigma_rest -> if Exp.equal e1 e then let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen @ sigma_rest)) in let prop_new = Prop.conjoin_eq tenv e1 e2 prop' in @@ -928,10 +907,11 @@ let check_inconsistency_two_hpreds tenv prop = let e_new = Prop.exp_normalize_prop ~destructive:true tenv prop_new e in f e_new [] sigma_new else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Exp.Const (Const.Cint i), _, _) as hpred) :: sigma_rest + | (Predicates.Hdllseg (Lseg_PE, _, e1, _, Exp.Const (Const.Cint i), _, _) as hpred) + :: sigma_rest when IntLit.iszero i -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred) :: sigma_rest -> + | (Predicates.Hdllseg (Lseg_PE, _, e1, _, e3, _, _) as hpred) :: sigma_rest -> if Exp.equal e1 e then let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen @ sigma_rest)) in let prop_new = Prop.conjoin_eq tenv e1 e3 prop' in @@ -943,14 +923,14 @@ let check_inconsistency_two_hpreds tenv prop = let rec check sigma_seen = function | [] -> false - | (Sil.Hpointsto (e1, _, _) as hpred) :: sigma_rest - | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> + | (Predicates.Hpointsto (e1, _, _) as hpred) :: sigma_rest + | (Predicates.Hlseg (Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> if f e1 [] (sigma_seen @ sigma_rest) then true else check (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> + | (Predicates.Hdllseg (Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> if f iF [] (sigma_seen @ sigma_rest) || f iB [] (sigma_seen @ sigma_rest) then true else check (hpred :: sigma_seen) sigma_rest - | (Sil.Hlseg (Sil.Lseg_PE, _, _, _, _) as hpred) :: sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) as hpred) :: sigma_rest -> + | (Predicates.Hlseg (Lseg_PE, _, _, _, _) as hpred) :: sigma_rest + | (Predicates.Hdllseg (Lseg_PE, _, _, _, _, _, _) as hpred) :: sigma_rest -> check (hpred :: sigma_seen) sigma_rest in check [] sigma @@ -980,7 +960,7 @@ let check_inconsistency_base tenv prop = ClangMethodKind.CPP_INSTANCE in let do_hpred = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + | Predicates.Hpointsto (Lvar pv, Eexp (e, _), _) -> Exp.equal e Exp.zero && Pvar.is_seed pv && (is_java_this pv || is_cpp_this pv || is_objc_instance_self pv) | _ -> @@ -989,15 +969,15 @@ let check_inconsistency_base tenv prop = List.exists ~f:do_hpred sigma in let inconsistent_atom = function - | Sil.Aeq (e1, e2) -> ( + | Predicates.Aeq (e1, e2) -> ( match (e1, e2) with | Exp.Const c1, Exp.Const c2 -> not (Const.equal c1 c2) | _ -> check_disequal tenv prop e1 e2 ) - | Sil.Aneq (e1, e2) -> ( + | Predicates.Aneq (e1, e2) -> ( match (e1, e2) with Exp.Const c1, Exp.Const c2 -> Const.equal c1 c2 | _ -> Exp.equal e1 e2 ) - | Sil.Apred _ | Anpred _ -> + | Predicates.Apred _ | Anpred _ -> false in let inconsistent_inequalities () = @@ -1047,15 +1027,15 @@ let check_inconsistency_pi tenv pi = (** {2 Abduction prover} *) -type subst2 = Sil.subst * Sil.subst +type subst2 = Predicates.subst * Predicates.subst type exc_body = | EXC_FALSE - | EXC_FALSE_HPRED of Sil.hpred + | EXC_FALSE_HPRED of Predicates.hpred | EXC_FALSE_EXPS of Exp.t * Exp.t - | EXC_FALSE_SEXPS of Sil.strexp * Sil.strexp - | EXC_FALSE_ATOM of Sil.atom - | EXC_FALSE_SIGMA of Sil.hpred list + | EXC_FALSE_SEXPS of Predicates.strexp * Predicates.strexp + | EXC_FALSE_ATOM of Predicates.atom + | EXC_FALSE_SIGMA of Predicates.hpred list exception IMPL_EXC of string * subst2 * exc_body @@ -1077,44 +1057,44 @@ module ProverState : sig (** type for array bounds checks *) type bounds_check = | BClen_imply of Exp.t * Exp.t * Exp.t list (** coming from array_len_imply *) - | BCfrom_pre of Sil.atom (** coming implicitly from preconditions *) + | BCfrom_pre of Predicates.atom (** coming implicitly from preconditions *) val add_bounds_check : bounds_check -> unit - val add_frame_fld : Sil.hpred -> unit + val add_frame_fld : Predicates.hpred -> unit val add_frame_typ : Exp.t * Exp.t -> unit - val add_missing_fld : Sil.hpred -> unit + val add_missing_fld : Predicates.hpred -> unit - val add_missing_pi : Sil.atom -> unit + val add_missing_pi : Predicates.atom -> unit - val add_missing_sigma : Sil.hpred list -> unit + val add_missing_sigma : Predicates.hpred list -> unit val add_missing_typ : Exp.t * Exp.t -> unit - val atom_is_array_bounds_check : Sil.atom -> bool + val atom_is_array_bounds_check : Predicates.atom -> bool (** check if atom in pre is a bounds check *) val get_bounds_checks : unit -> bounds_check list - val get_frame_fld : unit -> Sil.hpred list + val get_frame_fld : unit -> Predicates.hpred list val get_frame_typ : unit -> (Exp.t * Exp.t) list - val get_missing_fld : unit -> Sil.hpred list + val get_missing_fld : unit -> Predicates.hpred list - val get_missing_pi : unit -> Sil.atom list + val get_missing_pi : unit -> Predicates.atom list - val get_missing_sigma : unit -> Sil.hpred list + val get_missing_sigma : unit -> Predicates.hpred list val get_missing_typ : unit -> (Exp.t * Exp.t) list - val d_implication : Sil.subst * Sil.subst -> 'a Prop.t * 'b Prop.t -> unit + val d_implication : Predicates.subst * Predicates.subst -> 'a Prop.t * 'b Prop.t -> unit - val d_implication_error : string * (Sil.subst * Sil.subst) * exc_body -> unit + val d_implication_error : string * (Predicates.subst * Predicates.subst) * exc_body -> unit end = struct - type bounds_check = BClen_imply of Exp.t * Exp.t * Exp.t list | BCfrom_pre of Sil.atom + type bounds_check = BClen_imply of Exp.t * Exp.t * Exp.t list | BCfrom_pre of Predicates.atom let implication_lhs = ref Prop.prop_emp @@ -1143,7 +1123,7 @@ end = struct (** free vars in array len position in current strexp part of prop *) let prop_fav_len prop = let do_hpred fav = function - | Sil.Hpointsto (_, Sil.Earray ((Exp.Var _ as len), _, _), _) -> + | Predicates.Hpointsto (_, Earray ((Var _ as len), _, _), _) -> Exp.free_vars len |> Ident.set_of_sequence ~init:fav | _ -> fav @@ -1183,7 +1163,8 @@ end = struct pre *) let atom_is_array_bounds_check atom = Prop.atom_is_inequality atom - && Sil.atom_free_vars atom |> Sequence.exists ~f:(fun id -> Ident.Set.mem id !fav_in_array_len) + && Predicates.atom_free_vars atom + |> Sequence.exists ~f:(fun id -> Ident.Set.mem id !fav_in_array_len) let get_bounds_checks () = !bounds_checks @@ -1227,7 +1208,7 @@ end = struct (* optional print of missing: if print something, prepend with newline *) if !missing_pi <> [] || !missing_sigma <> [] || !missing_fld <> [] || !missing_typ <> [] - || not (Sil.is_sub_empty sub) + || not (Predicates.is_sub_empty sub) then ( L.d_ln () ; L.d_str "[" ; d_missing_ sub ; L.d_str "]" ) @@ -1277,13 +1258,13 @@ end = struct | EXC_FALSE -> () | EXC_FALSE_HPRED hpred -> - L.d_str " on " ; Sil.d_hpred hpred + L.d_str " on " ; Predicates.d_hpred hpred | EXC_FALSE_EXPS (e1, e2) -> L.d_str " on " ; Exp.d_exp e1 ; L.d_str "," ; Exp.d_exp e2 | EXC_FALSE_SEXPS (se1, se2) -> - L.d_str " on " ; Sil.d_sexp se1 ; L.d_str "," ; Sil.d_sexp se2 + L.d_str " on " ; Predicates.d_sexp se1 ; L.d_str "," ; Predicates.d_sexp se2 | EXC_FALSE_ATOM a -> - L.d_str " on " ; Sil.d_atom a + L.d_str " on " ; Predicates.d_atom a | EXC_FALSE_SIGMA sigma -> L.d_str " on " ; Prop.d_sigma sigma in @@ -1303,8 +1284,8 @@ let d_impl_err (arg1, (s1, s2), arg3) = ProverState.d_implication_error (arg1, ( (** extend a substitution *) let extend_sub sub v e = - let new_exp_sub = Sil.subst_of_list [(v, e)] in - Sil.sub_join new_exp_sub (Sil.sub_range_map (Sil.exp_sub new_exp_sub) sub) + let new_exp_sub = Predicates.subst_of_list [(v, e)] in + Predicates.sub_join new_exp_sub (Predicates.sub_range_map (Predicates.exp_sub new_exp_sub) sub) (** Extend [sub1] and [sub2] to witnesses that each instance of [e1\[sub1\]] is an instance of @@ -1317,13 +1298,13 @@ let exp_imply tenv calc_missing (subs : subst2) e1_in e2_in : subst2 = | false, false -> if Ident.equal v1 v2 then subs else if calc_missing && Ident.is_footprint v1 && Ident.is_footprint v2 then - let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in + let () = ProverState.add_missing_pi (Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("exps", subs, EXC_FALSE_EXPS (e1, e2))) | true, false -> raise (IMPL_EXC ("exps", subs, EXC_FALSE_EXPS (e1, e2))) | false, true -> - let sub2' = extend_sub (snd subs) v2 (Sil.exp_sub (fst subs) (Exp.Var v1)) in + let sub2' = extend_sub (snd subs) v2 (Predicates.exp_sub (fst subs) (Exp.Var v1)) in (fst subs, sub2') | true, true -> let v1' = Ident.create_fresh Ident.knormal in @@ -1363,23 +1344,23 @@ let exp_imply tenv calc_missing (subs : subst2) e1_in e2_in : subst2 = (* here e2' could also be a variable that we could try to substitute (as in the next match case), but we ignore that to avoid backtracking *) let e' = Exp.BinOp (Binop.MinusA None, e1, e2') in - do_imply subs (Prop.exp_normalize_noabs tenv Sil.sub_empty e') e2 + do_imply subs (Prop.exp_normalize_noabs tenv Predicates.sub_empty e') e2 | e1, Exp.BinOp (Binop.PlusA _, e2, (Exp.Var v2 as e2')) when Ident.is_primed v2 || Ident.is_footprint v2 -> (* symmetric of above case *) let e' = Exp.BinOp (Binop.MinusA None, e1, e2') in - do_imply subs (Prop.exp_normalize_noabs tenv Sil.sub_empty e') e2 + do_imply subs (Prop.exp_normalize_noabs tenv Predicates.sub_empty e') e2 | Exp.Var id, Exp.Lvar pv when Ident.is_footprint id && Pvar.is_local pv -> (* Footprint var could never be the same as local address *) raise (IMPL_EXC ("expression not equal", subs, EXC_FALSE_EXPS (e1, e2))) | Exp.Var _, e2 -> if calc_missing then - let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in + let () = ProverState.add_missing_pi (Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) | Exp.Lvar pv1, Exp.Const _ when Pvar.is_global pv1 -> if calc_missing then - let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in + let () = ProverState.add_missing_pi (Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) | Exp.Lvar v1, Exp.Lvar v2 -> @@ -1477,23 +1458,25 @@ let array_len_imply tenv calc_missing subs len1 len2 indices2 = (** Extend [sub1] and [sub2] to witnesses that each instance of [se1\[sub1\]] is an instance of [se2\[sub2\]]. Raise IMPL_FALSE if not possible. *) let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 : - subst2 * Sil.strexp option * Sil.strexp option = - (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; + subst2 * Predicates.strexp option * Predicates.strexp option = + (* L.d_str "sexp_imply "; Predicates.d_sexp se1; L.d_str " "; Predicates.d_sexp se2; L.d_str " : "; Typ.d_full typ2; L.d_ln(); *) match (se1, se2) with - | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> + | Predicates.Eexp (e1, _), Predicates.Eexp (e2, _) -> (exp_imply tenv calc_missing subs e1 e2, None, None) - | Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) -> + | Predicates.Estruct (fsel1, inst1), Predicates.Estruct (fsel2, _) -> let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in - let fld_frame_opt = if fld_frame <> [] then Some (Sil.Estruct (fld_frame, inst1)) else None in + let fld_frame_opt = + if fld_frame <> [] then Some (Predicates.Estruct (fld_frame, inst1)) else None + in let fld_missing_opt = - if fld_missing <> [] then Some (Sil.Estruct (fld_missing, inst1)) else None + if fld_missing <> [] then Some (Predicates.Estruct (fld_missing, inst1)) else None in (subs', fld_frame_opt, fld_missing_opt) - | Sil.Estruct _, Sil.Eexp (e2, _) -> ( - let e2' = Sil.exp_sub (snd subs) e2 in + | Predicates.Estruct _, Predicates.Eexp (e2, _) -> ( + let e2' = Predicates.exp_sub (snd subs) e2 in match e2' with | Exp.Var id2 when Ident.is_primed id2 -> let id2' = Ident.create_fresh Ident.knormal in @@ -1502,38 +1485,39 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 : | _ -> d_impl_err ("sexp_imply not implemented", subs, EXC_FALSE_SEXPS (se1, se2)) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | Sil.Earray (len1, esel1, inst1), Sil.Earray (len2, esel2, _) -> + | Predicates.Earray (len1, esel1, inst1), Predicates.Earray (len2, esel2, _) -> let indices2 = List.map ~f:fst esel2 in let subs' = array_len_imply tenv calc_missing subs len1 len2 indices2 in let subs'', index_frame, index_missing = array_imply tenv source calc_index_frame calc_missing subs' esel1 esel2 typ2 in let index_frame_opt = - if index_frame <> [] then Some (Sil.Earray (len1, index_frame, inst1)) else None + if index_frame <> [] then Some (Predicates.Earray (len1, index_frame, inst1)) else None in let index_missing_opt = if index_missing <> [] && !BiabductionConfig.footprint then - Some (Sil.Earray (len1, index_missing, inst1)) + Some (Predicates.Earray (len1, index_missing, inst1)) else None in (subs'', index_frame_opt, index_missing_opt) - | Sil.Eexp (_, inst), Sil.Estruct (fsel, inst') -> + | Predicates.Eexp (_, inst), Predicates.Estruct (fsel, inst') -> d_impl_err ( "WARNING: function call with parameters of struct type, treating as unknown" , subs , EXC_FALSE_SEXPS (se1, se2) ) ; let fsel' = - let g (f, _) = (f, Sil.Eexp (Exp.Var (Ident.create_fresh Ident.knormal), inst)) in + let g (f, _) = (f, Predicates.Eexp (Exp.Var (Ident.create_fresh Ident.knormal), inst)) in List.map ~f:g fsel in sexp_imply tenv source calc_index_frame calc_missing subs - (Sil.Estruct (fsel', inst')) + (Predicates.Estruct (fsel', inst')) se2 typ2 - | Sil.Eexp _, Sil.Earray (len, _, inst) | Sil.Estruct _, Sil.Earray (len, _, inst) -> - let se1' = Sil.Earray (len, [(Exp.zero, se1)], inst) in + | Predicates.Eexp _, Predicates.Earray (len, _, inst) + | Predicates.Estruct _, Predicates.Earray (len, _, inst) -> + let se1' = Predicates.Earray (len, [(Exp.zero, se1)], inst) in sexp_imply tenv source calc_index_frame calc_missing subs se1' se2 typ2 - | Sil.Earray (len, _, _), Sil.Eexp (_, inst) -> - let se2' = Sil.Earray (len, [(Exp.zero, se2)], inst) in + | Predicates.Earray (len, _, _), Predicates.Eexp (_, inst) -> + let se2' = Predicates.Earray (len, [(Exp.zero, se2)], inst) in let typ2' = Typ.mk_array typ2 in (* In the sexp_imply, struct_imply, array_imply, and sexp_imply_nolhs functions, the typ2 argument is only used by eventually passing its value to Typ.Struct.fld, Exp.Lfield, @@ -1548,7 +1532,8 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 : and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : - subst2 * (Typ.Fieldname.t * Sil.strexp) list * (Typ.Fieldname.t * Sil.strexp) list = + subst2 * (Typ.Fieldname.t * Predicates.strexp) list * (Typ.Fieldname.t * Predicates.strexp) list + = let lookup = Tenv.lookup tenv in match (fsel1, fsel2) with | _, [] -> @@ -1597,7 +1582,7 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 : - subst2 * (Exp.t * Sil.strexp) list * (Exp.t * Sil.strexp) list = + subst2 * (Exp.t * Predicates.strexp) list * (Exp.t * Predicates.strexp) list = let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ2 in match (esel1, esel2) with | _, [] -> @@ -1626,8 +1611,8 @@ and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 and sexp_imply_nolhs tenv source calc_missing (subs : subst2) se2 typ2 = match se2 with - | Sil.Eexp (e2_, _) -> ( - let e2 = Sil.exp_sub (snd subs) e2_ in + | Predicates.Eexp (e2_, _) -> ( + let e2 = Predicates.exp_sub (snd subs) e2_ in match e2 with | Exp.Var v2 when Ident.is_primed v2 -> let v2' = path_to_id source in @@ -1640,13 +1625,13 @@ and sexp_imply_nolhs tenv source calc_missing (subs : subst2) se2 typ2 = else raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) | Exp.Const _ when calc_missing -> let id = path_to_id source in - ProverState.add_missing_pi (Sil.Aeq (Exp.Var id, e2_)) ; + ProverState.add_missing_pi (Predicates.Aeq (Exp.Var id, e2_)) ; subs | _ -> raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) ) - | Sil.Estruct (fsel2, _) -> + | Predicates.Estruct (fsel2, _) -> (fun (x, _, _) -> x) (struct_imply tenv source calc_missing subs [] fsel2 typ2) - | Sil.Earray (_, esel2, _) -> + | Predicates.Earray (_, esel2, _) -> (fun (x, _, _) -> x) (array_imply tenv source false calc_missing subs [] esel2 typ2) @@ -1661,29 +1646,30 @@ let rec exp_list_imply tenv calc_missing subs l1 l2 = let filter_ne_lhs sub e0 = function - | Sil.Hpointsto (e, _, _) -> - if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None - | Sil.Hlseg (Sil.Lseg_NE, _, e, _, _) -> - if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None - | Sil.Hdllseg (Sil.Lseg_NE, _, e, _, _, e', _) -> - if Exp.equal e0 (Sil.exp_sub sub e) || Exp.equal e0 (Sil.exp_sub sub e') then Some () + | Predicates.Hpointsto (e, _, _) -> + if Exp.equal e0 (Predicates.exp_sub sub e) then Some () else None + | Predicates.Hlseg (Lseg_NE, _, e, _, _) -> + if Exp.equal e0 (Predicates.exp_sub sub e) then Some () else None + | Predicates.Hdllseg (Lseg_NE, _, e, _, _, e', _) -> + if Exp.equal e0 (Predicates.exp_sub sub e) || Exp.equal e0 (Predicates.exp_sub sub e') then + Some () else None | _ -> None let filter_hpred sub hpred2 hpred1 = - match (Sil.hpred_sub sub hpred1, hpred2) with - | Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_PE, _, _, _, _) -> - if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false + match (Predicates.hpred_sub sub hpred1, hpred2) with + | Predicates.Hlseg (Lseg_NE, hpara1, e1, f1, el1), Predicates.Hlseg (Lseg_PE, _, _, _, _) -> + if Predicates.equal_hpred (Hlseg (Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false else None - | Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) -> - if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true + | Predicates.Hlseg (Lseg_PE, hpara1, e1, f1, el1), Predicates.Hlseg (Lseg_NE, _, _, _, _) -> + if Predicates.equal_hpred (Hlseg (Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true else None (* return missing disequality *) - | Sil.Hpointsto (e1, _, _), Sil.Hlseg (_, _, e2, _, _) -> + | Predicates.Hpointsto (e1, _, _), Predicates.Hlseg (_, _, e2, _, _) -> if Exp.equal e1 e2 then Some false else None | hpred1, hpred2 -> - if Sil.equal_hpred hpred1 hpred2 then Some false else None + if Predicates.equal_hpred hpred1 hpred2 then Some false else None let hpred_has_primed_lhs sub hpred = @@ -1698,13 +1684,13 @@ let hpred_has_primed_lhs sub hpred = | _ -> Exp.free_vars e |> Sequence.exists ~f:Ident.is_primed in - let exp_has_primed e = find_primed (Sil.exp_sub sub e) in + let exp_has_primed e = find_primed (Predicates.exp_sub sub e) in match hpred with - | Sil.Hpointsto (e, _, _) -> + | Predicates.Hpointsto (e, _, _) -> exp_has_primed e - | Sil.Hlseg (_, _, e, _, _) -> + | Predicates.Hlseg (_, _, e, _, _) -> exp_has_primed e - | Sil.Hdllseg (_, _, iF, _, _, iB, _) -> + | Predicates.Hdllseg (_, _, iF, _, _, iB, _) -> exp_has_primed iF && exp_has_primed iB @@ -1734,7 +1720,7 @@ let expand_hpred_pointer = fun tenv calc_index_frame hpred -> let rec expand changed calc_index_frame hpred = match hpred with - | Sil.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) -> + | Predicates.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) -> let cnt_texp' = match match adr_typ.desc with @@ -1767,9 +1753,11 @@ let expand_hpred_pointer = L.(die InternalError) "expand_hpred_pointer: Unexpected non-sizeof type in Lfield" ) in - let hpred' = Sil.Hpointsto (adr_base, Estruct ([(fld, cnt)], Sil.inst_none), cnt_texp') in + let hpred' = + Predicates.Hpointsto (adr_base, Estruct ([(fld, cnt)], Predicates.inst_none), cnt_texp') + in expand true true hpred' - | Sil.Hpointsto (Exp.Lindex (e, ind), se, t) -> + | Predicates.Hpointsto (Lindex (e, ind), se, t) -> let t' = match t with | Exp.Sizeof ({typ= t_} as sizeof_data) -> @@ -1784,13 +1772,15 @@ let expand_hpred_pointer = | _ -> Exp.get_undefined false in - let hpred' = Sil.Hpointsto (e, Sil.Earray (len, [(ind, se)], Sil.inst_none), t') in + let hpred' = + Predicates.Hpointsto (e, Predicates.Earray (len, [(ind, se)], Predicates.inst_none), t') + in expand true true hpred' - | Sil.Hpointsto (Exp.BinOp (Binop.PlusPI, e1, e2), Sil.Earray (len, esel, inst), t) -> + | Predicates.Hpointsto (BinOp (PlusPI, e1, e2), Earray (len, esel, inst), t) -> let shift_exp e = Exp.BinOp (Binop.PlusA None, e, e2) in let len' = shift_exp len in let esel' = List.map ~f:(fun (e, se) -> (shift_exp e, se)) esel in - let hpred' = Sil.Hpointsto (e1, Sil.Earray (len', esel', inst), t) in + let hpred' = Predicates.Hpointsto (e1, Predicates.Earray (len', esel', inst), t) in expand true calc_index_frame hpred' | _ -> (changed, calc_index_frame, hpred) @@ -1972,14 +1962,14 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing = of length given by its type only active in type_size mode *) let sexp_imply_preprocess se1 texp1 se2 = match (se1, texp1, se2) with - | Sil.Eexp (_, inst), Exp.Sizeof _, Sil.Earray _ when Config.type_size -> - let se1' = Sil.Earray (texp1, [(Exp.zero, se1)], inst) in + | Predicates.Eexp (_, inst), Exp.Sizeof _, Predicates.Earray _ when Config.type_size -> + let se1' = Predicates.Earray (texp1, [(Exp.zero, se1)], inst) in L.d_strln ~color:Orange "sexp_imply_preprocess" ; L.d_str " se1: " ; - Sil.d_sexp se1 ; + Predicates.d_sexp se1 ; L.d_ln () ; L.d_str " se1': " ; - Sil.d_sexp se1' ; + Predicates.d_sexp se1' ; L.d_ln () ; se1' | _ -> @@ -1991,13 +1981,13 @@ let sexp_imply_preprocess se1 texp1 se2 = let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) = let is_callee = match e1 with Exp.Lvar pv -> Pvar.is_callee pv | _ -> false in let is_allocated_lhs e = - let filter = function Sil.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false in + let filter = function Predicates.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false in List.exists ~f:filter prop1.Prop.sigma in let type_rhs e = let sub_opt = ref None in let filter = function - | Sil.Hpointsto (e', _, Exp.Sizeof sizeof_data) when Exp.equal e' e -> + | Predicates.Hpointsto (e', _, Exp.Sizeof sizeof_data) when Exp.equal e' e -> sub_opt := Some sizeof_data ; true | _ -> @@ -2009,8 +1999,8 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 match (texp1, texp2, se1, se2) with | ( Exp.Sizeof {typ= {desc= Tptr (t1, _)}; dynamic_length= None} , Exp.Sizeof {typ= {desc= Tptr (t2, _)}; dynamic_length= None} - , Sil.Eexp (e1', _) - , Sil.Eexp (e2', _) ) + , Predicates.Eexp (e1', _) + , Predicates.Eexp (e2', _) ) when not (is_allocated_lhs e1') -> ( match type_rhs e2' with | Some sizeof_data2 -> ( @@ -2037,8 +2027,8 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 : subst2 * Prop.normal Prop.t = match hpred2 with - | Sil.Hpointsto (e2_, se2, texp2) -> ( - let e2 = Sil.exp_sub (snd subs) e2_ in + | Predicates.Hpointsto (e2_, se2, texp2) -> ( + let e2 = Predicates.exp_sub (snd subs) e2_ in ( match e2 with | Exp.Lvar _ -> () @@ -2057,7 +2047,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 raise (IMPL_EXC ("lhs does not have e|->", subs, EXC_FALSE_HPRED hpred2)) | Some iter1' -> ( match Prop.prop_iter_current tenv iter1' with - | Sil.Hpointsto (e1, se1, texp1), _ -> ( + | Predicates.Hpointsto (e1, se1, texp1), _ -> ( try let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp2 in let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in @@ -2069,12 +2059,12 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) ; ( match fld_missing with | Some fld_missing -> - ProverState.add_missing_fld (Sil.Hpointsto (e2_, fld_missing, texp1)) + ProverState.add_missing_fld (Predicates.Hpointsto (e2_, fld_missing, texp1)) | None -> () ) ; ( match fld_frame with | Some fld_frame -> - ProverState.add_frame_fld (Sil.Hpointsto (e1, fld_frame, texp1)) + ProverState.add_frame_fld (Predicates.Hpointsto (e1, fld_frame, texp1)) | None -> () ) ; ( match typing_missing with @@ -2090,11 +2080,11 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in (subs', prop1') with IMPL_EXC (s, _, _) when calc_missing -> raise (MISSING_EXC s) ) - | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> + | Predicates.Hlseg (Lseg_NE, para1, e1, f1, elist1), _ -> (* Unroll lseg *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_instantiate para1 e1 n' elist1 in - let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para1 n' f1 elist1] in + let _, para_inst1 = Predicates.hpara_instantiate para1 e1 n' elist1 in + let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_PE para1 n' f1 elist1] in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in L.d_increase_indent () ; let res = @@ -2104,13 +2094,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 sigma2 hpred2 ) in L.d_decrease_indent () ; res - | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Exp.equal (Sil.exp_sub (fst subs) iF1) e2 -> + | Predicates.Hdllseg (Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ + when Exp.equal (Predicates.exp_sub (fst subs) iF1) e2 -> (* Unroll dllseg forward *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in + let _, para_inst1 = Predicates.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in let hpred_list1 = - para_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] + para_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para1 n' iF1 oF1 iB1 elist1] in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in L.d_increase_indent () ; @@ -2121,13 +2111,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 sigma2 hpred2 ) in L.d_decrease_indent () ; res - | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Exp.equal (Sil.exp_sub (fst subs) iB1) e2 -> + | Predicates.Hdllseg (Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ + when Exp.equal (Predicates.exp_sub (fst subs) iB1) e2 -> (* Unroll dllseg backward *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in + let _, para_inst1 = Predicates.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in let hpred_list1 = - para_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] + para_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para1 iF1 oB1 iB1 n' elist1] in let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in L.d_increase_indent () ; @@ -2140,9 +2130,9 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 L.d_decrease_indent () ; res | _ -> assert false ) ) ) - | Sil.Hlseg (k, para2, e2_, f2_, elist2_) -> ( + | Predicates.Hlseg (k, para2, e2_, f2_, elist2_) -> ( (* for now ignore implications between PE and NE *) - let e2, f2 = (Sil.exp_sub (snd subs) e2_, Sil.exp_sub (snd subs) f2_) in + let e2, f2 = (Predicates.exp_sub (snd subs) e2_, Predicates.exp_sub (snd subs) f2_) in ( match e2 with | Exp.Lvar _ -> () @@ -2152,18 +2142,19 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 raise (Exceptions.Abduction_case_not_implemented __POS__) ) | _ -> () ) ; - if Exp.equal e2 f2 && Sil.equal_lseg_kind k Sil.Lseg_PE then (subs, prop1) + if Exp.equal e2 f2 && Predicates.equal_lseg_kind k Lseg_PE then (subs, prop1) else match Prop.prop_iter_create prop1 with | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | Some iter1 -> ( match - Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) + Prop.prop_iter_find iter1 + (filter_hpred (fst subs) (Predicates.hpred_sub (snd subs) hpred2)) with | None -> - let elist2 = List.map ~f:(fun e -> Sil.exp_sub (snd subs) e) elist2_ in - let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in + let elist2 = List.map ~f:(fun e -> Predicates.exp_sub (snd subs) e) elist2_ in + let _, para_inst2 = Predicates.hpara_instantiate para2 e2 f2 elist2 in L.d_increase_indent () ; let res = decrease_indent_when_exception (fun () -> @@ -2172,46 +2163,44 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 (* calc_missing is false as we're checking an instantiation of the original list *) L.d_decrease_indent () ; res | Some iter1' -> ( - let elist2 = List.map ~f:(fun e -> Sil.exp_sub (snd subs) e) elist2_ in + let elist2 = List.map ~f:(fun e -> Predicates.exp_sub (snd subs) e) elist2_ in (* force instantiation of existentials *) let subs' = exp_list_imply tenv calc_missing subs (f2 :: elist2) (f2 :: elist2) in let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in let hpred1 = match Prop.prop_iter_current tenv iter1' with | hpred1, b -> - if b then ProverState.add_missing_pi (Sil.Aneq (e2_, f2_)) ; + if b then ProverState.add_missing_pi (Predicates.Aneq (e2_, f2_)) ; (* for PE |- NE *) hpred1 in match hpred1 with - | Sil.Hlseg _ -> + | Predicates.Hlseg _ -> (subs', prop1') - | Sil.Hpointsto _ -> + | Predicates.Hpointsto _ -> (* unroll rhs list and try again *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst2 = Sil.hpara_instantiate para2 e2_ n' elist2 in - let hpred_list2 = - para_inst2 @ [Prop.mk_lseg tenv Sil.Lseg_PE para2 n' f2_ elist2_] - in + let _, para_inst2 = Predicates.hpara_instantiate para2 e2_ n' elist2 in + let hpred_list2 = para_inst2 @ [Prop.mk_lseg tenv Lseg_PE para2 n' f2_ elist2_] in L.d_increase_indent () ; let res = decrease_indent_when_exception (fun () -> try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2 with exn when SymOp.exn_not_failure exn -> L.d_strln ~color:Red "backtracking lseg: trying rhs of length exactly 1" ; - let _, para_inst3 = Sil.hpara_instantiate para2 e2_ f2_ elist2 in + let _, para_inst3 = Predicates.hpara_instantiate para2 e2_ f2_ elist2 in sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3 ) in L.d_decrease_indent () ; res - | Sil.Hdllseg _ -> + | Predicates.Hdllseg _ -> assert false ) ) ) - | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> + | Predicates.Hdllseg (Lseg_PE, _, _, _, _, _, _) -> d_impl_err ("rhs dllsegPE not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) - | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) -> ( + | Predicates.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) -> ( (* for now ignore implications between PE and NE *) - let iF2, oF2 = (Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2) in - let iB2, oB2 = (Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2) in + let iF2, oF2 = (Predicates.exp_sub (snd subs) iF2, Predicates.exp_sub (snd subs) oF2) in + let iB2, oB2 = (Predicates.exp_sub (snd subs) iB2, Predicates.exp_sub (snd subs) oB2) in ( match oF2 with | Exp.Lvar _ -> () @@ -2235,12 +2224,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | Some iter1 -> ( match - Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) + Prop.prop_iter_find iter1 + (filter_hpred (fst subs) (Predicates.hpred_sub (snd subs) hpred2)) with | None -> - let elist2 = List.map ~f:(fun e -> Sil.exp_sub (snd subs) e) elist2 in + let elist2 = List.map ~f:(fun e -> Predicates.exp_sub (snd subs) e) elist2 in let _, para_inst2 = - if Exp.equal iF2 iB2 then Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 + if Exp.equal iF2 iB2 then Predicates.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 else assert false (* Only base case of rhs list considered for now *) in @@ -2253,7 +2243,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 L.d_decrease_indent () ; res | Some iter1' -> (* Only consider implications between identical listsegs for now *) - let elist2 = List.map ~f:(fun e -> Sil.exp_sub (snd subs) e) elist2 in + let elist2 = List.map ~f:(fun e -> Predicates.exp_sub (snd subs) e) elist2 in (* force instantiation of existentials *) let subs' = exp_list_imply tenv calc_missing subs @@ -2270,8 +2260,8 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * Prop.normal Prop.t = let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *) - | Sil.Hpointsto (e2_, _, _) -> ( - let e2 = Sil.exp_sub (snd subs) e2_ in + | Predicates.Hpointsto (e2_, _, _) -> ( + let e2 = Predicates.exp_sub (snd subs) e2_ in match e2 with | Exp.Const (Const.Cstr s) -> Some (s, true) @@ -2290,15 +2280,20 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * let index = Exp.int (IntLit.of_int (String.length s)) in match !Language.curr_language with | Clang -> - Sil.Earray (Exp.int len, [(index, Sil.Eexp (Exp.zero, Sil.inst_none))], Sil.inst_none) + Predicates.Earray + ( Exp.int len + , [(index, Predicates.Eexp (Exp.zero, Predicates.inst_none))] + , Predicates.inst_none ) | Java -> let mk_fld_sexp field_name = let fld = Typ.Fieldname.make Typ.Name.Java.java_lang_string field_name in - let se = Sil.Eexp (Exp.Var (Ident.create_fresh Ident.kprimed), Sil.Inone) in + let se = + Predicates.Eexp (Exp.Var (Ident.create_fresh Ident.kprimed), Predicates.Inone) + in (fld, se) in let fields = ["count"; "hash"; "offset"; "value"] in - Sil.Estruct (List.map ~f:mk_fld_sexp fields, Sil.inst_none) + Predicates.Estruct (List.map ~f:mk_fld_sexp fields, Predicates.inst_none) in let const_string_texp = match !Language.curr_language with @@ -2316,17 +2311,17 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * ; dynamic_length= None ; subtype= Subtype.exact } in - Sil.Hpointsto (root, sexp, const_string_texp) + Predicates.Hpointsto (root, sexp, const_string_texp) in let mk_constant_class_hpred s = (* create an hpred from a constant class *) let root = Exp.Const (Const.Cclass (Ident.string_to_name s)) in let sexp = (* TODO: add appropriate fields *) - Sil.Estruct + Predicates.Estruct ( [ ( Typ.Fieldname.make Typ.Name.Java.java_lang_class "name" - , Sil.Eexp (Exp.Const (Const.Cstr s), Sil.Inone) ) ] - , Sil.inst_none ) + , Predicates.Eexp (Exp.Const (Const.Cstr s), Predicates.Inone) ) ] + , Predicates.inst_none ) in let class_texp = let class_type = Typ.Name.Java.java_lang_class in @@ -2336,7 +2331,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * ; dynamic_length= None ; subtype= Subtype.exact } in - Sil.Hpointsto (root, sexp, class_texp) + Predicates.Hpointsto (root, sexp, class_texp) in try match move_primed_lhs_from_front subs sigma2 with @@ -2376,7 +2371,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * | None -> let subs' = match hpred2' with - | Sil.Hpointsto (e2, se2, te2) -> + | Predicates.Hpointsto (e2, se2, te2) -> let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) te2 in sexp_imply_nolhs tenv e2 calc_missing subs se2 typ2 | _ -> @@ -2393,10 +2388,10 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * L.d_decrease_indent () ; res in match hpred2 with - | Sil.Hpointsto (e2_, se2, t) -> + | Predicates.Hpointsto (e2_, se2, t) -> let changed, calc_index_frame', hpred2' = expand_hpred_pointer tenv calc_index_frame - (Sil.Hpointsto (Prop.exp_normalize_noabs tenv (snd subs) e2_, se2, t)) + (Predicates.Hpointsto (Prop.exp_normalize_noabs tenv (snd subs) e2_, se2, t)) in if changed then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') @@ -2419,13 +2414,13 @@ let prepare_prop_for_implication tenv (_, sub2) pi1 sigma1 = let imply_pi tenv calc_missing (sub1, sub2) prop pi2 = let do_atom a = - let a' = Sil.atom_sub sub2 a in + let a' = Predicates.atom_sub sub2 a in try if not (check_atom tenv prop a') then raise (IMPL_EXC ("rhs atom missing in lhs", (sub1, sub2), EXC_FALSE_ATOM a')) with IMPL_EXC _ when calc_missing -> L.d_str "imply_pi: adding missing atom " ; - Sil.d_atom a ; + Predicates.d_atom a ; L.d_ln () ; ProverState.add_missing_pi a in @@ -2442,30 +2437,32 @@ let rec pre_check_pure_implication tenv calc_missing (subs : subst2) pi1 pi2 = match pi2 with | [] -> subs - | (Sil.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) -> ( - let e2, f2 = (Sil.exp_sub (snd subs) e2_in, Sil.exp_sub (snd subs) f2_in) in + | (Predicates.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) -> ( + let e2, f2 = (Predicates.exp_sub (snd subs) e2_in, Predicates.exp_sub (snd subs) f2_in) in if Exp.equal e2 f2 then pre_check_pure_implication tenv calc_missing subs pi1 pi2' else match (e2, f2) with - | Exp.Var v2, f2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + | Exp.Var v2, f2 when Ident.is_primed v2 (* && not (Predicates.mem_sub v2 (snd subs)) *) -> (* The commented-out condition should always hold. *) let sub2' = extend_sub (snd subs) v2 f2 in pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2' - | e2, Exp.Var v2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + | e2, Exp.Var v2 when Ident.is_primed v2 (* && not (Predicates.mem_sub v2 (snd subs)) *) -> (* The commented-out condition should always hold. *) let sub2' = extend_sub (snd subs) v2 e2 in pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2' | _ -> let pi1' = Prop.pi_sub (fst subs) pi1 in let prop_for_impl = prepare_prop_for_implication tenv subs pi1' [] in - imply_atom tenv calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)) ; + imply_atom tenv calc_missing subs prop_for_impl (Predicates.Aeq (e2_in, f2_in)) ; pre_check_pure_implication tenv calc_missing subs pi1 pi2' ) - | (Sil.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ + | (Predicates.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ when (not calc_missing) && match e with Var v -> not (Ident.is_primed v) | _ -> true -> raise (IMPL_EXC - ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE)) - | (Sil.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' -> + ( "ineq e2=f2 in rhs with e2 not primed var" + , (Predicates.sub_empty, Predicates.sub_empty) + , EXC_FALSE )) + | (Predicates.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' -> pre_check_pure_implication tenv calc_missing subs pi1 pi2' @@ -2476,7 +2473,7 @@ let check_array_bounds tenv (sub1, sub2) prop = let check_failed atom = ProverState.checks := Bounds_check :: !ProverState.checks ; L.d_str ~color:Red "bounds_check failed: provable atom: " ; - Sil.d_atom atom ; + Predicates.d_atom atom ; L.d_ln () ; if not Config.bound_error_allowed_in_procedure_call then raise (IMPL_EXC ("bounds check", (sub1, sub2), EXC_FALSE)) @@ -2487,8 +2484,8 @@ let check_array_bounds tenv (sub1, sub2) prop = in let check_bound = function | ProverState.BClen_imply (len1_, len2_, _indices2) -> - let len1 = Sil.exp_sub sub1 len1_ in - let len2 = Sil.exp_sub sub2 len2_ in + let len1 = Predicates.exp_sub sub1 len1_ in + let len2 = Predicates.exp_sub sub2 len2_ in (* L.d_strln ~color:Orange "check_bound "; Exp.d_exp len1; L.d_str " "; Exp.d_exp len2; L.d_ln(); *) let indices_to_check = @@ -2497,8 +2494,8 @@ let check_array_bounds tenv (sub1, sub2) prop = in List.iter ~f:(fail_if_le len1) indices_to_check | ProverState.BCfrom_pre atom_ -> - let atom_neg = atom_negate tenv (Sil.atom_sub sub2 atom_) in - (* L.d_strln ~color:Orange "BCFrom_pre"; Sil.d_atom atom_neg; L.d_ln (); *) + let atom_neg = atom_negate tenv (Predicates.atom_sub sub2 atom_) in + (* L.d_strln ~color:Orange "BCFrom_pre"; Predicates.d_atom atom_neg; L.d_ln (); *) if check_atom tenv prop atom_neg then check_failed atom_neg in List.iter ~f:check_bound (ProverState.get_bounds_checks ()) @@ -2512,7 +2509,7 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 let filter (id, e) = Ident.is_normal id && Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in - let sub1_base = Sil.sub_filter_pair ~f:filter prop1.Prop.sub in + let sub1_base = Predicates.sub_filter_pair ~f:filter prop1.Prop.sub in let pi1, pi2 = (Prop.get_pure prop1, Prop.get_pure prop2) in let sigma1, sigma2 = (prop1.Prop.sigma, prop2.Prop.sigma) in let subs = pre_check_pure_implication tenv calc_missing (prop1.Prop.sub, sub1_base) pi1 pi2 in @@ -2577,13 +2574,13 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 type implication_result = | ImplOK of ( check list - * Sil.subst - * Sil.subst - * Sil.hpred list - * Sil.atom list - * Sil.hpred list - * Sil.hpred list - * Sil.hpred list + * Predicates.subst + * Predicates.subst + * Predicates.hpred list + * Predicates.atom list + * Predicates.hpred list + * Predicates.hpred list + * Predicates.hpred list * (Exp.t * Exp.t) list * (Exp.t * Exp.t) list ) | ImplFail of check list @@ -2674,14 +2671,3 @@ let find_minimum_pure_cover tenv cases = in let shrink cases = if List.length cases > 2 then shrink_ [] cases else cases in try Some (shrink (grow [] cases)) with NO_COVER -> None - -(* -(** Check [prop |- e1 if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None - | _ -> None -*) diff --git a/infer/src/biabduction/Prover.mli b/infer/src/biabduction/Prover.mli index 2027f62a8..111700c54 100644 --- a/infer/src/biabduction/Prover.mli +++ b/infer/src/biabduction/Prover.mli @@ -10,9 +10,9 @@ open! IStd (** Functions for Theorem Proving *) -open Sil +open Predicates -val atom_negate : Tenv.t -> Sil.atom -> Sil.atom +val atom_negate : Tenv.t -> atom -> atom (** Negate an atom *) (** {2 Ordinary Theorem Proving} *) @@ -49,7 +49,7 @@ val is_root : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> offset list opti [offlist]. If so, it returns [Some(offlist)]. Otherwise, it returns [None]. Assumes that [base_exp] points to the beginning of a structure, not the middle. *) -val expand_hpred_pointer : Tenv.t -> bool -> Sil.hpred -> bool * bool * Sil.hpred +val expand_hpred_pointer : Tenv.t -> bool -> hpred -> bool * bool * hpred (** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off. Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *) @@ -70,13 +70,13 @@ val d_typings : (Exp.t * Exp.t) list -> unit type implication_result = | ImplOK of ( check list - * Sil.subst - * Sil.subst - * Sil.hpred list - * Sil.atom list - * Sil.hpred list - * Sil.hpred list - * Sil.hpred list + * subst + * subst + * hpred list + * atom list + * hpred list + * hpred list + * hpred list * (Exp.t * Exp.t) list * (Exp.t * Exp.t) list ) | ImplFail of check list @@ -89,8 +89,7 @@ val check_implication_for_footprint : (** {2 Cover: minimum set of pi's whose disjunction is equivalent to true} *) -val find_minimum_pure_cover : - Tenv.t -> (Sil.atom list * 'a) list -> (Sil.atom list * 'a) list option +val find_minimum_pure_cover : Tenv.t -> (atom list * 'a) list -> (atom list * 'a) list option (** Find minimum set of pi's in [cases] whose disjunction covers true *) (** {2 Subtype checking} *) diff --git a/infer/src/biabduction/Rearrange.ml b/infer/src/biabduction/Rearrange.ml index d58e679c9..0b882524e 100644 --- a/infer/src/biabduction/Rearrange.ml +++ b/infer/src/biabduction/Rearrange.ml @@ -78,7 +78,7 @@ let bounds_check tenv pname prop len e = let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (t : Typ.t) - (off : Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t = + (off : Predicates.offset list) inst : Predicates.atom list * Predicates.strexp * Typ.t = if Config.trace_rearrange then ( L.d_increase_indent () ; L.d_strln "entering create_struct_values" ; @@ -86,7 +86,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp Typ.d_full t ; L.d_ln () ; L.d_str "off: " ; - Sil.d_offset_list off ; + Predicates.d_offset_list off ; L.d_ln () ; L.d_ln () ) ; let new_id () = incr max_stamp ; Ident.create kind !max_stamp in @@ -95,13 +95,13 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp L.d_str "create_struct_values type:" ; Typ.d_full t ; L.d_str " off: " ; - Sil.d_offset_list off ; + Predicates.d_offset_list off ; L.d_ln () ; raise (Exceptions.Bad_footprint pos) in match (t.desc, off) with | Tstruct _, [] -> - ([], Sil.Estruct ([], inst), t) + ([], Predicates.Estruct ([], inst), t) | Tstruct name, Off_fld (f, _) :: off' -> ( match Tenv.lookup tenv name with | Some ({fields; statics} as struct_typ) -> ( @@ -110,7 +110,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in - let se = Sil.Estruct ([(f, se')], inst) in + let se = Predicates.Estruct ([(f, se')], inst) in let replace_typ_of_f (f', t', a') = if Typ.Fieldname.equal f f' then (f, res_t', a') else (f', t', a') in @@ -129,30 +129,30 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp in let e' = Absarray.array_clean_new_index footprint_part e in let len = Exp.Var (new_id ()) in - let se = Sil.Earray (len, [(e', se')], inst) in + let se = Predicates.Earray (len, [(e', se')], inst) in let res_t = Typ.mk_array res_t' in - (Sil.Aeq (e, e') :: atoms', se, res_t) + (Predicates.Aeq (e, e') :: atoms', se, res_t) | Tarray {elt= t'; length; stride}, off -> ( let len = match length with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len) in match off with | [] -> - ([], Sil.Earray (len, [], inst), t) - | Sil.Off_index e :: off' -> + ([], Predicates.Earray (len, [], inst), t) + | Predicates.Off_index e :: off' -> bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ; let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in let e' = Absarray.array_clean_new_index footprint_part e in - let se = Sil.Earray (len, [(e', se')], inst) in + let se = Predicates.Earray (len, [(e', se')], inst) in let res_t = Typ.mk_array ~default:t res_t' ?length ?stride in - (Sil.Aeq (e, e') :: atoms', se, res_t) - | Sil.Off_fld _ :: _ -> + (Predicates.Aeq (e, e') :: atoms', se, res_t) + | Predicates.Off_fld _ :: _ -> assert false ) | Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun, [] | Tptr _, [] | TVar _, [] -> let id = new_id () in - ([], Sil.Eexp (Exp.Var id, inst), t) + ([], Predicates.Eexp (Exp.Var id, inst), t) | (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _ | TVar _), Off_index e :: off' -> (* In this case, we lift t to the t array. *) let t', mk_typ_f = @@ -167,16 +167,16 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in let e' = Absarray.array_clean_new_index footprint_part e in - let se = Sil.Earray (len, [(e', se')], inst) in + let se = Predicates.Earray (len, [(e', se')], inst) in let res_t = mk_typ_f (Tarray {elt= res_t'; length= None; stride= None}) in - (Sil.Aeq (e, e') :: atoms', se, res_t) + (Predicates.Aeq (e, e') :: atoms', se, res_t) | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun, _ | Tptr _, _ | TVar _, _ -> fail t off __POS__ in if Config.trace_rearrange then ( let _, se, _ = res in L.d_strln "exiting create_struct_values, returning" ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_decrease_indent () ; L.d_ln () ; L.d_ln () ) ; @@ -189,18 +189,18 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp If we want to implement the checks for array bounds errors, we need to change this function. *) let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se (typ : Typ.t) - (off : Sil.offset list) inst = + (off : Predicates.offset list) inst = let new_id () = incr max_stamp ; Ident.create kind !max_stamp in match (off, se, typ.desc) with - | [], Sil.Eexp _, _ | [], Sil.Estruct _, _ -> + | [], Predicates.Eexp _, _ | [], Predicates.Estruct _, _ -> [([], se, typ)] - | [], Sil.Earray _, _ -> - let off_new = Sil.Off_index Exp.zero :: off in + | [], Predicates.Earray _, _ -> + let off_new = Predicates.Off_index Exp.zero :: off in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst - | Off_fld _ :: _, Sil.Earray _, Tarray _ -> - let off_new = Sil.Off_index Exp.zero :: off in + | Off_fld _ :: _, Predicates.Earray _, Tarray _ -> + let off_new = Predicates.Off_index Exp.zero :: off in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst - | Off_fld (f, _) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> ( + | Off_fld (f, _) :: off', Predicates.Estruct (fsel, inst'), Tstruct name -> ( match Tenv.lookup tenv name with | Some ({fields; statics} as struct_typ) -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with @@ -216,7 +216,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp if Typ.Fieldname.equal f1 f then (f1, res_se') else ft1 in let res_fsel' = - List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] + List.sort ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp] (List.map ~f:replace_fse fsel) in let replace_fta ((f1, _, a1) as fta1) = @@ -226,7 +226,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields) in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; - (res_atoms', Sil.Estruct (res_fsel', inst'), typ) :: acc + (res_atoms', Predicates.Estruct (res_fsel', inst'), typ) :: acc in List.fold ~f:replace ~init:[] atoms_se_typ_list' | None -> @@ -234,7 +234,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp create_struct_values pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in let res_fsel' = - List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] ((f, se') :: fsel) + List.sort ~compare:[%compare: Typ.Fieldname.t * Predicates.strexp] ((f, se') :: fsel) in let replace_fta (f', t', a') = if Typ.Fieldname.equal f' f then (f, res_typ', a') else (f', t', a') @@ -243,30 +243,30 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields) in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; - [(atoms', Sil.Estruct (res_fsel', inst'), typ)] ) + [(atoms', Predicates.Estruct (res_fsel', inst'), typ)] ) | None -> raise (Exceptions.Missing_fld (f, __POS__)) ) | None -> raise (Exceptions.Missing_fld (f, __POS__)) ) | Off_fld _ :: _, _, _ -> raise (Exceptions.Bad_footprint __POS__) - | Off_index _ :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _) - | Off_index _ :: _, Sil.Estruct _, Tstruct _ -> + | Off_index _ :: _, Predicates.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun | Tptr _) + | Off_index _ :: _, Predicates.Estruct _, Tstruct _ -> (* L.d_strln ~color:Orange "turn into an array"; *) let len = match se with - | Sil.Eexp (_, Sil.Ialloc) -> + | Predicates.Eexp (_, Predicates.Ialloc) -> Exp.one (* if allocated explicitly, we know len is 1 *) | _ -> if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *) else Exp.Var (new_id ()) in - let se_new = Sil.Earray (len, [(Exp.zero, se)], inst) in + let se_new = Predicates.Earray (len, [(Exp.zero, se)], inst) in let typ_new = Typ.mk_array typ in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst | ( Off_index e :: off' - , Sil.Earray (len, esel, inst_arr) + , Predicates.Earray (len, esel, inst_arr) , Tarray {elt= typ'; length= len_for_typ'; stride} ) -> ( bounds_check tenv pname orig_prop len e (State.get_loc_exn ()) ; match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with @@ -280,7 +280,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp let res_esel' = List.map ~f:replace_ise esel in if Typ.equal res_typ' typ' || Int.equal (List.length res_esel') 1 then ( res_atoms' - , Sil.Earray (len, res_esel', inst_arr) + , Predicates.Earray (len, res_esel', inst_arr) , Typ.mk_array ~default:typ res_typ' ?length:len_for_typ' ?stride ) :: acc else raise (Exceptions.Bad_footprint __POS__) @@ -310,7 +310,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp false in if index_in_array then - let array_default = Sil.Earray (array_len, array_cont, inst_arr) in + let array_default = Predicates.Earray (array_len, array_cont, inst_arr) in let typ_default = Typ.mk_array ~default:typ_array typ_cont ?length:typ_array_len in [([], array_default, typ_default)] else if !BiabductionConfig.footprint then ( @@ -319,9 +319,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in check_sound elem_typ ; let cont_new = - List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) + List.sort ~compare:[%compare: Exp.t * Predicates.strexp] ((index, elem_se) :: array_cont) in - let array_new = Sil.Earray (array_len, cont_new, inst_arr) in + let array_new = Predicates.Earray (array_len, cont_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in [(atoms, array_new, typ_new)] ) else @@ -333,9 +333,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in check_sound elem_typ ; let cont_new = - List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) + List.sort ~compare:[%compare: Exp.t * Predicates.strexp] ((index, elem_se) :: array_cont) in - let array_new = Sil.Earray (array_len, cont_new, inst_arr) in + let array_new = Predicates.Earray (array_len, cont_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in [(atoms, array_new, typ_new)] in @@ -351,9 +351,9 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp List.fold ~f:(fun acc' (atoms', se', typ') -> check_sound typ' ; - let atoms_new = Sil.Aeq (index, i) :: atoms' in + let atoms_new = Predicates.Aeq (index, i) :: atoms' in let isel_new = list_rev_and_concat isel_seen_rev ((i, se') :: isel_unseen) in - let array_new = Sil.Earray (array_len, isel_new, inst_arr) in + let array_new = Predicates.Earray (array_len, isel_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array typ' ?length:typ_array_len in (atoms_new, array_new, typ_new) :: acc' ) ~init:[] atoms_se_typ_list @@ -372,10 +372,10 @@ let laundry_offset_for_footprint max_stamp offs_in = match offs with | [] -> (List.rev offs_seen, List.rev eqs) - | (Sil.Off_fld _ as off) :: offs' -> + | (Predicates.Off_fld _ as off) :: offs' -> let offs_seen' = off :: offs_seen in laundry offs_seen' eqs offs' - | (Sil.Off_index idx as off) :: offs' -> + | (Predicates.Off_index idx as off) :: offs' -> if exp_has_only_footprint_ids idx then let offs_seen' = off :: offs_seen in laundry offs_seen' eqs offs' @@ -383,7 +383,7 @@ let laundry_offset_for_footprint max_stamp offs_in = let () = incr max_stamp in let fid_new = Ident.create Ident.kfootprint !max_stamp in let exp_new = Exp.Var fid_new in - let off_new = Sil.Off_index exp_new in + let off_new = Predicates.Off_index exp_new in let offs_seen' = off_new :: offs_seen in let eqs' = (fid_new, idx) :: eqs in laundry offs_seen' eqs' offs' @@ -392,7 +392,7 @@ let laundry_offset_for_footprint max_stamp offs_in = let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se te - (off : Sil.offset list) inst = + (off : Predicates.offset list) inst = let typ = Exp.texp_to_typ None te in let off', laundry_atoms = let off', eqs = laundry_offset_for_footprint max_stamp off in @@ -402,11 +402,11 @@ let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se t in if Config.trace_rearrange then ( L.d_str "entering strexp_extend_values se: " ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_str " typ: " ; Typ.d_full typ ; L.d_str " off': " ; - Sil.d_offset_list off' ; + Predicates.d_offset_list off' ; L.d_strln (if footprint_part then " FP" else " RE") ) ; let atoms_se_typ_list = strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off' inst @@ -432,13 +432,13 @@ let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se t let collect_root_offset exp = let root = Exp.root_of_lexp exp in - let offsets = Sil.exp_get_offsets exp in + let offsets = Predicates.exp_get_offsets exp in (root, offsets) (** Exp.Construct a points-to predicate for an expression, to add to a footprint. *) let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : - Sil.hpred * Sil.hpred * Sil.atom list = + Predicates.hpred * Predicates.hpred * Predicates.atom list = let root, off = collect_root_offset lexp in if not (exp_has_only_footprint_ids root) then if @@ -463,7 +463,7 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : let fun_exp = Exp.Const (Const.Cfun fun_name) in ( [] , Prop.mk_ptsto tenv root - (Sil.Eexp (fun_exp, inst)) + (Predicates.Eexp (fun_exp, inst)) (Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) ) | _, [], Typ.Tfun -> let atoms, se, typ = @@ -483,8 +483,8 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : ) in let atoms, ptsto_foot = create_ptsto true off_foot in - let sub = Sil.subst_of_list eqs in - let ptsto = Sil.hpred_sub sub ptsto_foot in + let sub = Predicates.subst_of_list eqs in + let ptsto = Predicates.hpred_sub sub ptsto_foot in let atoms' = List.map ~f:(fun (id, e) -> Prop.mk_eq tenv (Exp.Var id) e) eqs in (ptsto, ptsto_foot, atoms @ atoms') @@ -492,10 +492,10 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : (** Check if the path in exp exists already in the current ptsto predicate. If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) let prop_iter_check_fields_ptsto_shallow tenv iter lexp = - let offset = Sil.exp_get_offsets lexp in + let offset = Predicates.exp_get_offsets lexp in let _, se, _ = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, t), _ -> + | Predicates.Hpointsto (e, se, t), _ -> (e, se, t) | _ -> assert false @@ -503,9 +503,9 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp = let rec check_offset se = function | [] -> None - | Sil.Off_fld (fld, _) :: off' -> ( + | Predicates.Off_fld (fld, _) :: off' -> ( match se with - | Sil.Estruct (fsel, _) -> ( + | Predicates.Estruct (fsel, _) -> ( match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with | Some (_, se') -> check_offset se' off' @@ -513,7 +513,7 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp = Some fld ) | _ -> Some fld ) - | Sil.Off_index _ :: _ -> + | Predicates.Off_index _ :: _ -> None in check_offset se offset @@ -528,36 +528,37 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = L.d_str "entering prop_iter_extend_ptsto lexp: " ; Exp.d_exp lexp ; L.d_ln () ) ; - let offset = Sil.exp_get_offsets lexp in + let offset = Predicates.exp_get_offsets lexp in let max_stamp = Prop.prop_iter_max_stamp iter in let extend_footprint_pred = function - | Sil.Hpointsto (e, se, te) -> + | Predicates.Hpointsto (e, se, te) -> let atoms_se_te_list = strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se te offset inst in List.map - ~f:(fun (atoms', se', te') -> (atoms', Sil.Hpointsto (e, se', te'))) + ~f:(fun (atoms', se', te') -> (atoms', Predicates.Hpointsto (e, se', te'))) atoms_se_te_list - | Sil.Hlseg (k, hpara, e1, e2, el) -> ( - match hpara.Sil.body with - | Sil.Hpointsto (e', se', te') :: body_rest -> + | Predicates.Hlseg (k, hpara, e1, e2, el) -> ( + match hpara.Predicates.body with + | Predicates.Hpointsto (e', se', te') :: body_rest -> let atoms_se_te_list = strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se' te' offset inst in let atoms_body_list = List.map - ~f:(fun (atoms0, se0, te0) -> (atoms0, Sil.Hpointsto (e', se0, te0) :: body_rest)) + ~f:(fun (atoms0, se0, te0) -> + (atoms0, Predicates.Hpointsto (e', se0, te0) :: body_rest) ) atoms_se_te_list in let atoms_hpara_list = List.map - ~f:(fun (atoms, body') -> (atoms, {hpara with Sil.body= body'})) + ~f:(fun (atoms, body') -> (atoms, {hpara with Predicates.body= body'})) atoms_body_list in List.map - ~f:(fun (atoms, hpara') -> (atoms, Sil.Hlseg (k, hpara', e1, e2, el))) + ~f:(fun (atoms, hpara') -> (atoms, Predicates.Hlseg (k, hpara', e1, e2, el))) atoms_hpara_list | _ -> assert false ) @@ -568,7 +569,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let iter' = List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms in - Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se, te)) + Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se, te)) in let do_extend e se te = if Config.trace_rearrange then ( @@ -576,7 +577,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = L.d_str "e: " ; Exp.d_exp e ; L.d_str " se : " ; - Sil.d_sexp se ; + Predicates.d_sexp se ; L.d_str " te: " ; Exp.d_texp_full te ; L.d_ln () ; @@ -608,11 +609,11 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let sigma_pto, sigma_rest = List.partition_tf ~f:(function - | Sil.Hpointsto (e', _, _) -> + | Predicates.Hpointsto (e', _, _) -> Exp.equal e e' - | Sil.Hlseg (_, _, e1, _, _) -> + | Predicates.Hlseg (_, _, e1, _, _) -> Exp.equal e e1 - | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) -> + | Predicates.Hdllseg (_, _, e_iF, _, _, e_iB, _) -> Exp.equal e e_iF || Exp.equal e e_iB ) footprint_sigma in @@ -630,7 +631,8 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = [([], footprint_sigma)] in List.map - ~f:(fun (atoms, sigma') -> (atoms, List.stable_sort ~compare:Sil.compare_hpred sigma')) + ~f:(fun (atoms, sigma') -> + (atoms, List.stable_sort ~compare:Predicates.compare_hpred sigma') ) atoms_sigma_list in let iter_atoms_fp_sigma_list = list_product iter_list atoms_fp_sigma_list in @@ -660,7 +662,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = res_iter_list in match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, te), _ -> + | Predicates.Hpointsto (e, se, te), _ -> do_extend e se te | _ -> assert false @@ -695,7 +697,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = | Some iter -> Prop.prop_iter_prev_then_insert iter ptsto in - let offsets_default = Sil.exp_get_offsets lexp in + let offsets_default = Predicates.exp_get_offsets lexp in Prop.prop_iter_set_state iter offsets_default @@ -817,10 +819,10 @@ let add_guarded_by_constraints tenv prop lexp pdesc = false in match get_fld_strexp_and_typ typ typ_matches_guarded_by flds with - | Some (Sil.Eexp (matching_exp, _), _) -> + | Some (Predicates.Eexp (matching_exp, _), _) -> List.find_map ~f:(function - | Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ}) + | Predicates.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ}) when Exp.equal lhs_exp matching_exp -> get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds | _ -> @@ -835,11 +837,12 @@ let add_guarded_by_constraints tenv prop lexp pdesc = ~f:(fun hpred -> (* FIXME: silenced warning may be legit *) match[@warning "-57"] hpred with - | Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ}) - | Sil.Hpointsto (_, Sil.Eexp ((Const (Cclass clazz) as lhs_exp), _), Exp.Sizeof {typ}) + | Predicates.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ}) + | Predicates.Hpointsto + (_, Predicates.Eexp ((Const (Cclass clazz) as lhs_exp), _), Exp.Sizeof {typ}) when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) -> - Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) - | Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> ( + Some (Predicates.Eexp (lhs_exp, Predicates.inst_none), typ) + | Predicates.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> ( (* first, try to find a field that exactly matches the guarded-by string *) match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with | None when guarded_by_str_is_this guarded_by_str0 -> @@ -852,7 +855,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = match_on_field_type typ flds | Some _ as res_opt -> res_opt ) - | Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof {typ}) + | Predicates.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof {typ}) when ( guarded_by_str_is_current_class_this guarded_by_str0 pname || guarded_by_str_is_super_class_this guarded_by_str0 pname ) && Pvar.is_this pvar -> @@ -915,7 +918,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = false ) || (* or the prop says we already have the lock *) List.exists - ~f:(function Sil.Apred (Alocked, _) -> true | _ -> false) + ~f:(function Predicates.Apred (Alocked, _) -> true | _ -> false) (Attribute.get_for_exp tenv prop guarded_by_exp) in let guardedby_is_self_referential = @@ -937,13 +940,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let is_accessible_through_local_ref exp = List.exists ~f:(function - | Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> + | Predicates.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> Exp.equal exp rhs_exp - | Sil.Hpointsto (_, Estruct (flds, _), _) -> + | Predicates.Hpointsto (_, Estruct (flds, _), _) -> List.exists ~f:(fun (fld, strexp) -> match strexp with - | Sil.Eexp (rhs_exp, _) -> + | Predicates.Eexp (rhs_exp, _) -> Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) | _ -> false ) @@ -965,7 +968,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = && not (proc_has_suppress_guarded_by_annot pdesc) in match find_guarded_by_exp guarded_by_str prop.Prop.sigma with - | Some (Sil.Eexp (guarded_by_exp, _), typ) -> + | Some (Predicates.Eexp (guarded_by_exp, _), typ) -> if is_read_write_lock typ then (* TODO: model/understand read-write locks rather than ignoring them *) prop @@ -1006,13 +1009,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc = in let check_fld_locks typ prop_acc (fld, strexp) = match strexp with - | Sil.Eexp (exp, _) when Exp.equal exp lexp -> + | Predicates.Eexp (exp, _) when Exp.equal exp lexp -> enforce_guarded_access fld typ prop_acc | _ -> prop_acc in let hpred_check_flds prop_acc = function - | Sil.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) -> + | Predicates.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) -> List.fold ~f:(check_fld_locks typ) ~init:prop_acc flds | _ -> prop_acc @@ -1053,7 +1056,7 @@ let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst = List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter_foot atoms in let iter' = Prop.prop_iter_replace_footprint_sigma iter_foot_atoms sigma_fp in - let offsets_default = Sil.exp_get_offsets lexp in + let offsets_default = Predicates.exp_get_offsets lexp in Prop.prop_iter_set_state iter' offsets_default @@ -1117,7 +1120,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = else ( check_field_splitting () ; match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, te), offset -> + | Predicates.Hpointsto (e, se, te), offset -> let max_stamp = Prop.prop_iter_max_stamp iter in let atoms_se_te_list = strexp_extend_values pname tenv orig_prop false Ident.kprimed (ref max_stamp) se te @@ -1127,7 +1130,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = let iter' = List.fold ~f:(Prop.prop_iter_add_atom !BiabductionConfig.footprint) ~init:iter atoms' in - Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se', te')) + Prop.prop_iter_update_current iter' (Predicates.Hpointsto (e, se', te')) in let filter it = let p = Prop.prop_iter_to_prop tenv it in @@ -1151,20 +1154,20 @@ let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist = if Config.nelseg then let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in - let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_NE para n' e2 elist] in + let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in + let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_NE para n' e2 elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_base_case = - let _, para_inst = Sil.hpara_instantiate para e1 e2 elist in + let _, para_inst = Predicates.hpara_instantiate para e1 e2 elist in Prop.prop_iter_update_current_by_list iter para_inst in recurse_on_iters [iter_inductive_case; iter_base_case] else let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in - let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in + let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in + let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_PE para n' e2 elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in recurse_on_iters [iter_inductive_case] @@ -1174,14 +1177,12 @@ let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist = let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist = let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in - let hpred_list1 = - para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll n' e1 e3 e4 elist] - in + let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in + let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll n' e1 e3 e4 elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_base_case = - let _, para_dll_inst = Sil.hpara_dll_instantiate para_dll e1 e2 e3 elist in + let _, para_dll_inst = Predicates.hpara_dll_instantiate para_dll e1 e2 e3 elist in let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in let prop' = Prop.prop_iter_to_prop tenv iter' in let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' in @@ -1194,14 +1195,12 @@ let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist = let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in - let hpred_list1 = - para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_NE para_dll e1 e2 e4 n' elist] - in + let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in + let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_NE para_dll e1 e2 e4 n' elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_base_case = - let _, para_dll_inst = Sil.hpara_dll_instantiate para_dll e4 e2 e3 elist in + let _, para_dll_inst = Predicates.hpara_dll_instantiate para_dll e4 e2 e3 elist in let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in let prop' = Prop.prop_iter_to_prop tenv iter' in let prop'' = Prop.conjoin_eq tenv ~footprint:!BiabductionConfig.footprint e1 e4 prop' in @@ -1214,8 +1213,8 @@ let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e let iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist = let iter_nonemp_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_inst1 = Sil.hpara_instantiate para e1 n' elist in - let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in + let _, para_inst1 = Predicates.hpara_instantiate para e1 n' elist in + let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Lseg_PE para n' e2 elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_subcases = @@ -1236,10 +1235,8 @@ let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter elist = let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in - let hpred_list1 = - para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll n' e1 e3 e4 elist] - in + let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e1 e2 n' elist in + let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll n' e1 e3 e4 elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_subcases = @@ -1261,10 +1258,8 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p elist = let iter_inductive_case = let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in - let _, para_dll_inst1 = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in - let hpred_list1 = - para_dll_inst1 @ [Prop.mk_dllseg tenv Sil.Lseg_PE para_dll e1 e2 e4 n' elist] - in + let _, para_dll_inst1 = Predicates.hpara_dll_instantiate para_dll e4 n' e3 elist in + let hpred_list1 = para_dll_inst1 @ [Prop.mk_dllseg tenv Lseg_PE para_dll e1 e2 e4 n' elist] in Prop.prop_iter_update_current_by_list iter hpred_list1 in let iter_subcases = @@ -1283,7 +1278,7 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p (** find the type at the offset from the given type expression, if any *) let type_at_offset tenv texp off = - let rec strip_offset (off : Sil.offset list) (typ : Typ.t) = + let rec strip_offset (off : Predicates.offset list) (typ : Typ.t) = match (off, typ.desc) with | [], _ -> Some typ @@ -1310,7 +1305,7 @@ let type_at_offset tenv texp off = let check_type_size tenv pname prop texp off typ_from_instr = L.d_strln ~color:Orange "check_type_size" ; L.d_str "off: " ; - Sil.d_offset_list off ; + Predicates.d_offset_list off ; L.d_ln () ; L.d_str "typ_from_instr: " ; Typ.d_full typ_from_instr ; @@ -1345,9 +1340,9 @@ let check_type_size tenv pname prop texp off typ_from_instr = * that the theorem prover cannot prove the inconsistency of any of the * new iters in the result. *) let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : - Sil.offset list Prop.prop_iter list = + Predicates.offset list Prop.prop_iter list = let rec root_typ_of_offsets = function - | Sil.Off_fld (f, fld_typ) :: _ -> ( + | Predicates.Off_fld (f, fld_typ) :: _ -> ( match fld_typ.desc with | Tstruct _ -> (* access through field: get the struct type from the field *) @@ -1362,12 +1357,12 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : fld_typ | _ -> typ_from_instr ) - | Sil.Off_index _ :: off -> + | Predicates.Off_index _ :: off -> Typ.mk_array (root_typ_of_offsets off) | _ -> typ_from_instr in - let typ = root_typ_of_offsets (Sil.exp_get_offsets lexp) in + let typ = root_typ_of_offsets (Predicates.exp_get_offsets lexp) in if Config.trace_rearrange then ( L.d_increase_indent () ; L.d_strln "entering iter_rearrange" ; @@ -1414,9 +1409,9 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : f_many_iters [] iters in let filter = function - | Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) -> + | Predicates.Hpointsto (base, _, _) | Predicates.Hlseg (_, _, base, _, _) -> Prover.is_root tenv prop base lexp - | Sil.Hdllseg (_, _, first, _, _, last, _) -> ( + | Predicates.Hdllseg (_, _, first, _, _, last, _) -> ( let result_first = Prover.is_root tenv prop first lexp in match result_first with | None -> @@ -1430,14 +1425,14 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : [default_case_iter iter] | Some iter -> ( match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (_, _, texp), off -> + | Predicates.Hpointsto (_, _, texp), off -> if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr ; iter_rearrange_ptsto pname tenv prop iter lexp inst - | Sil.Hlseg (Sil.Lseg_NE, para, e1, e2, elist), _ -> + | Predicates.Hlseg (Lseg_NE, para, e1, e2, elist), _ -> iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist - | Sil.Hlseg (Sil.Lseg_PE, para, e1, e2, elist), _ -> + | Predicates.Hlseg (Lseg_PE, para, e1, e2, elist), _ -> iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist - | Sil.Hdllseg (Sil.Lseg_NE, para_dll, e1, e2, e3, e4, elist), _ -> ( + | Predicates.Hdllseg (Lseg_NE, para_dll, e1, e2, e3, e4, elist), _ -> ( match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with | None, None -> assert false @@ -1445,7 +1440,7 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist | _, Some _ -> iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist ) - | Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> ( + | Predicates.Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> ( match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with | None, None -> assert false @@ -1474,7 +1469,7 @@ let var_has_annotation pdesc is_annotation pvar = let attr_has_annot is_annotation tenv prop exp = let attr_has_annot = function - | Sil.Apred ((Aretval (pname, ret_attr) | Aundef (pname, ret_attr, _, _)), _) + | Predicates.Apred ((Aretval (pname, ret_attr) | Aundef (pname, ret_attr, _, _)), _) when is_annotation ret_attr -> Some (Typ.Procname.to_string pname) | _ -> @@ -1494,7 +1489,7 @@ let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, s false in match strexp with - | Sil.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp -> + | Predicates.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp -> let has_annot = fld_has_annot fld in if has_annot then obj_str := Some (Typ.Fieldname.to_simplified_string fld) ; has_annot @@ -1509,7 +1504,7 @@ let is_only_pt_by_fld_or_param_with_annot pdesc tenv prop deref_exp is_annotatio let obj_str = ref None in let is_pt_by_fld_or_param_with_annot hpred = match hpred with - | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp ((Exp.Var _ as exp), _), _) + | Predicates.Hpointsto (Exp.Lvar pvar, Eexp ((Exp.Var _ as exp), _), _) when Exp.equal exp deref_exp -> let var_has_annotation = Pvar.is_seed pvar && var_has_annotation pdesc is_annotation pvar in if var_has_annotation then obj_str := Some (Pvar.to_string pvar) ; @@ -1517,7 +1512,7 @@ let is_only_pt_by_fld_or_param_with_annot pdesc tenv prop deref_exp is_annotatio if Option.is_some procname_str_opt then obj_str := procname_str_opt ; (* it's ok for a local with no annotation to point to deref_exp *) var_has_annotation || Option.is_some procname_str_opt || Pvar.is_local pvar - | Sil.Hpointsto (_, Sil.Estruct (flds, _), Exp.Sizeof {typ}) -> + | Predicates.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> List.for_all ~f:(is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp) flds | _ -> true @@ -1648,7 +1643,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = let get_exp_called () = (* Exp called in the block's function call*) match State.get_instr () with - | Some (Sil.Call (_, Exp.Var id, _, _, _)) -> + | Some (Sil.Call (_, Var id, _, _, _)) -> Errdesc.find_ident_assignment (State.get_node_exn ()) id | _ -> None @@ -1708,7 +1703,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = It returns an iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc : - Sil.offset list Prop.prop_iter list = + Predicates.offset list Prop.prop_iter list = let nlexp = match Prop.exp_normalize_prop tenv prop lexp with | Exp.BinOp (Binop.PlusPI, ep, e) -> @@ -1718,7 +1713,7 @@ let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc : e in let ptr_tested_for_zero = Prover.check_disequal tenv prop (Exp.root_of_lexp nlexp) Exp.zero in - let inst = Sil.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in + let inst = Predicates.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in L.d_strln ".... Rearrangement Start ...." ; L.d_str "Exp: " ; Exp.d_exp nlexp ; diff --git a/infer/src/biabduction/Rearrange.mli b/infer/src/biabduction/Rearrange.mli index b75911746..ef371fe4f 100644 --- a/infer/src/biabduction/Rearrange.mli +++ b/infer/src/biabduction/Rearrange.mli @@ -32,7 +32,7 @@ val rearrange : -> Typ.t -> Prop.normal Prop.t -> Location.t - -> Sil.offset list Prop.prop_iter list + -> Predicates.offset list Prop.prop_iter list (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. It returns an iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) diff --git a/infer/src/biabduction/RetainCycles.ml b/infer/src/biabduction/RetainCycles.ml index 377fcd762..b2129b527 100644 --- a/infer/src/biabduction/RetainCycles.ml +++ b/infer/src/biabduction/RetainCycles.ml @@ -136,7 +136,7 @@ let get_weak_alias_type prop e = let sigma = prop.Prop.sigma in let check_weak_alias hpred = match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e', _), Sizeof {typ}) -> ( + | Predicates.Hpointsto (_, Eexp (e', _), Sizeof {typ}) -> ( match typ.Typ.desc with | (Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained)) when Exp.equal e' e -> @@ -154,7 +154,8 @@ let get_cycles found_cycles root tenv prop = let sigma = prop.Prop.sigma in let get_points_to e = List.find - ~f:(fun hpred -> match hpred with Sil.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false) + ~f:(fun hpred -> + match hpred with Predicates.Hpointsto (e', _, _) -> Exp.equal e' e | _ -> false ) sigma in (* Perform a dfs of a graph stopping when e_root is reached. Returns the set of cycles reached. *) @@ -169,7 +170,7 @@ let get_cycles found_cycles root tenv prop = match fields with | [] -> found_cycles - | (field, Sil.Eexp (f_exp, f_inst)) :: el' -> + | (field, Predicates.Eexp (f_exp, f_inst)) :: el' -> let rc_field = {rc_field_name= field; rc_field_inst= f_inst} in let obj_edge = {rc_from= from_node; rc_field} in let edge = Object obj_edge in @@ -191,7 +192,7 @@ let get_cycles found_cycles root tenv prop = match get_points_to f_exp with | None -> found_cycles - | Some (Sil.Hpointsto (_, Sil.Estruct (new_fields, _), Exp.Sizeof {typ= te})) + | Some (Predicates.Hpointsto (_, Estruct (new_fields, _), Exp.Sizeof {typ= te})) when edge_is_strong tenv obj_edge -> let rc_to = {rc_node_exp= f_exp; rc_node_typ= te} in dfs ~found_cycles ~root_node ~from_node:rc_to ~rev_path:(edge :: rev_path) @@ -205,8 +206,8 @@ let get_cycles found_cycles root tenv prop = found_cycles in match root with - | Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) when Sil.is_objc_object root - -> + | Predicates.Hpointsto (e_root, Estruct (fl, _), Exp.Sizeof {typ= te}) + when Predicates.is_objc_object root -> let se_root = {rc_node_exp= e_root; rc_node_typ= te} in (* start dfs with empty path and expr pointing to root *) dfs ~found_cycles ~root_node:se_root ~from_node:se_root ~rev_path:[] ~fields:fl ~visited:[] diff --git a/infer/src/biabduction/RetainCyclesType.ml b/infer/src/biabduction/RetainCyclesType.ml index cf658f9fc..0446ba226 100644 --- a/infer/src/biabduction/RetainCyclesType.ml +++ b/infer/src/biabduction/RetainCyclesType.ml @@ -8,7 +8,7 @@ open! IStd type retain_cycle_node = {rc_node_exp: Exp.t; rc_node_typ: Typ.t} -type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Sil.inst} +type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Predicates.inst} type retain_cycle_edge_obj = {rc_from: retain_cycle_node; rc_field: retain_cycle_field} @@ -58,7 +58,7 @@ end) let is_inst_rearrange node = match node with | Object obj -> ( - match obj.rc_field.rc_field_inst with Sil.Irearrange _ -> true | _ -> false ) + match obj.rc_field.rc_field_inst with Predicates.Irearrange _ -> true | _ -> false ) | Block _ -> false @@ -99,7 +99,8 @@ let pp_retain_cycle_node f (node : retain_cycle_node) = let pp_retain_cycle_field f (field : retain_cycle_field) = - Format.fprintf f "%a[%a]" Typ.Fieldname.pp field.rc_field_name Sil.pp_inst field.rc_field_inst + Format.fprintf f "%a[%a]" Typ.Fieldname.pp field.rc_field_name Predicates.pp_inst + field.rc_field_inst let pp_retain_cycle_edge f (edge : retain_cycle_edge) = diff --git a/infer/src/biabduction/RetainCyclesType.mli b/infer/src/biabduction/RetainCyclesType.mli index 50505d4ff..cbd63c43d 100644 --- a/infer/src/biabduction/RetainCyclesType.mli +++ b/infer/src/biabduction/RetainCyclesType.mli @@ -9,7 +9,7 @@ open! IStd type retain_cycle_node = {rc_node_exp: Exp.t; rc_node_typ: Typ.t} -type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Sil.inst} +type retain_cycle_field = {rc_field_name: Typ.Fieldname.t; rc_field_inst: Predicates.inst} type retain_cycle_edge_obj = {rc_from: retain_cycle_node; rc_field: retain_cycle_field} diff --git a/infer/src/biabduction/State.ml b/infer/src/biabduction/State.ml index 6e055c849..6b4f2f31a 100644 --- a/infer/src/biabduction/State.ml +++ b/infer/src/biabduction/State.ml @@ -110,9 +110,9 @@ let instrs_normalize instrs = let subst = let count = ref Int.min_value in let gensym id = incr count ; Ident.set_stamp id !count in - Sil.subst_of_list (List.rev_map ~f:(fun id -> (id, Exp.Var (gensym id))) bound_ids) + Predicates.subst_of_list (List.rev_map ~f:(fun id -> (id, Exp.Var (gensym id))) bound_ids) in - let subst_and_add acc instr = Sil.instr_sub subst instr :: acc in + let subst_and_add acc instr = Predicates.instr_sub subst instr :: acc in Instrs.fold instrs ~init:[] ~f:subst_and_add @@ -167,7 +167,7 @@ let mk_find_duplicate_nodes : Procdesc.t -> Procdesc.Node.t -> Procdesc.NodeSet. let get_inst_update pos = let loc = get_loc_exn () in - Sil.inst_update loc pos + Predicates.inst_update loc pos let get_path () = @@ -191,7 +191,7 @@ let extract_pre p tenv pdesc abstract_fun = let sub = let idlist = Prop.free_vars p |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let count = ref 0 in - Sil.subst_of_list + Predicates.subst_of_list (List.map ~f:(fun id -> incr count ; diff --git a/infer/src/biabduction/State.mli b/infer/src/biabduction/State.mli index e5cb56d2b..d28b0e5cf 100644 --- a/infer/src/biabduction/State.mli +++ b/infer/src/biabduction/State.mli @@ -22,7 +22,7 @@ val get_diverging_states_node : unit -> Paths.PathSet.t val get_diverging_states_proc : unit -> Paths.PathSet.t (** Get the diverging states for the procedure *) -val get_inst_update : PredSymb.path_pos -> Sil.inst +val get_inst_update : PredSymb.path_pos -> Predicates.inst (** Get update instrumentation for the current loc *) val get_instr : unit -> Sil.instr option diff --git a/infer/src/biabduction/SymExec.ml b/infer/src/biabduction/SymExec.ml index 7d9b4d9a4..fdd8027df 100644 --- a/infer/src/biabduction/SymExec.ml +++ b/infer/src/biabduction/SymExec.ml @@ -20,7 +20,7 @@ let rec fldlist_assoc fld = function if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l -let unroll_type tenv (typ : Typ.t) (off : Sil.offset) = +let unroll_type tenv (typ : Typ.t) (off : Predicates.offset) = let fail pp_fld fld = L.d_strln ".... Invalid Field Access ...." ; L.d_printfln "Fld : %a" pp_fld fld ; @@ -41,7 +41,7 @@ let unroll_type tenv (typ : Typ.t) (off : Sil.offset) = | _, Off_index (Const (Cint i)) when IntLit.iszero i -> typ | _ -> - fail (Sil.pp_offset Pp.text) off + fail (Predicates.pp_offset Pp.text) off (** Apply function [f] to the expression at position [offlist] in [strexp]. If not found, expand @@ -60,10 +60,10 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty let pp_error () = L.d_strln ".... Invalid Field ...." ; L.d_str "strexp : " ; - Sil.d_sexp strexp ; + Predicates.d_sexp strexp ; L.d_ln () ; L.d_str "offlist : " ; - Sil.d_offset_list offlist ; + Predicates.d_offset_list offlist ; L.d_ln () ; L.d_str "type : " ; Typ.d_full typ ; @@ -74,38 +74,40 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty L.d_ln () in match (offlist, strexp, typ.Typ.desc) with - | [], Sil.Eexp (e, inst_curr), _ -> + | [], Predicates.Eexp (e, inst_curr), _ -> let inst_new = match inst with - | Sil.Ilookup -> + | Predicates.Ilookup -> (* a lookup does not change an inst unless it is inst_initial *) lookup_inst := Some inst_curr ; inst_curr | _ -> - Sil.update_inst inst_curr inst + Predicates.update_inst inst_curr inst in let e' = f (Some e) in - (e', Sil.Eexp (e', inst_new), typ, None) - | [], Sil.Estruct (fesl, inst'), _ -> - if not nullify_struct then (f None, Sil.Estruct (fesl, inst'), typ, None) + (e', Predicates.Eexp (e', inst_new), typ, None) + | [], Predicates.Estruct (fesl, inst'), _ -> + if not nullify_struct then (f None, Predicates.Estruct (fesl, inst'), typ, None) else if fp_root then ( pp_error () ; assert false ) else ( L.d_strln "WARNING: struct assignment treated as nondeterministic assignment" ; (f None, Prop.create_strexp_of_type tenv Prop.Fld_init typ None inst, typ, None) ) - | [], Sil.Earray _, _ -> - let offlist' = Sil.Off_index Exp.zero :: offlist in + | [], Predicates.Earray _, _ -> + let offlist' = Predicates.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst - | Sil.Off_fld _ :: _, Sil.Earray _, _ -> - let offlist_new = Sil.Off_index Exp.zero :: offlist in + | Predicates.Off_fld _ :: _, Predicates.Earray _, _ -> + let offlist_new = Predicates.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst lookup_inst - | Sil.Off_fld (fld, fld_typ) :: offlist', Sil.Estruct (fsel, inst'), Typ.Tstruct name -> ( + | ( Predicates.Off_fld (fld, fld_typ) :: offlist' + , Predicates.Estruct (fsel, inst') + , Typ.Tstruct name ) -> ( match Tenv.lookup tenv name with | Some ({fields} as struct_typ) -> ( - let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in + let t' = unroll_type tenv typ (Predicates.Off_fld (fld, fld_typ)) in match List.find ~f:(fun fse -> Typ.Fieldname.equal fld (fst fse)) fsel with | Some (_, se') -> let res_e', res_se', res_t', res_pred_insts_op' = @@ -115,7 +117,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty let replace_fse fse = if Typ.Fieldname.equal fld (fst fse) then (fld, res_se') else fse in - let res_se = Sil.Estruct (List.map ~f:replace_fse fsel, inst') in + let res_se = Predicates.Estruct (List.map ~f:replace_fse fsel, inst') in let replace_fta (f, t, a) = if Typ.Fieldname.equal fld f then (fld, res_t', a) else (f, t, a) in @@ -130,11 +132,11 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty | None -> pp_error () ; assert false ) - | Sil.Off_fld _ :: _, _, _ -> + | Predicates.Off_fld _ :: _, _, _ -> pp_error () ; assert false - | ( Sil.Off_index idx :: offlist' - , Sil.Earray (len, esel, inst1) + | ( Predicates.Off_index idx :: offlist' + , Predicates.Earray (len, esel, inst1) , Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> ( let nidx = Prop.exp_normalize_prop tenv p idx in match List.find ~f:(fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel with @@ -144,7 +146,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty lookup_inst in let replace_ese ese = if Exp.equal idx_ese' (fst ese) then (idx_ese', res_se') else ese in - let res_se = Sil.Earray (len, List.map ~f:replace_ese esel, inst1) in + let res_se = Predicates.Earray (len, List.map ~f:replace_ese esel, inst1) in let res_t = Typ.mk_array ~default:typ res_t' ?length:len' ?stride:stride' in (res_e', res_se, res_t, res_pred_insts_op') | None -> @@ -154,7 +156,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty L.d_strln " not materialized -- returning nondeterministic value" ; let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in (res_e', strexp, typ, None) ) - | Sil.Off_index _ :: _, _, _ -> + | Predicates.Off_index _ :: _, _, _ -> (* This case should not happen. The rearrangement should have materialized all the accessed cells. *) pp_error () ; @@ -176,12 +178,16 @@ let ptsto_lookup pdesc tenv p (lexp, se, sizeof) offlist id = let fp_root = match lexp with Exp.Var id -> Ident.is_footprint id | _ -> false in let lookup_inst = ref None in let e', se', typ', pred_insts_op' = - apply_offlist pdesc tenv p fp_root false (lexp, se, sizeof.Exp.typ) offlist f Sil.inst_lookup - lookup_inst + apply_offlist pdesc tenv p fp_root false (lexp, se, sizeof.Exp.typ) offlist f + Predicates.inst_lookup lookup_inst in let lookup_uninitialized = (* true if we have looked up an uninitialized value *) - match !lookup_inst with Some (Sil.Iinitial | Sil.Ialloc | Sil.Ilookup) -> true | _ -> false + match !lookup_inst with + | Some (Predicates.Iinitial | Predicates.Ialloc | Predicates.Ilookup) -> + true + | _ -> + false in let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in (e', ptsto', pred_insts_op', lookup_uninitialized) @@ -214,14 +220,14 @@ let update_iter iter pi sigma = (** Precondition: se should not include hpara_psto that could mean nonempty heaps. *) let rec execute_nullify_se = function - | Sil.Eexp _ -> - Sil.Eexp (Exp.zero, Sil.inst_nullify) - | Sil.Estruct (fsel, _) -> + | Predicates.Eexp _ -> + Predicates.Eexp (Exp.zero, Predicates.inst_nullify) + | Predicates.Estruct (fsel, _) -> let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in - Sil.Estruct (fsel', Sil.inst_nullify) - | Sil.Earray (len, esel, _) -> + Predicates.Estruct (fsel', Predicates.inst_nullify) + | Predicates.Earray (len, esel, _) -> let esel' = List.map ~f:(fun (idx, se) -> (idx, execute_nullify_se se)) esel in - Sil.Earray (len, esel', Sil.inst_nullify) + Predicates.Earray (len, esel', Predicates.inst_nullify) (** Do pruning for conditional [if (e1 != e2)] if [positive] is true and [(if (e1 == e2)] if @@ -422,7 +428,7 @@ let check_arith_norm_exp tenv pname exp prop = let check_already_dereferenced tenv pname cond prop = let find_hpred lhs = List.find - ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e lhs | _ -> false) + ~f:(function Predicates.Hpointsto (e, _, _) -> Exp.equal e lhs | _ -> false) prop.Prop.sigma in let rec is_check_zero = function @@ -452,7 +458,7 @@ let check_already_dereferenced tenv pname cond prop = match is_check_zero cond with | Some id -> ( match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with - | Some (Sil.Hpointsto (_, se, _)) -> ( + | Some (Predicates.Hpointsto (_, se, _)) -> ( match Tabulation.find_dereference_without_null_check_in_sexp se with | Some n -> Some (id, n) @@ -479,11 +485,11 @@ let check_already_dereferenced tenv pname cond prop = exception in that case *) let check_deallocate_static_memory prop_after = let check_deallocated_attribute = function - | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Lvar pv]) + | Predicates.Apred (Aresource ({ra_kind= Rrelease} as ra), [Lvar pv]) when Pvar.is_local pv || Pvar.is_global pv -> let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in raise (Exceptions.Deallocate_stack_variable freed_desc) - | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Const (Cstr s)]) -> + | Predicates.Apred (Aresource ({ra_kind= Rrelease} as ra), [Const (Cstr s)]) -> let freed_desc = Errdesc.explain_deallocate_constant_string s ra in raise (Exceptions.Deallocate_static_memory freed_desc) | _ -> @@ -543,7 +549,7 @@ let resolve_typename prop receiver_exp = let rec loop = function | [] -> None - | Sil.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp -> + | Predicates.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp -> Some typexp | _ :: hpreds -> loop hpreds @@ -760,7 +766,7 @@ let receiver_self receiver prop = List.exists ~f:(fun hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + | Predicates.Hpointsto (Lvar pv, Eexp (e, _), _) -> Exp.equal e receiver && Pvar.is_seed pv && Pvar.is_self pv | _ -> false ) @@ -890,7 +896,7 @@ let add_strexp_to_footprint tenv strexp abduced_pv typ prop = let add_to_footprint tenv abduced_pv typ prop = let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in let prop' = - add_strexp_to_footprint tenv (Sil.Eexp (fresh_fp_var, Sil.Inone)) abduced_pv typ prop + add_strexp_to_footprint tenv (Eexp (fresh_fp_var, Predicates.Inone)) abduced_pv typ prop in (prop', fresh_fp_var) @@ -900,7 +906,7 @@ let add_to_footprint tenv abduced_pv typ prop = footprint. regular abduction just adds a fresh footprint value of the correct type to the footprint. we can get rid of this special case if we fix the abduction on struct values *) let add_struct_value_to_footprint tenv abduced_pv typ prop = - let struct_strexp = Prop.create_strexp_of_type tenv Prop.Fld_init typ None Sil.inst_none in + let struct_strexp = Prop.create_strexp_of_type tenv Prop.Fld_init typ None Predicates.inst_none in let prop' = add_strexp_to_footprint tenv struct_strexp abduced_pv typ prop in (prop', struct_strexp) @@ -918,7 +924,8 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal List.find_map ~f:(fun hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (exp, _), _) when Pvar.equal pv abduced_ret_pv -> + | Predicates.Hpointsto (Exp.Lvar pv, Eexp (exp, _), _) when Pvar.equal pv abduced_ret_pv + -> Some exp | _ -> None ) @@ -927,7 +934,7 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal (* find an hpred [abduced] |-> A in [prop] and add [exp] = A to prop *) let bind_exp_to_abduced_val exp_to_bind abduced prop = let bind_exp prop = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (rhs, _), _) when Pvar.equal pv abduced -> + | Predicates.Hpointsto (Exp.Lvar pv, Eexp (rhs, _), _) when Pvar.equal pv abduced -> Prop.conjoin_eq tenv exp_to_bind rhs prop | _ -> prop @@ -968,7 +975,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l let iter_ren = Prop.prop_iter_make_id_primed tenv id iter in let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in match Prop.prop_iter_current tenv iter_ren with - | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist -> ( + | Predicates.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist -> ( let contents, new_ptsto, pred_insts_op, lookup_uninitialized = ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id in @@ -980,7 +987,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l false in let update acc (pi, sigma) = - let pi' = Sil.Aeq (Exp.Var id, contents) :: pi in + let pi' = Predicates.Aeq (Exp.Var id, contents) :: pi in let sigma' = new_ptsto :: sigma in let iter' = update_iter iter_ren pi' sigma' in let prop' = Prop.prop_iter_to_prop tenv iter' in @@ -997,7 +1004,7 @@ let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ l update acc_in ([], []) | Some pred_insts -> List.rev (List.fold ~f:update ~init:acc_in pred_insts) ) - | Sil.Hpointsto _, _ -> + | Predicates.Hpointsto _, _ -> Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@." ; Prop.prop_iter_to_prop tenv iter_ren :: acc_in | _ -> @@ -1043,7 +1050,7 @@ let execute_store ?(report_deref_errors = true) pname pdesc tenv lhs_exp typ rhs let execute_store_ pdesc tenv rhs_exp acc_in iter = let lexp, strexp, sizeof, offlist = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist -> + | Predicates.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist -> (lexp, strexp, sizeof, offlist) | _ -> assert false @@ -1154,7 +1161,7 @@ let declare_locals_and_ret tenv pdesc (prop_ : Prop.normal Prop.t) = let ptsto = (pvar, Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}, None) in - Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_initial ptsto + Prop.mk_ptsto_lvar tenv Prop.Fld_init Predicates.inst_initial ptsto in let sigma_locals_and_ret () = let pname = Procdesc.get_proc_name pdesc in @@ -1486,13 +1493,14 @@ let rec sym_exec exe_env tenv current_summary instr_ (prop_ : Prop.normal Prop.t let eprop = Prop.expose prop_ in match List.partition_tf - ~f:(function Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false) + ~f:(function + | Predicates.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false ) eprop.Prop.sigma with - | [Sil.Hpointsto (e, se, typ)], sigma' -> + | [Predicates.Hpointsto (e, se, typ)], sigma' -> let sigma'' = let se' = execute_nullify_se se in - Sil.Hpointsto (e, se', typ) :: sigma' + Predicates.Hpointsto (e, se', typ) :: sigma' in let eprop_res = Prop.set eprop ~sigma:sigma'' in ret_old_path [Prop.normalize tenv eprop_res] @@ -1561,8 +1569,11 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call let already_has_abduced_retval p = List.exists ~f:(fun hpred -> - match hpred with Sil.Hpointsto (Exp.Lvar pv, _, _) -> Pvar.equal pv abduced | _ -> false - ) + match hpred with + | Predicates.Hpointsto (Exp.Lvar pv, _, _) -> + Pvar.equal pv abduced + | _ -> + false ) p.Prop.sigma_fp in (* prevent introducing multiple abduced retvals for a single call site in a loop *) @@ -1577,7 +1588,7 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call | Typ.Tptr (typ, _) -> (* for pointer types passed by reference, do abduction directly on the pointer *) let prop', fresh_fp_var = add_to_footprint tenv abduced typ prop in - (prop', Sil.Eexp (fresh_fp_var, Sil.Inone)) + (prop', Predicates.Eexp (fresh_fp_var, Predicates.Inone)) | _ -> L.(die InternalError) "No need for abduction on non-pointer type %s" (Typ.to_string actual_typ) @@ -1585,8 +1596,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call let filtered_sigma = List.map ~f:(function - | Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> - Sil.Hpointsto (lhs, abduced_strexp, typ_exp) + | Predicates.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> + Predicates.Hpointsto (lhs, abduced_strexp, typ_exp) | hpred -> hpred ) prop'.Prop.sigma @@ -1597,7 +1608,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call let prop' = let filtered_sigma = List.filter - ~f:(function Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true) + ~f:(function + | Predicates.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true ) prop.Prop.sigma in Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma) @@ -1605,8 +1617,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call List.fold ~f:(fun p hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced -> - let new_hpred = Sil.Hpointsto (actual, rhs, texp) in + | Predicates.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced -> + let new_hpred = Predicates.Hpointsto (actual, rhs, texp) in Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma)) | _ -> p ) @@ -1638,7 +1650,7 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots let do_exp p (e, _) = let do_attribute q atom = match atom with - | Sil.Apred ((Aresource {ra_res= Rfile} as res), _) -> + | Predicates.Apred ((Aresource {ra_res= Rfile} as res), _) -> Attribute.remove_for_attr tenv q res | _ -> q @@ -1913,7 +1925,8 @@ and sym_exec_wrapper exe_env handle_exn tenv summary proc_cfg instr List.map ~f:(fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed in let ren_sub = - Sil.subst_of_list (List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_primed_normal) + Predicates.subst_of_list + (List.map ~f:(fun (id1, id2) -> (id1, Exp.Var id2)) ids_primed_normal) in let p' = Prop.normalize tenv (Prop.prop_sub ren_sub p) in let fav_normal = List.map ~f:snd ids_primed_normal in diff --git a/infer/src/biabduction/Tabulation.ml b/infer/src/biabduction/Tabulation.ml index db41fbb8a..7a8ecbd10 100644 --- a/infer/src/biabduction/Tabulation.ml +++ b/infer/src/biabduction/Tabulation.ml @@ -15,12 +15,12 @@ open! IStd module L = Logging type splitting = - { sub: Sil.subst - ; frame: Sil.hpred list - ; missing_pi: Sil.atom list - ; missing_sigma: Sil.hpred list - ; frame_fld: Sil.hpred list - ; missing_fld: Sil.hpred list + { sub: Predicates.subst + ; frame: Predicates.hpred list + ; missing_pi: Predicates.atom list + ; missing_sigma: Predicates.hpred list + ; frame_fld: Predicates.hpred list + ; missing_fld: Predicates.hpred list ; frame_typ: (Exp.t * Exp.t) list ; missing_typ: (Exp.t * Exp.t) list } @@ -60,8 +60,8 @@ type invalid_res = type valid_res = { incons_pre_missing: bool (** whether the actual pre is consistent with the missing part *) - ; vr_pi: Sil.atom list (** missing pi *) - ; vr_sigma: Sil.hpred list (** missing sigma *) + ; vr_pi: Predicates.atom list (** missing pi *) + ; vr_sigma: Predicates.hpred list (** missing sigma *) ; vr_cons_res: (Prop.normal Prop.t * Paths.Path.t) list (** consistent result props *) ; vr_incons_res: (Prop.normal Prop.t * Paths.Path.t) list (** inconsistent result props *) } @@ -144,7 +144,7 @@ let spec_rename_vars pname spec = in let ids = Ident.HashQueue.keys fav in let ids' = List.map ~f:(fun i -> (i, Ident.create_fresh Ident.kprimed)) ids in - let ren_sub = Sil.subst_of_list (List.map ~f:(fun (i, i') -> (i, Exp.Var i')) ids') in + let ren_sub = Predicates.subst_of_list (List.map ~f:(fun (i, i') -> (i, Exp.Var i')) ids') in let pre' = BiabductionSummary.Jprop.jprop_sub ren_sub spec.BiabductionSummary.pre in let posts' = List.map ~f:(fun (p, path) -> (Prop.prop_sub ren_sub p, path)) spec.BiabductionSummary.posts @@ -188,22 +188,22 @@ let spec_find_rename trace_call summary : let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ = let hpred_has_only_footprint_vars hpred = - Sil.hpred_free_vars hpred |> Sequence.for_all ~f:Ident.is_footprint + Predicates.hpred_free_vars hpred |> Sequence.for_all ~f:Ident.is_footprint in - let sub = Sil.sub_join sub1 sub2 in + let sub = Predicates.sub_join sub1 sub2 in let sub1_inverse = - let sub1_list = Sil.sub_to_list sub1 in + let sub1_list = Predicates.sub_to_list sub1 in let sub1_list' = List.filter ~f:(function _, Exp.Var _ -> true | _ -> false) sub1_list in let sub1_inverse_list = List.map ~f:(function id, Exp.Var id' -> (id', Exp.Var id) | _ -> assert false) sub1_list' in - Sil.subst_of_list_duplicates sub1_inverse_list + Predicates.subst_of_list_duplicates sub1_inverse_list in let fav_actual_pre = let fav_pre = Prop.free_vars actual_pre |> Ident.hashqueue_of_sequence in let filter id = Int.equal (Ident.get_stamp id) (-1) in (* vars which represent expansions of fields *) - Sil.sub_range sub2 + Predicates.sub_range sub2 |> List.fold_left ~init:fav_pre ~f:(fun res e -> Exp.free_vars e |> Sequence.filter ~f:filter |> Ident.hashqueue_of_sequence ~init:res ) in @@ -221,7 +221,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ Prop.sigma_sub sub missing_fld |> Prop.sigma_free_vars |> Ident.hashqueue_of_sequence in let map_var_to_pre_var_or_fresh id = - match Sil.exp_sub sub1_inverse (Exp.Var id) with + match Predicates.exp_sub sub1_inverse (Exp.Var id) with | Exp.Var id' -> if Ident.HashQueue.mem fav_actual_pre id' || Ident.is_path id' @@ -231,7 +231,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ | _ -> assert false in - let sub_list = Sil.sub_to_list sub in + let sub_list = Predicates.sub_to_list sub in let sub1 = let f id = if Ident.HashQueue.mem fav_actual_pre id then (id, Exp.Var id) @@ -239,10 +239,10 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ else if Ident.HashQueue.mem fav_missing_fld id then (id, Exp.Var id) else if Ident.is_footprint id then (id, Exp.Var id) else - let dom1 = Sil.sub_domain sub1 in - let rng1 = Sil.sub_range sub1 in - let dom2 = Sil.sub_domain sub2 in - let rng2 = Sil.sub_range sub2 in + let dom1 = Predicates.sub_domain sub1 in + let rng1 = Predicates.sub_range sub1 in + let dom2 = Predicates.sub_domain sub2 in + let rng2 = Predicates.sub_range sub2 in let vars_actual_pre = List.map ~f:(fun id -> Exp.Var id) (Ident.HashQueue.keys fav_actual_pre) in @@ -271,41 +271,41 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ Exp.free_vars e |> Ident.hashqueue_of_sequence ~init:fav ) |> Ident.HashQueue.keys in - Sil.subst_of_list (List.map ~f fav_sub_list) + Predicates.subst_of_list (List.map ~f fav_sub_list) in let sub2_list = let f id = (id, Exp.Var (Ident.create_fresh Ident.kfootprint)) in List.map ~f fav_missing_primed in - let sub_list' = List.map ~f:(fun (id, e) -> (id, Sil.exp_sub sub1 e)) sub_list in - let sub' = Sil.subst_of_list (sub2_list @ sub_list') in + let sub_list' = List.map ~f:(fun (id, e) -> (id, Predicates.exp_sub sub1 e)) sub_list in + let sub' = Predicates.subst_of_list (sub2_list @ sub_list') in (* normalize everything w.r.t sub' *) let norm_missing_pi = Prop.pi_sub sub' missing_pi in let norm_missing_sigma = Prop.sigma_sub sub' missing_sigma in let norm_frame_fld = Prop.sigma_sub sub' frame_fld in let norm_frame_typ = - List.map ~f:(fun (e, te) -> (Sil.exp_sub sub' e, Sil.exp_sub sub' te)) frame_typ + List.map ~f:(fun (e, te) -> (Predicates.exp_sub sub' e, Predicates.exp_sub sub' te)) frame_typ in let norm_missing_typ = - List.map ~f:(fun (e, te) -> (Sil.exp_sub sub' e, Sil.exp_sub sub' te)) missing_typ + List.map ~f:(fun (e, te) -> (Predicates.exp_sub sub' e, Predicates.exp_sub sub' te)) missing_typ in let norm_missing_fld = let sigma = Prop.sigma_sub sub' missing_fld in let filter hpred = if not (hpred_has_only_footprint_vars hpred) then ( L.d_warning "Missing fields hpred has non-footprint vars: " ; - Sil.d_hpred hpred ; + Predicates.d_hpred hpred ; L.d_ln () ; false ) else match hpred with - | Sil.Hpointsto (Exp.Var _, _, _) -> + | Predicates.Hpointsto (Exp.Var _, _, _) -> true - | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + | Predicates.Hpointsto (Exp.Lvar pvar, _, _) -> Pvar.is_global pvar | _ -> L.d_warning "Missing fields in complex pred: " ; - Sil.d_hpred hpred ; + Predicates.d_hpred hpred ; L.d_ln () ; false in @@ -325,7 +325,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ (** Check whether an inst represents a dereference without null check, and return the line number and path position *) let find_dereference_without_null_check_in_inst = function - | Sil.Iupdate (Some true, _, n, pos) | Sil.Irearrange (Some true, _, n, pos) -> + | Predicates.Iupdate (Some true, _, n, pos) | Predicates.Irearrange (Some true, _, n, pos) -> Some (n, pos) | _ -> None @@ -334,13 +334,13 @@ let find_dereference_without_null_check_in_inst = function (** Check whether a sexp contains a dereference without null check, and return the line number and path position *) let rec find_dereference_without_null_check_in_sexp = function - | Sil.Eexp (_, inst) -> + | Predicates.Eexp (_, inst) -> find_dereference_without_null_check_in_inst inst - | Sil.Estruct (fsel, inst) -> + | Predicates.Estruct (fsel, inst) -> let res = find_dereference_without_null_check_in_inst inst in if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd fsel) else res - | Sil.Earray (_, esel, inst) -> + | Predicates.Earray (_, esel, inst) -> let res = find_dereference_without_null_check_in_inst inst in if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd esel) else res @@ -361,7 +361,7 @@ and find_dereference_without_null_check_in_sexp_list = function In case of dereference error, return [Some(deref_error, description)], otherwise [None] *) let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre formal_params = let check_dereference e sexp = - let e_sub = Sil.exp_sub sub e in + let e_sub = Predicates.exp_sub sub e in let desc use_buckets deref_str = let error_desc = Errdesc.explain_dereference_as_caller_expression caller_pname tenv ~use_buckets deref_str @@ -412,7 +412,7 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo None ) in let check_hpred = function - | Sil.Hpointsto (lexp, se, _) -> + | Predicates.Hpointsto (lexp, se, _) -> check_dereference (Exp.root_of_lexp lexp) se | _ -> None @@ -441,9 +441,9 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo Some deref_err ) -let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list = - let map_inst inst = Sil.inst_new_loc loc inst in - let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in +let post_process_sigma tenv (sigma : Predicates.hpred list) loc : Predicates.hpred list = + let map_inst inst = Predicates.inst_new_loc loc inst in + let do_hpred (_, _, hpred) = Predicates.hpred_instmap map_inst hpred in (* update the location of instrumentations *) List.map ~f:(fun hpred -> do_hpred (Prover.expand_hpred_pointer tenv false hpred)) sigma @@ -452,7 +452,7 @@ let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list = let check_path_errors_in_post tenv caller_pname post post_path = let check_attr atom = match atom with - | Sil.Apred (Adiv0 path_pos, [e]) -> + | Predicates.Apred (Adiv0 path_pos, [e]) -> if Prover.check_zero tenv e then ( let desc = Errdesc.explain_divide_by_zero tenv e (State.get_node_exn ()) (State.get_loc_exn ()) @@ -485,14 +485,14 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre false in let atom_update_alloc_attribute = function - | Sil.Apred (Aresource ra, [e]) + | Predicates.Apred (Aresource ra, [e]) when not ( PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease && actual_pre_has_freed_attribute e ) -> (* unless it was already freed before the call *) let vpath, _ = Errdesc.vpath_find tenv post e in let ra' = {ra with ra_pname= callee_pname; ra_loc= loc; ra_vpath= vpath} in - Sil.Apred (Aresource ra', [e]) + Predicates.Apred (Aresource ra', [e]) | a -> a in @@ -506,24 +506,24 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre let hpred_lhs_compare hpred1 hpred2 = match (hpred1, hpred2) with - | Sil.Hpointsto (e1, _, _), Sil.Hpointsto (e2, _, _) -> + | Predicates.Hpointsto (e1, _, _), Predicates.Hpointsto (e2, _, _) -> Exp.compare e1 e2 - | Sil.Hpointsto _, _ -> + | Predicates.Hpointsto _, _ -> -1 - | _, Sil.Hpointsto _ -> + | _, Predicates.Hpointsto _ -> 1 | hpred1, hpred2 -> - Sil.compare_hpred hpred1 hpred2 + Predicates.compare_hpred hpred1 hpred2 (** set the inst everywhere in a sexp *) let rec sexp_set_inst inst = function - | Sil.Eexp (e, _) -> - Sil.Eexp (e, inst) - | Sil.Estruct (fsel, _) -> - Sil.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst) - | Sil.Earray (len, esel, _) -> - Sil.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst) + | Predicates.Eexp (e, _) -> + Predicates.Eexp (e, inst) + | Predicates.Estruct (fsel, _) -> + Predicates.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst) + | Predicates.Earray (len, esel, _) -> + Predicates.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst) let rec fsel_star_fld fsel1 fsel2 = @@ -551,7 +551,7 @@ and esel_star_fld esel1 esel2 = match (esel1, esel2) with | [], esel2 -> (* don't know whether element is read or written in fun call with array *) - List.map ~f:(fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2 + List.map ~f:(fun (e, se) -> (e, sexp_set_inst Predicates.Inone se)) esel2 | esel1, [] -> esel1 | (e1, se1) :: esel1', (e2, se2) :: esel2' -> ( @@ -561,26 +561,26 @@ and esel_star_fld esel1 esel2 = | n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2 | _ -> - let se2' = sexp_set_inst Sil.Inone se2 in + let se2' = sexp_set_inst Predicates.Inone se2 in (* don't know whether element is read or written in fun call with array *) (e2, se2') :: esel_star_fld esel1 esel2' ) -and sexp_star_fld se1 se2 : Sil.strexp = - (* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *) +and sexp_star_fld se1 se2 : Predicates.strexp = + (* L.d_str "sexp_star_fld "; Predicates.d_sexp se1; L.d_str " "; Predicates.d_sexp se2; L.d_ln (); *) match (se1, se2) with - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) -> - Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2) - | Sil.Earray (len1, esel1, _), Sil.Earray (_, esel2, inst2) -> - Sil.Earray (len1, esel_star_fld esel1 esel2, inst2) - | Sil.Eexp (_, inst1), Sil.Earray (len2, esel2, _) -> + | Predicates.Estruct (fsel1, _), Predicates.Estruct (fsel2, inst2) -> + Predicates.Estruct (fsel_star_fld fsel1 fsel2, inst2) + | Predicates.Earray (len1, esel1, _), Predicates.Earray (_, esel2, inst2) -> + Predicates.Earray (len1, esel_star_fld esel1 esel2, inst2) + | Predicates.Eexp (_, inst1), Predicates.Earray (len2, esel2, _) -> let esel1 = [(Exp.zero, se1)] in - Sil.Earray (len2, esel_star_fld esel1 esel2, inst1) + Predicates.Earray (len2, esel_star_fld esel1 esel2, inst1) | _ -> L.d_str "cannot star " ; - Sil.d_sexp se1 ; + Predicates.d_sexp se1 ; L.d_str " and " ; - Sil.d_sexp se2 ; + Predicates.d_sexp se2 ; L.d_ln () ; assert false @@ -619,22 +619,23 @@ let texp_star tenv texp1 texp2 = texp1 -let hpred_star_fld tenv (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred = +let hpred_star_fld tenv (hpred1 : Predicates.hpred) (hpred2 : Predicates.hpred) : Predicates.hpred = match (hpred1, hpred2) with - | Sil.Hpointsto (e1, se1, t1), Sil.Hpointsto (_, se2, t2) -> + | Hpointsto (e1, se1, t1), Hpointsto (_, se2, t2) -> (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) - Sil.Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2) + Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2) | _ -> assert false (** Implementation of [*] for the field-splitting model *) -let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list = +let sigma_star_fld tenv (sigma1 : Predicates.hpred list) (sigma2 : Predicates.hpred list) : + Predicates.hpred list = let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in let sigma2 = List.stable_sort ~compare:hpred_lhs_compare sigma2 in (* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *) - let rec star sg1 sg2 : Sil.hpred list = + let rec star sg1 sg2 : Predicates.hpred list = match (sg1, sg2) with | [], _ -> [] @@ -660,19 +661,20 @@ let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Si let hpred_typing_lhs_compare hpred1 (e2, _) = - match hpred1 with Sil.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1 + match hpred1 with Predicates.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1 -let hpred_star_typing (hpred1 : Sil.hpred) (_, te2) : Sil.hpred = - match hpred1 with Sil.Hpointsto (e1, se1, _) -> Sil.Hpointsto (e1, se1, te2) | _ -> assert false +let hpred_star_typing (hpred1 : Predicates.hpred) (_, te2) : Predicates.hpred = + match hpred1 with Hpointsto (e1, se1, _) -> Hpointsto (e1, se1, te2) | _ -> assert false (** Implementation of [*] between predicates and typings *) -let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Exp.t * Exp.t) list) : Sil.hpred list = +let sigma_star_typ (sigma1 : Predicates.hpred list) (typings2 : (Exp.t * Exp.t) list) : + Predicates.hpred list = let typing_lhs_compare (e1, _) (e2, _) = Exp.compare e1 e2 in let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in let typings2 = List.stable_sort ~compare:typing_lhs_compare typings2 in - let rec star sg1 typ2 : Sil.hpred list = + let rec star sg1 typ2 : Predicates.hpred list = match (sg1, typ2) with | [], _ -> [] @@ -715,10 +717,11 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop : 'a Prop.t) pi_new sig | [] -> current_pi | a :: new_pi' -> - if Sil.atom_free_vars a |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id)) then ( + if Predicates.atom_free_vars a |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id)) + then ( L.d_warning "dropping atom with non-footprint variable" ; L.d_ln () ; - Sil.d_atom a ; + Predicates.d_atom a ; L.d_ln () ; extend_pi current_pi new_pi' ) else extend_pi (a :: current_pi) new_pi' @@ -770,7 +773,7 @@ let exp_is_exn = function Exp.Exn _ -> true | _ -> false let prop_is_exn pname prop = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let is_exn = function - | Sil.Hpointsto (e1, Sil.Eexp (e2, _), _) when Exp.equal e1 ret_pvar -> + | Predicates.Hpointsto (e1, Predicates.Eexp (e2, _), _) when Exp.equal e1 ret_pvar -> exp_is_exn e2 | _ -> false @@ -784,7 +787,7 @@ let prop_get_exn_name pname prop = let rec search_exn e = function | [] -> None - | Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}}) :: _ when Exp.equal e1 e -> + | Predicates.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}}) :: _ when Exp.equal e1 e -> Some name | _ :: tl -> search_exn e tl @@ -792,7 +795,7 @@ let prop_get_exn_name pname prop = let rec find_exn_name hpreds = function | [] -> None - | Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _) :: _ when Exp.equal e1 ret_pvar -> + | Predicates.Hpointsto (e1, Eexp (Exp.Exn e2, _), _) :: _ when Exp.equal e1 ret_pvar -> search_exn e2 hpreds | _ :: tl -> find_exn_name hpreds tl @@ -806,8 +809,8 @@ let lookup_custom_errors prop = let rec search_error = function | [] -> None - | Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _ - when Pvar.equal var Sil.custom_error -> + | Predicates.Hpointsto (Exp.Lvar var, Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _ + when Pvar.equal var Predicates.custom_error -> Some error_str | _ :: tl -> search_error tl @@ -819,8 +822,8 @@ let lookup_custom_errors prop = let prop_set_exn tenv pname prop se_exn = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let map_hpred = function - | Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar -> - Sil.Hpointsto (e, se_exn, t) + | Predicates.Hpointsto (e, _, t) when Exp.equal e ret_pvar -> + Predicates.Hpointsto (e, se_exn, t) | hpred -> hpred in @@ -847,7 +850,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat if !BiabductionConfig.footprint && List.is_empty posts then (* in case of divergence, produce a prop *) (* with updated footprint and inconsistent current *) - [(Prop.set Prop.prop_emp ~pi:[Sil.Aneq (Exp.zero, Exp.zero)], path_pre)] + [(Prop.set Prop.prop_emp ~pi:[Predicates.Aneq (Exp.zero, Exp.zero)], path_pre)] else List.map ~f:(fun (p, path_post) -> @@ -896,7 +899,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat let handle_null_case_analysis sigma = let id_assigned_to_null id = let filter = function - | Sil.Aeq (Exp.Var id', Exp.Const (Const.Cint i)) -> + | Predicates.Aeq (Exp.Var id', Exp.Const (Const.Cint i)) -> Ident.equal id id' && IntLit.isnull i | _ -> false @@ -906,12 +909,12 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat let f (e, inst_opt) = match (e, inst_opt) with | Exp.Var id, Some inst when id_assigned_to_null id -> - let inst' = Sil.inst_set_null_case_flag inst in + let inst' = Predicates.inst_set_null_case_flag inst in (e, Some inst') | _ -> (e, inst_opt) in - Sil.hpred_list_expmap f sigma + Predicates.hpred_list_expmap f sigma in let post_p2 = let post_p1_sigma = post_p1.Prop.sigma in @@ -929,7 +932,7 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat post_p2 | Some iter -> ( let filter = function - | Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar -> + | Predicates.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar -> Some () | _ -> None @@ -939,14 +942,14 @@ let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre pat post_p2 | Some iter' -> ( match fst (Prop.prop_iter_current tenv iter') with - | Sil.Hpointsto (_, Sil.Eexp (e', inst), _) when exp_is_exn e' -> + | Predicates.Hpointsto (_, Eexp (e', inst), _) when exp_is_exn e' -> (* resuls is an exception: set in caller *) let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in - prop_set_exn tenv caller_pname p (Sil.Eexp (e', inst)) - | Sil.Hpointsto (_, Sil.Eexp (e', _), _) -> + prop_set_exn tenv caller_pname p (Eexp (e', inst)) + | Predicates.Hpointsto (_, Eexp (e', _), _) -> let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in Prop.conjoin_eq tenv e' (Exp.Var ret_id) p - | Sil.Hpointsto _ -> + | Predicates.Hpointsto _ -> (* returning nothing or unexpected sexp, turning into nondet *) Prop.prop_iter_remove_curr_then_to_prop tenv iter' | _ -> @@ -998,7 +1001,7 @@ let mk_actual_precondition tenv prop actual_params formal_params = in let mk_instantiation (formal_var, (actual_e, actual_t)) = Prop.mk_ptsto tenv (Exp.Lvar formal_var) - (Sil.Eexp (actual_e, Sil.inst_actual_precondition)) + (Eexp (actual_e, Predicates.inst_actual_precondition)) (Exp.Sizeof {typ= actual_t; nbytes= None; dynamic_length= None; subtype= Subtype.exact}) in let instantiated_formals = List.map ~f:mk_instantiation formals_actuals in @@ -1015,7 +1018,8 @@ let mk_posts tenv prop callee_pname posts = let last_call_ret_non_null = List.exists ~f:(function - | Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname -> + | Predicates.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname + -> Prover.check_disequal tenv prop exp Exp.zero | _ -> false ) @@ -1025,7 +1029,7 @@ let mk_posts tenv prop callee_pname posts = let returns_null prop = List.exists ~f:(function - | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar -> + | Predicates.Hpointsto (Exp.Lvar pvar, Eexp (e, _), _) when Pvar.is_return pvar -> Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero | _ -> false ) @@ -1089,8 +1093,8 @@ let missing_sigma_need_adding_to_tenv tenv hpreds = in let missing_hpred_need_adding_to_tenv hpred = match hpred with - | Sil.Hpointsto (_, Sil.Estruct (missing_fields, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) - -> ( + | Predicates.Hpointsto + (_, Estruct (missing_fields, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) -> ( match Tenv.lookup tenv name with | Some struc -> List.exists ~f:(field_is_missing struc) missing_fields @@ -1123,7 +1127,8 @@ let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hp | Some callee_tenv -> let add_field_in_hpred hpred = match hpred with - | Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) -> ( + | Predicates.Hpointsto (_, Estruct (_, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) + -> ( match Tenv.lookup callee_tenv name with | Some {fields} -> List.iter ~f:(fun field -> Tenv.add_field caller_tenv name field) fields @@ -1172,7 +1177,7 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop , missing_typ ) -> ( (* check if a missing_fld hpred is from a dyn language (ObjC) *) let hpred_missing_objc_class = function - | Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) -> + | Predicates.Hpointsto (_, Estruct (_, _), Exp.Sizeof {typ}) -> Typ.is_objc_class typ | _ -> false @@ -1250,7 +1255,7 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop let remove_constant_string_class tenv prop = let filter = function - | Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) -> + | Predicates.Hpointsto (Const (Cstr _ | Cclass _), _, _) -> false | _ -> true @@ -1276,7 +1281,8 @@ let quantify_path_idents_remove_constant_strings tenv (prop : Prop.normal Prop.t (** Strengthen the footprint by adding pure facts from the current part *) let prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t = let is_footprint_atom_not_attribute a = - (not (Attribute.is_pred a)) && Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint + (not (Attribute.is_pred a)) + && Predicates.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint in let pure = Prop.get_pure p in let new_footprint_atoms = List.filter ~f:is_footprint_atom_not_attribute pure in @@ -1284,7 +1290,8 @@ let prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t = else (* add pure fact to footprint *) let filtered_pi_fp = - List.filter (p.Prop.pi_fp @ new_footprint_atoms) ~f:(fun a -> not (Sil.atom_has_local_addr a)) + List.filter (p.Prop.pi_fp @ new_footprint_atoms) ~f:(fun a -> + not (Predicates.atom_has_local_addr a) ) in Prop.normalize tenv (Prop.set p ~pi_fp:filtered_pi_fp) diff --git a/infer/src/biabduction/Tabulation.mli b/infer/src/biabduction/Tabulation.mli index a059ae8cd..6fc01134e 100644 --- a/infer/src/biabduction/Tabulation.mli +++ b/infer/src/biabduction/Tabulation.mli @@ -34,7 +34,8 @@ val check_attr_dealloc_mismatch : PredSymb.t -> PredSymb.t -> unit (** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *) -val find_dereference_without_null_check_in_sexp : Sil.strexp -> (int * PredSymb.path_pos) option +val find_dereference_without_null_check_in_sexp : + Predicates.strexp -> (int * PredSymb.path_pos) option (** Check whether a sexp contains a dereference without null check, and return the line number and path position *) diff --git a/infer/src/biabduction/interproc.ml b/infer/src/biabduction/interproc.ml index e7a850162..3f59e8f76 100644 --- a/infer/src/biabduction/interproc.ml +++ b/infer/src/biabduction/interproc.ml @@ -292,8 +292,8 @@ let propagate_nodes_divergence tenv (proc_cfg : ProcCfg.Exceptional.t) (pset : P let prop_incons = let mk_incons prop = let p_abs = Abs.abstract pname tenv prop in - let p_zero = Prop.set p_abs ~sub:Sil.sub_empty ~sigma:[] in - Prop.normalize tenv (Prop.set p_zero ~pi:[Sil.Aneq (Exp.zero, Exp.zero)]) + let p_zero = Prop.set p_abs ~sub:Predicates.sub_empty ~sigma:[] in + Prop.normalize tenv (Prop.set p_zero ~pi:[Predicates.Aneq (Exp.zero, Exp.zero)]) in Paths.PathSet.map mk_incons diverging_states in @@ -581,7 +581,7 @@ let extract_specs tenv pdesc pathset : Prop.normal BiabductionSummary.spec list |> Ident.HashQueue.keys in let sub_list = List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.knormal))) fav in - Sil.subst_of_list sub_list + Predicates.subst_of_list sub_list in let pre_post_visited_list = let pplist = Paths.PathSet.elements pathset in @@ -679,8 +679,8 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * BiabductionSumma let create_seed_vars sigma = let hpred_add_seed sigma = function - | Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) -> - Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma + | Predicates.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) -> + Predicates.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma | _ -> sigma in @@ -700,7 +700,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr | Java -> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} in - Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_formal (pv, texp, None) + Prop.mk_ptsto_lvar tenv Prop.Fld_init Predicates.inst_formal (pv, texp, None) in List.map ~f:do_formal new_formals in @@ -723,7 +723,9 @@ let initial_prop tenv (curr_f : Procdesc.t) (prop : 'a Prop.t) ~add_formals : Pr (* no new formals added *) in let prop1 = - Prop.prop_reset_inst (fun inst_old -> Sil.update_inst inst_old Sil.inst_formal) prop + Prop.prop_reset_inst + (fun inst_old -> Predicates.update_inst inst_old Predicates.inst_formal) + prop in let prop2 = prop_init_formals_seed tenv new_formals prop1 in Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2) @@ -740,7 +742,7 @@ let initial_prop_from_pre tenv curr_f pre = let sub_list = List.map ~f:(fun id -> (id, Exp.Var (Ident.create_fresh Ident.kfootprint))) vars in - let sub = Sil.subst_of_list sub_list in + let sub = Predicates.subst_of_list sub_list in let pre2 = Prop.prop_sub sub pre in let pre3 = Prop.set pre2 ~pi_fp:(Prop.get_pure pre2) ~sigma_fp:pre2.Prop.sigma in initial_prop tenv curr_f pre3 ~add_formals:false @@ -936,14 +938,14 @@ let custom_error_preconditions summary = (* Remove the constrain of the form this != null which is true for all Java virtual calls *) let remove_this_not_null tenv prop = let collect_hpred (var_option, hpreds) = function - | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _) + | Predicates.Hpointsto (Exp.Lvar pvar, Eexp (Exp.Var var, _), _) when Language.curr_language_is Java && Pvar.is_this pvar -> (Some var, hpreds) | hpred -> (var_option, hpred :: hpreds) in let collect_atom var atoms = function - | Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null -> + | Predicates.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null -> atoms | a -> a :: atoms @@ -1175,7 +1177,7 @@ let analyze_procedure_aux summary exe_env tenv : Summary.t = let summary_compact = match summaryre.Summary.payloads.biabduction with | Some BiabductionSummary.({preposts} as biabduction) when Config.save_compact_summaries -> - let sharing_env = Sil.create_sharing_env () in + let sharing_env = Predicates.create_sharing_env () in let compact_preposts = List.map ~f:(BiabductionSummary.NormSpec.compact sharing_env) preposts in diff --git a/infer/src/bufferoverrun/bufferOverrunModels.ml b/infer/src/bufferoverrun/bufferOverrunModels.ml index fb128d582..2056b069f 100644 --- a/infer/src/bufferoverrun/bufferOverrunModels.ml +++ b/infer/src/bufferoverrun/bufferOverrunModels.ml @@ -114,7 +114,7 @@ let fgets str_exp num_exp = let malloc ~can_be_zero size_exp = let exec ({pname; node_hash; location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem = - let size_exp = Prop.exp_normalize_noabs tenv Sil.sub_empty size_exp in + let size_exp = Prop.exp_normalize_noabs tenv Predicates.sub_empty size_exp in let typ, stride, length0, dyn_length = get_malloc_info size_exp in let length = Sem.eval integer_type_widths length0 mem in let traces = Trace.(Set.add_elem location ArrayDeclaration) (Dom.Val.get_traces length) in @@ -263,7 +263,7 @@ let strcat dest_exp src_exp = let realloc src_exp size_exp = let exec ({location; tenv; integer_type_widths} as model_env) ~ret:(id, _) mem = - let size_exp = Prop.exp_normalize_noabs tenv Sil.sub_empty size_exp in + let size_exp = Prop.exp_normalize_noabs tenv Predicates.sub_empty size_exp in let typ, _, length0, dyn_length = get_malloc_info size_exp in let length = Sem.eval integer_type_widths length0 mem in let v = Sem.eval integer_type_widths src_exp mem |> Dom.Val.set_array_length location ~length in diff --git a/infer/src/topl/Topl.ml b/infer/src/topl/Topl.ml index 5a8ff780a..4cfc9ec16 100644 --- a/infer/src/topl/Topl.ml +++ b/infer/src/topl/Topl.ml @@ -161,16 +161,16 @@ let instrument tenv procdesc = + one cannot do boolean-conjunction on symbolic heaps; and + the prover fails to see that 0!=o.f * o|-f->0 is inconsistent *) let lookup_static_var env (var : Exp.t) (prop : 'a Prop.t) : Exp.t option = - let from_strexp = function Sil.Eexp (e, _) -> Some e | _ -> None in + let from_strexp = function Predicates.Eexp (e, _) -> Some e | _ -> None in let get_field field (f, e) = if Typ.Fieldname.equal field f then from_strexp e else None in let get_strexp field = function - | Sil.Estruct (fs, _inst) -> + | Predicates.Estruct (fs, _inst) -> List.find_map ~f:(get_field field) fs | _ -> None in let get_hpred obj field = function - | Sil.Hpointsto (obj', se, _typ) when Exp.equal obj obj' -> + | Predicates.Hpointsto (obj', se, _typ) when Exp.equal obj obj' -> get_strexp field se | _ -> None diff --git a/infer/src/topl/ToplMonitor.ml b/infer/src/topl/ToplMonitor.ml index 4088d0921..f57f3f721 100644 --- a/infer/src/topl/ToplMonitor.ml +++ b/infer/src/topl/ToplMonitor.ml @@ -120,7 +120,7 @@ let pure_exp e : Exp.t * Sil.instr list = let es = List.dedup_and_sort ~compare:Exp.compare es in let pairs = List.map ~f:(fun e -> (e, Ident.create_fresh Ident.knormal)) es in let subst = List.map ~f:(function e, id -> (e, Exp.Var id)) pairs in - let e' = Sil.exp_replace_exp subst e in + let e' = Predicates.exp_replace_exp subst e in let mk_load (e, id) = Sil.Load {id; e; root_typ= ToplUtils.any_type; typ= ToplUtils.any_type; loc= sourcefile_location ()}