From 12444933d1f7107dc73c4a2f30107e75c85c97ee Mon Sep 17 00:00:00 2001 From: Vesal Vojdani Date: Fri, 26 May 2023 10:58:09 +0300 Subject: [PATCH 01/71] Add initial attempt to rely on ptranal for EvalFunvar queries --- src/analyses/ptranalEvalFunvar.ml | 59 +++++++++++++++++++ src/framework/constraints.ml | 1 + .../regression/33-constants/05-fun_ptranal.c | 14 +++++ 3 files changed, 74 insertions(+) create mode 100644 src/analyses/ptranalEvalFunvar.ml create mode 100644 tests/regression/33-constants/05-fun_ptranal.c diff --git a/src/analyses/ptranalEvalFunvar.ml b/src/analyses/ptranalEvalFunvar.ml new file mode 100644 index 0000000000..3b3d04ed6d --- /dev/null +++ b/src/analyses/ptranalEvalFunvar.ml @@ -0,0 +1,59 @@ +(** Wrapper analysis to answer EvalFunvar query using Cil's pointer analysis. *) + +open GoblintCil +open Analyses + +module Spec = +struct + include Analyses.DefaultSpec + + let name () = "ptranal" + + module D = Lattice.Unit + module C = Lattice.Unit + + (* transfer functions *) + let assign ctx (lval:lval) (rval:exp) : D.t = + ctx.local + + let branch ctx (exp:exp) (tv:bool) : D.t = + ctx.local + + let body ctx (f:fundec) : D.t = + ctx.local + + let return ctx (exp:exp option) (f:fundec) : D.t = + ctx.local + + let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [ctx.local, ctx.local] + + let combine_env ctx lval fexp f args fc au f_ask = + au + + let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + ctx.local + + let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + ctx.local + + let query ctx (type a) (q: a Queries.t): a Queries.result = + match q with + | Queries.EvalFunvar (Lval (Mem e, _)) -> + let funs = Ptranal.resolve_exp e in + List.fold_left (fun xs f -> Queries.LS.add (f, `NoOffset) xs) (Queries.LS.empty ()) funs + | _ -> Queries.Result.top q + + let startstate v = D.bot () + let threadenter ctx lval f args = [D.top ()] + let threadspawn ctx lval f args fctx = ctx.local + let exitstate v = D.top () + + let init _: unit = + Ptranal.analyze_file !Cilfacade.current_file; + Ptranal.compute_results false + +end + +let _ = + MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index f608698521..d8fcdcd09a 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -754,6 +754,7 @@ struct [v] | _ -> (* Depends on base for query. *) + M.debug ~category:Program "Dynamic function call through %a" d_exp e; let ls = ctx.ask (Queries.EvalFunvar e) in Queries.LS.fold (fun ((x,_)) xs -> x::xs) ls [] in diff --git a/tests/regression/33-constants/05-fun_ptranal.c b/tests/regression/33-constants/05-fun_ptranal.c new file mode 100644 index 0000000000..5ebaf24e22 --- /dev/null +++ b/tests/regression/33-constants/05-fun_ptranal.c @@ -0,0 +1,14 @@ +//PARAM: --set ana.activated '["constants", "ptranal"]' +// intentional explicit ana.activated to do tutorial in isolation +int f(int a, int b){ + int d = 3; + int z = a + d; + return z; +} + +int main(){ + int d = 0; + int (*fp)(int,int) = &f; + d = fp(2, 3); + return 0; +} From 993a0455cbdde81e5eaa41d3a1890f09ac9258b6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 2 Nov 2023 12:25:38 +0200 Subject: [PATCH 02/71] Extract both branches dead test from concrat/Remotery --- tests/regression/00-sanity/41-both_branches-2.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 tests/regression/00-sanity/41-both_branches-2.c diff --git a/tests/regression/00-sanity/41-both_branches-2.c b/tests/regression/00-sanity/41-both_branches-2.c new file mode 100644 index 0000000000..4bfd339b13 --- /dev/null +++ b/tests/regression/00-sanity/41-both_branches-2.c @@ -0,0 +1,17 @@ +// PARAM: --disable sem.unknown_function.invalidate.globals +#include +struct S { + int *f[1]; +}; + +int main() { + struct S* s; + s = magic(); + + int *p = s->f[0]; + if (p) + __goblint_check(1); // reachable + else + __goblint_check(1); // reachable + return 0; +} From 4ea07567add44655631166371103c1512a32b678 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 2 Nov 2023 12:37:03 +0200 Subject: [PATCH 03/71] Fix both branches dead from bot address in array Fix from https://github.com/goblint/analyzer/issues/1188#issuecomment-1735060169. --- src/cdomains/valueDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index cba4b04c18..003a65a49e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -201,7 +201,7 @@ struct let typAttr = typeAttrs ai in let can_recover_from_top = ArrayDomain.can_recover_from_top (ArrayDomain.get_domain ~varAttr ~typAttr) in let len = array_length_idx (IndexDomain.top ()) length in - Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else (bot_value ai))) + Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else Bot)) | TNamed ({ttype=t; _}, _) -> top_value ~varAttr t | _ -> Top From a568620dd4f45361863f208f7c8be85c1e657bce Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:10:24 +0200 Subject: [PATCH 04/71] Remove gs from set signature in base --- src/analyses/base.ml | 70 ++++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 912d1f3bff..f24e9419d9 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1417,7 +1417,7 @@ struct (** [set st addr val] returns a state where [addr] is set to [val] * it is always ok to put None for lval_raw and rval_raw, this amounts to not using/maintaining * precise information about arrays. *) - let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (gs:glob_fun) (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = + let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = let update_variable x t y z = if M.tracing then M.tracel "set" ~var:x.vname "update_variable: start '%s' '%a'\nto\n%a\n\n" x.vname VD.pretty y CPA.pretty z; let r = update_variable x t y z in (* refers to defintion that is outside of set *) @@ -1476,7 +1476,7 @@ struct * side-effects here, but the code still distinguishes these cases. *) if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then begin if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: update a global var '%s' ...\n" x.vname; - let priv_getg = priv_getg gs in + let priv_getg = priv_getg ctx.global in (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) @@ -1590,7 +1590,7 @@ struct let set_many ~ctx a (gs:glob_fun) (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = - set ~ctx a gs acc lval typ value + set ~ctx a acc lval typ value in (* And fold over the list starting from the store turned wstore: *) List.fold_left f st lval_value_list @@ -1640,7 +1640,7 @@ struct let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true gs st lval lval_type ?lval_raw value + let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -1660,8 +1660,8 @@ struct let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with - | Top -> set ~ctx ask gs st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw - | v -> set ~ctx ask gs st adr lval_t v ?lval_raw ?rval_raw + | Top -> set ~ctx ask st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw + | v -> set ~ctx ask st adr lval_t v ?lval_raw ?rval_raw (************************************************************************** @@ -1834,7 +1834,7 @@ struct | ret -> ret in let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in - let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) ctx.global nst (return_var ()) t_override rv in + let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1851,7 +1851,7 @@ struct let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in - set ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval v.vtype new_value + set ~ctx (Analyses.ask_of_ctx ctx) ctx.local lval v.vtype new_value (************************************************************************** * Function calls @@ -2173,7 +2173,7 @@ struct else VD.top_value (unrollType dest_typ) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value in + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value in (* for string functions *) let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) @@ -2219,15 +2219,15 @@ struct let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (f s1_a s2_a) else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (f s1_a s2_a) else - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) | _ -> (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) let _ = AD.string_writing_defined s1_a in - set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else @@ -2235,11 +2235,11 @@ struct | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with - | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in - set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) | Bot, Array array_s2 -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in @@ -2248,7 +2248,7 @@ struct try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size with Failure _ -> ID.top_of ptrdiff_ik in let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array empty_array array_s2) | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in @@ -2259,19 +2259,19 @@ struct let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array empty_array array_s2) | _, Array array_s2 when CilType.Typ.equal s1_typ charPtrType -> (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) if op_addr = None then (* triggers warning, function only evaluated for side-effects *) let _ = AD.string_writing_defined s1_a in - set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) else let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) | _ -> - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in let st = match desc.special args, f.vname with @@ -2286,13 +2286,13 @@ struct | _ -> VD.top_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | Bzero { dest; count; }, _ -> (* TODO: share something with memset special case? *) (* TODO: check count *) let dest_a, dest_typ = addr_type_of_exp dest in let value = VD.zero_init_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | Memcpy { dest = dst; src; n; }, _ -> (* TODO: use n *) memory_copying dst src (Some n) | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) @@ -2315,7 +2315,7 @@ struct | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> @@ -2374,10 +2374,10 @@ struct match ID.to_int x with | Some z -> if M.tracing then M.tracel "attr" "setting\n"; - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) - | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) + | None -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end - | _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + | _ -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end | Identity e, _ -> begin match lv with @@ -2452,7 +2452,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) gs st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2470,7 +2470,7 @@ struct | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st ret_a (Cilfacade.typeOf ret_var) v + set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] end | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] @@ -2573,14 +2573,14 @@ struct let st' = match eval_rv ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in - let r = set ~ctx ask gs st jmp_buf (Cilfacade.typeOf env) value in + let r = set ~ctx ask st jmp_buf (Cilfacade.typeOf env) value in if M.tracing then M.tracel "setjmp" "setting setjmp %a on %a -> %a\n" d_exp env D.pretty st D.pretty r; r | _ -> failwith "problem?!" in begin match lv with | Some lv -> - set ~ctx ask gs st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx ask st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2603,12 +2603,12 @@ struct in let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in - set ~ctx ~t_override:t ask ctx.global ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) + set ~ctx ~t_override:t ask ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2843,7 +2843,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false gs st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = @@ -2887,7 +2887,7 @@ struct WideningTokens.with_side_tokens (WideningTokens.TS.of_list uuids) (fun () -> CPA.fold (fun x v acc -> let addr: AD.t = AD.of_mval (x, `NoOffset) in - set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false ctx.global acc addr x.vtype v + set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false acc addr x.vtype v ) e_d.cpa ctx.local ) in @@ -2911,7 +2911,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx (Analyses.ask_of_ctx ctx) ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> From fcb52df193a0ec4bca6bcf0c668f47d16daf7114 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:15:24 +0200 Subject: [PATCH 05/71] Remove gs from set_many signature in base --- src/analyses/base.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f24e9419d9..209dc21279 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1587,7 +1587,7 @@ struct (* if M.tracing then M.tracel "set" ~var:firstvar "set got an exception '%s'\n" x; *) M.info ~category:Unsound "Assignment to unknown address, assuming no write happened."; st - let set_many ~ctx a (gs:glob_fun) (st: store) lval_value_list: store = + let set_many ~ctx a (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = set ~ctx a acc lval typ value @@ -1809,7 +1809,7 @@ struct let init_var v = (AD.of_var v, v.vtype, VD.init_value ~varAttr:v.vattr v.vtype) in (* Apply it to all the locals and then assign them all *) let inits = List.map init_var f.slocals in - set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local inits + set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.local inits let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then @@ -1903,7 +1903,7 @@ struct let vs = List.map (Tuple3.third) invalids' in M.tracel "invalidate" "Setting addresses [%a] to values [%a]\n" (d_list ", " AD.pretty) addrs (d_list ", " VD.pretty) vs ); - set_many ~ctx ask gs st invalids' + set_many ~ctx ask st invalids' let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = @@ -2485,7 +2485,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2498,7 +2498,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2514,7 +2514,7 @@ struct let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [ + set_many ~ctx (Analyses.ask_of_ctx ctx) st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] @@ -2522,7 +2522,7 @@ struct else ( let blobsize = ID.mul (ID.cast_to ik @@ sizeval) (ID.cast_to ik @@ countval) in (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [ + set_many ~ctx (Analyses.ask_of_ctx ctx) st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] @@ -2556,7 +2556,7 @@ struct heap_addr in let lv_addr = eval_lv ask gs st lv in - set_many ~ctx ask gs st [ + set_many ~ctx ask st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); ] (* TODO: free (i.e. invalidate) old blob if successful? *) From ae56428aa66592c1b4ea4642c4e8547d182e705d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:20:00 +0200 Subject: [PATCH 06/71] Remove gs from invalidate signature in base --- src/analyses/base.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 209dc21279..dd4f91b0e6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1876,11 +1876,12 @@ struct List.map mpt exps ) - let invalidate ?(deep=true) ~ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = + let invalidate ?(deep=true) ~ctx ask (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) + let gs = ctx.global in let invalidate_address st a = let t = AD.type_of a in let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) @@ -2041,8 +2042,8 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) gs st shallow_addrs in - invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) gs st' deep_addrs + let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st shallow_addrs in + invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = let has_non_heap_var = AD.exists (function @@ -2132,7 +2133,7 @@ struct let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s\n" d_plainlval lv f.vname; - invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global st [Cil.mkAddrOrStartOf lv] + invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = @@ -2466,14 +2467,14 @@ struct | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with - | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] + | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] end - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] + | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] in let st' = invalidate_ret_lv st' in Priv.thread_join (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) id st' From 9d13dd19432a7bcb1e2ab0925b27835e4d1f1419 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:22:49 +0200 Subject: [PATCH 07/71] Remove gs from special_unknown_invalidate signature in base --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index dd4f91b0e6..1d3de4b3c8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2021,7 +2021,7 @@ struct newst end - let special_unknown_invalidate ctx ask gs st f args = + let special_unknown_invalidate ctx ask st f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2614,7 +2614,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) gs st f args + special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2744,7 +2744,7 @@ struct | exception Not_found -> (* Unknown functions *) let st = ctx.local in - let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) ctx.global st f args in + let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 55bc2d66f9c2c9f3ee73fff0e9790bf9698204e9 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:46:46 +0200 Subject: [PATCH 08/71] Remove ask from set signature in base --- src/analyses/base.ml | 69 ++++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 1d3de4b3c8..f28484de10 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1417,7 +1417,7 @@ struct (** [set st addr val] returns a state where [addr] is set to [val] * it is always ok to put None for lval_raw and rval_raw, this amounts to not using/maintaining * precise information about arrays. *) - let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = + let set ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = let update_variable x t y z = if M.tracing then M.tracel "set" ~var:x.vname "update_variable: start '%s' '%a'\nto\n%a\n\n" x.vname VD.pretty y CPA.pretty z; let r = update_variable x t y z in (* refers to defintion that is outside of set *) @@ -1430,6 +1430,7 @@ struct (* Updating a single varinfo*offset pair. NB! This function's type does * not include the flag. *) let update_one_addr (x, offs) (st: store): store = + let a = (Analyses.ask_of_ctx ctx) in let cil_offset = Offs.to_cil_offset offs in let t = match t_override with | Some t -> t @@ -1590,7 +1591,7 @@ struct let set_many ~ctx a (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = - set ~ctx a acc lval typ value + set ~ctx acc lval typ value in (* And fold over the list starting from the store turned wstore: *) List.fold_left f st lval_value_list @@ -1640,7 +1641,7 @@ struct let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true st lval lval_type ?lval_raw value + let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -1660,8 +1661,8 @@ struct let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with - | Top -> set ~ctx ask st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw - | v -> set ~ctx ask st adr lval_t v ?lval_raw ?rval_raw + | Top -> set ~ctx st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw + | v -> set ~ctx st adr lval_t v ?lval_raw ?rval_raw (************************************************************************** @@ -1834,7 +1835,7 @@ struct | ret -> ret in let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in - let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) nst (return_var ()) t_override rv in + let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1851,7 +1852,7 @@ struct let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in - set ~ctx (Analyses.ask_of_ctx ctx) ctx.local lval v.vtype new_value + set ~ctx ctx.local lval v.vtype new_value (************************************************************************** * Function calls @@ -2174,7 +2175,7 @@ struct else VD.top_value (unrollType dest_typ) in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value in + set ~ctx st dest_a dest_typ value in (* for string functions *) let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) @@ -2220,15 +2221,15 @@ struct let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (f s1_a s2_a) + set ~ctx st lv_a lv_typ (f s1_a s2_a) else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (f s1_a s2_a) + set ~ctx st lv_a lv_typ (f s1_a s2_a) else - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx st lv_a lv_typ (VD.top_value (unrollType lv_typ)) | _ -> (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) let _ = AD.string_writing_defined s1_a in - set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else @@ -2236,11 +2237,11 @@ struct | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with - | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in - set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | Bot, Array array_s2 -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in @@ -2249,7 +2250,7 @@ struct try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size with Failure _ -> ID.top_of ptrdiff_ik in let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx st lv_a lv_typ (op_array empty_array array_s2) | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in @@ -2260,19 +2261,19 @@ struct let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx st lv_a lv_typ (op_array empty_array array_s2) | _, Array array_s2 when CilType.Typ.equal s1_typ charPtrType -> (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) if op_addr = None then (* triggers warning, function only evaluated for side-effects *) let _ = AD.string_writing_defined s1_a in - set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx st s1_a s1_typ (VD.top_value (unrollType s1_typ)) else let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx st lv_a lv_typ (op_array array_s1 array_s2) | _ -> - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in let st = match desc.special args, f.vname with @@ -2287,13 +2288,13 @@ struct | _ -> VD.top_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | Bzero { dest; count; }, _ -> (* TODO: share something with memset special case? *) (* TODO: check count *) let dest_a, dest_typ = addr_type_of_exp dest in let value = VD.zero_init_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | Memcpy { dest = dst; src; n; }, _ -> (* TODO: use n *) memory_copying dst src (Some n) | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) @@ -2316,7 +2317,7 @@ struct | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> @@ -2375,10 +2376,10 @@ struct match ID.to_int x with | Some z -> if M.tracing then M.tracel "attr" "setting\n"; - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) - | None -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) + | None -> set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end - | _ -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + | _ -> set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end | Identity e, _ -> begin match lv with @@ -2453,7 +2454,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2471,7 +2472,7 @@ struct | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v + set ~ctx st ret_a (Cilfacade.typeOf ret_var) v | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] end | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] @@ -2574,14 +2575,14 @@ struct let st' = match eval_rv ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in - let r = set ~ctx ask st jmp_buf (Cilfacade.typeOf env) value in + let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in if M.tracing then M.tracel "setjmp" "setting setjmp %a on %a -> %a\n" d_exp env D.pretty st D.pretty r; r | _ -> failwith "problem?!" in begin match lv with | Some lv -> - set ~ctx ask st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2604,12 +2605,12 @@ struct in let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in - set ~ctx ~t_override:t ask ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) + set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2844,7 +2845,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = @@ -2888,7 +2889,7 @@ struct WideningTokens.with_side_tokens (WideningTokens.TS.of_list uuids) (fun () -> CPA.fold (fun x v acc -> let addr: AD.t = AD.of_mval (x, `NoOffset) in - set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false acc addr x.vtype v + set ~ctx ~invariant:false acc addr x.vtype v ) e_d.cpa ctx.local ) in @@ -2912,7 +2913,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> From c740996b56c6e58453c58c321bb2773cd590f9d2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:48:25 +0200 Subject: [PATCH 09/71] Remove ask from set_many signature in base --- src/analyses/base.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f28484de10..89cbe59b16 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1588,7 +1588,7 @@ struct (* if M.tracing then M.tracel "set" ~var:firstvar "set got an exception '%s'\n" x; *) M.info ~category:Unsound "Assignment to unknown address, assuming no write happened."; st - let set_many ~ctx a (st: store) lval_value_list: store = + let set_many ~ctx (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = set ~ctx acc lval typ value @@ -1810,7 +1810,7 @@ struct let init_var v = (AD.of_var v, v.vtype, VD.init_value ~varAttr:v.vattr v.vtype) in (* Apply it to all the locals and then assign them all *) let inits = List.map init_var f.slocals in - set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.local inits + set_many ~ctx ctx.local inits let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then @@ -1905,7 +1905,7 @@ struct let vs = List.map (Tuple3.third) invalids' in M.tracel "invalidate" "Setting addresses [%a] to values [%a]\n" (d_list ", " AD.pretty) addrs (d_list ", " VD.pretty) vs ); - set_many ~ctx ask st invalids' + set_many ~ctx st invalids' let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = @@ -2487,7 +2487,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2500,7 +2500,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2516,7 +2516,7 @@ struct let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( - set_many ~ctx (Analyses.ask_of_ctx ctx) st [ + set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] @@ -2524,7 +2524,7 @@ struct else ( let blobsize = ID.mul (ID.cast_to ik @@ sizeval) (ID.cast_to ik @@ countval) in (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [ + set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] @@ -2558,7 +2558,7 @@ struct heap_addr in let lv_addr = eval_lv ask gs st lv in - set_many ~ctx ask st [ + set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); ] (* TODO: free (i.e. invalidate) old blob if successful? *) From 05abd0df6fde2ba5f309b991aa43d6fb102414e4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:51:39 +0200 Subject: [PATCH 10/71] Remove ask from invalidate signature --- src/analyses/base.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 89cbe59b16..f55e497f9e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1877,12 +1877,13 @@ struct List.map mpt exps ) - let invalidate ?(deep=true) ~ctx ask (st:store) (exps: exp list): store = + let invalidate ?(deep=true) ~ctx (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let gs = ctx.global in + let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) @@ -2043,8 +2044,8 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st shallow_addrs in - invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) st' deep_addrs + let st' = invalidate ~deep:false ~ctx st shallow_addrs in + invalidate ~deep:true ~ctx st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = let has_non_heap_var = AD.exists (function @@ -2134,7 +2135,7 @@ struct let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s\n" d_plainlval lv f.vname; - invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st [Cil.mkAddrOrStartOf lv] + invalidate ~deep:false ~ctx st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = @@ -2468,14 +2469,14 @@ struct | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with - | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) set ~ctx st ret_a (Cilfacade.typeOf ret_var) v - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] + | _ -> invalidate ~ctx st [ret_var] end - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] + | _ -> invalidate ~ctx st [ret_var] in let st' = invalidate_ret_lv st' in Priv.thread_join (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) id st' From 5c27f2b1ad8e0ab3f6aa4bee5ce197e048687a1e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:52:53 +0200 Subject: [PATCH 11/71] Remove ask from special_unknown_invalidate signature --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f55e497f9e..9e20cfc522 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2023,7 +2023,7 @@ struct newst end - let special_unknown_invalidate ctx ask st f args = + let special_unknown_invalidate ctx st f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2616,7 +2616,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args + special_unknown_invalidate ctx st f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2746,7 +2746,7 @@ struct | exception Not_found -> (* Unknown functions *) let st = ctx.local in - let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args in + let st = special_unknown_invalidate ctx st f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 1575f7e2749b28db119dc233d7b008a9e1c56d6f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:54:30 +0200 Subject: [PATCH 12/71] Remove unneccessary parentheses and rename a -> ask --- src/analyses/base.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 9e20cfc522..d216838de0 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1430,12 +1430,12 @@ struct (* Updating a single varinfo*offset pair. NB! This function's type does * not include the flag. *) let update_one_addr (x, offs) (st: store): store = - let a = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in let cil_offset = Offs.to_cil_offset offs in let t = match t_override with | Some t -> t | None -> - if a.f (Q.IsAllocVar x) then + if ask.f (Q.IsAllocVar x) then (* the vtype of heap vars will be TVoid, so we need to trust the pointer we got to this to be of the right type *) (* i.e. use the static type of the pointer here *) lval_type @@ -1450,8 +1450,8 @@ struct in let update_offset old_value = (* Projection globals to highest Precision *) - let projected_value = project_val (Queries.to_value_domain_ask a) None None value (is_global a x) in - let new_value = VD.update_offset ~blob_destructive (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in + let projected_value = project_val (Queries.to_value_domain_ask ask) None None value (is_global ask x) in + let new_value = VD.update_offset ~blob_destructive (Queries.to_value_domain_ask ask) old_value offs projected_value lval_raw ((Var x), cil_offset) t in if WeakUpdates.mem x st.weak then VD.join old_value new_value else if invariant then ( @@ -1475,20 +1475,20 @@ struct end else (* Check if we need to side-effect this one. We no longer generate * side-effects here, but the code still distinguishes these cases. *) - if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then begin + if (!earlyglobs || ThreadFlag.has_ever_been_multi ask) && is_global ask x then begin if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: update a global var '%s' ...\n" x.vname; let priv_getg = priv_getg ctx.global in (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) - let old_value = if not invariant && Cil.isIntegralType x.vtype && not (a.f (IsAllocVar x)) && offs = `NoOffset then begin + let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ask.f (IsAllocVar x)) && offs = `NoOffset then begin VD.bot_value ~varAttr:x.vattr lval_type end else - Priv.read_global a priv_getg st x + Priv.read_global ask priv_getg st x in let new_value = update_offset old_value in if M.tracing then M.tracel "set" "update_offset %a -> %a\n" VD.pretty old_value VD.pretty new_value; - let r = Priv.write_global ~invariant a priv_getg (priv_sideg ctx.sideg) st x new_value in + let r = Priv.write_global ~invariant ask priv_getg (priv_sideg ctx.sideg) st x new_value in if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: updated a global var '%s' \nstate:%a\n\n" x.vname D.pretty r; r end else begin @@ -1565,7 +1565,7 @@ struct else let x_updated = update_variable x t new_value st.cpa in let with_dep = add_partitioning_dependencies x new_value {st with cpa = x_updated } in - effect_on_arrays a with_dep + effect_on_arrays ask with_dep end in let update_one x store = From 16c9a8be199303b8bace8ea1056000daa35a6751 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 13:20:13 +0200 Subject: [PATCH 13/71] Remove st from special_unknown_invalidate signature --- src/analyses/base.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d216838de0..c1aa47f17a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2023,7 +2023,7 @@ struct newst end - let special_unknown_invalidate ctx st f args = + let special_unknown_invalidate ctx f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2044,7 +2044,7 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx st shallow_addrs in + let st' = invalidate ~deep:false ~ctx ctx.local shallow_addrs in invalidate ~deep:true ~ctx st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = @@ -2616,7 +2616,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx st f args + special_unknown_invalidate ctx f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2745,8 +2745,7 @@ struct [make_entry ~thread:true ctx fd args] | exception Not_found -> (* Unknown functions *) - let st = ctx.local in - let st = special_unknown_invalidate ctx st f args in + let st = special_unknown_invalidate ctx f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 8187ac9c210f9e3b9f6b2eddd4507325e2632a54 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 14:20:10 +0200 Subject: [PATCH 14/71] Add ctx to almost everywhere in base --- src/analyses/base.ml | 297 ++++++++++++++++++---------------- src/analyses/baseInvariant.ml | 26 +-- 2 files changed, 169 insertions(+), 154 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c1aa47f17a..7d78e91302 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -679,14 +679,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let rec eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint a gs st exp + eval_rv_ask_evalint ~ctx a gs st exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -695,8 +695,8 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint a gs st exp = - let eval_next () = eval_rv_no_ask_evalint a gs st exp in + and eval_rv_ask_evalint ~ctx a gs st exp = + let eval_next () = eval_rv_no_ask_evalint ~ctx a gs st exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with @@ -719,24 +719,24 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint a gs st exp = - eval_rv_base a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx a gs st exp = + eval_rv_base ~ctx a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up a gs st exp = + and eval_rv_back_up ~ctx a gs st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv a gs st exp + eval_rv ~ctx a gs st exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base a gs st exp (* bypass all queries *) + eval_rv_base ~ctx a gs st exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + and eval_rv_base ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -758,7 +758,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -774,12 +774,12 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv a gs st e1 in - let a2 = eval_rv a gs st e2 in + let a1 = eval_rv ~ctx a gs st e1 in + let a2 = eval_rv ~ctx a gs st e2 in let extra_is_safe = match evalbinop_base a st op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -788,7 +788,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop a gs st op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx a gs st op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -821,8 +821,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv a gs st e in (* value of common exp *) - let vs = List.map (eval_rv a gs st) es in (* values of other sides *) + let v = eval_rv ~ctx a gs st e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx a gs st) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -864,25 +864,25 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop a gs st LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx a gs st LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop a gs st op ~e1 ~e2 typ + evalbinop ~ctx a gs st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv a gs st arg1 in + let a1 = eval_rv ~ctx a gs st arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv a gs st lval) + | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv a gs st lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv a gs st (Const (CStr (x,e))) (* TODO safe? *) + Address (AD.map array_start (eval_lv ~ctx a gs st lval)) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx a gs st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv a gs st exp in + let v = eval_rv ~ctx a gs st exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -898,9 +898,9 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv a gs st (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get a gs st (eval_lv ~ctx a gs st (Var v, ofs)) (Some exp) (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -913,7 +913,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv a gs st b in (* abstract base addresses *) + let p = eval_lv ~ctx a gs st b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -951,19 +951,19 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset a gs st ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx a gs st ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal a gs st op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx a gs st op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let a1 = eval_rv a gs st e1 in - let a2 = eval_rv a gs st e2 in + let a1 = eval_rv ~ctx a gs st e1 in + let a2 = eval_rv ~ctx a gs st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base a st op t1 a1 t2 a2 t in @@ -1002,48 +1002,48 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv a (gs:glob_fun) st (exp:exp): AD.t = + and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv a gs st lval - | _ -> eval_tv a gs st exp + | Lval lval -> eval_lv ~ctx a gs st lval + | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) - and eval_tv a (gs:glob_fun) st (exp:exp): AD.t = - match (eval_rv a gs st exp) with + and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + match (eval_rv ~ctx a gs st exp) with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int a gs st exp = - match eval_rv a gs st exp with + and eval_int ~ctx a gs st exp = + match eval_rv ~ctx a gs st exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset a (gs:glob_fun) (st: store) (ofs: offset) = + and convert_offset ~ctx a (gs:glob_fun) (st: store) (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset a gs st ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx a gs st ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset a gs st ofs) + `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) | Index (exp, ofs) -> - match eval_rv a gs st exp with - | Int i -> `Index (iDtoIdx i, convert_offset a gs st ofs) - | Address add -> `Index (AD.to_int add, convert_offset a gs st ofs) - | Top -> `Index (IdxDom.top (), convert_offset a gs st ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset a gs st ofs) + match eval_rv ~ctx a gs st exp with + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = + and eval_lv ~ctx (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset a gs st ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx a gs st ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match (eval_rv a gs st n) with + match (eval_rv ~ctx a gs st n) with | Address adr -> ( if AD.is_null adr then ( @@ -1063,7 +1063,7 @@ struct M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx a gs st ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr @@ -1075,17 +1075,17 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = try - let r = eval_rv a gs st exp in + let r = eval_rv ~ctx a gs st exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ask gs st e = + let query_evalint ~ctx ask gs st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ask gs st e with + let r = match eval_rv_no_ask_evalint ~ctx ask gs st e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) @@ -1107,17 +1107,32 @@ struct else ( let asked' = Queries.Set.add anyq asked in match q with - | EvalInt e -> query_evalint (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and ask asked = { Queries.f = fun (type a) (q: a Queries.t) -> query asked q } (* our version of ask *) - and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) in (* the expression is guaranteed to not contain globals *) - match (eval_rv (ask Queries.Set.empty) gs st exp) with + and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) + and ctx = + { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in base eval_exp context.") + ; node = MyCFG.dummy_node + ; prev_node = MyCFG.dummy_node + ; control_context = (fun () -> ctx_failwith "Base eval_exp has no context.") + ; context = (fun () -> ctx_failwith "Base eval_exp has no context.") + ; edge = MyCFG.Skip + ; local = st + ; global = gs + ; spawn = (fun ?(multiple=false) _ -> failwith "Base eval_exp should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Base eval_exp trying to split paths.") + ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") + } + in + match (eval_rv ~ctx (ask Queries.Set.empty) gs st exp) with | Int x -> ValueDomain.ID.to_int x | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in + let fp = eval_fv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -1128,14 +1143,14 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ask gs st e = + let eval_rv_address ~ctx ask gs st e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ask gs st e + eval_rv ~ctx ask gs st e (* interpreter end *) @@ -1227,7 +1242,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + begin match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1248,15 +1263,15 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1271,9 +1286,9 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1307,14 +1322,14 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1322,7 +1337,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1342,7 +1357,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1352,7 +1367,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1645,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine a gs st exp lval = eval_rv a gs st (Lval lval) + let eval_rv_lval_refine ~ctx a gs st exp lval = eval_rv ~ctx a gs st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1705,9 +1720,9 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in + let rval_val = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1739,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1761,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let valu = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1834,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1849,9 +1864,9 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in + let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in + let current_value = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1859,18 +1874,18 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps - let collect_invalidate ~deep ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_invalidate ~deep ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = if deep then - collect_funargs ask ~warn gs st exps + collect_funargs ~ctx ask ~warn gs st exps else ( - let mpt e = match eval_rv_address ask gs st e with + let mpt e = match eval_rv_address ~ctx ask gs st e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -1893,7 +1908,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~warn:true ask gs st exps in + let args = collect_invalidate ~deep ~ctx ~warn:true ask gs st exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -1912,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv (Analyses.ask_of_ctx ctx) ctx.global st) args in + let vals = List.map (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -1989,7 +2004,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in + let start_addr = eval_tv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2006,8 +2021,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in - let deep_flist = collect_invalidate ~deep:true (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; @@ -2056,7 +2071,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; @@ -2140,7 +2155,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let addr = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2167,12 +2182,12 @@ struct in let dest_a, dest_typ = addr_type_of_exp dst in let src_lval = mkMem ~addr:(Cil.stripCasts src) ~off:NoOffset in - let src_typ = eval_lv (Analyses.ask_of_ctx ctx) gs st src_lval + let src_typ = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) + eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2181,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv (Analyses.ask_of_ctx ctx) gs st n with + begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2207,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in + let s1_v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s1 in let s1_a = address_from_value s1_v in let s1_typ = AD.type_of s1_a in - let s2_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in + let s2_v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s2 in let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) @@ -2219,7 +2234,7 @@ struct begin match lv, op_addr with | Some lv_val, Some f -> (* when whished types coincide, compute result of operation op_addr, otherwise use top *) - let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) set ~ctx st lv_a lv_typ (f s1_a s2_a) @@ -2235,7 +2250,7 @@ struct (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2280,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv (Analyses.ask_of_ctx ctx) gs st ch in + let eval_ch = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2303,9 +2318,9 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv (Analyses.ask_of_ctx ctx) gs st s in + let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2331,8 +2346,8 @@ struct string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with | CArrays.IsNotSubstr -> Address (AD.null_ptr) - | CArrays.IsSubstrAtIndex0 -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2350,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2365,13 +2380,13 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv (Analyses.ask_of_ctx ctx) gs st lval in + let address = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv (Analyses.ask_of_ctx ctx) gs st mtyp with + let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in + match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st mtyp with | Int x -> begin match ID.to_int x with @@ -2390,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in - let eval_y = eval_rv (Analyses.ask_of_ctx ctx) gs st y in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_y = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2455,7 +2470,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2465,10 +2480,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match (eval_rv (Analyses.ask_of_ctx ctx) gs st ret_var) with + match (eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ret_var) with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with + begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in @@ -2488,8 +2503,8 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2501,8 +2516,8 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2514,12 +2529,12 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in - let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in + let sizeval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size in + let countval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2527,7 +2542,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2538,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ask gs st p in + let p_rv = eval_rv ~ctx ask gs st p in let p_addr = match p_rv with | Address a -> a @@ -2549,7 +2564,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ask gs st size in + let size_int = eval_int ~ctx ask gs st size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = @@ -2558,7 +2573,7 @@ struct else heap_addr in - let lv_addr = eval_lv ask gs st lv in + let lv_addr = eval_lv ~ctx ask gs st lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2573,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ask gs st env with + let st' = match eval_rv ~ctx ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2583,7 +2598,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2604,14 +2619,14 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2636,7 +2651,7 @@ struct | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ask ctx.global st lval in + let address = eval_lv ~ctx ask ctx.global st lval in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with @@ -2735,7 +2750,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2837,10 +2852,10 @@ struct let ost = octx.local (* all evals happen in octx with non-top values *) - let eval_rv a gs st e = eval_rv oa gs ost e - let eval_rv_address a gs st e = eval_rv_address oa gs ost e - let eval_lv a gs st lv = eval_lv oa gs ost lv - let convert_offset a gs st o = convert_offset oa gs ost o + let eval_rv ~ctx a gs st e = eval_rv ~ctx oa gs ost e + let eval_rv_address ~ctx a gs st e = eval_rv_address ~ctx oa gs ost e + let eval_lv ~ctx a gs st lv = eval_lv ~ctx oa gs ost lv + let convert_offset ~ctx a gs st o = convert_offset ~ctx oa gs ost o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2850,9 +2865,9 @@ struct let refine_entire_var = false let map_oldval oldval t_lval = if VD.is_bot oldval then VD.top_value t_lval else oldval - let eval_rv_lval_refine a gs st exp lv = + let eval_rv_lval_refine ~ctx a gs st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c @@ -2913,7 +2928,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f18eeed24f..174cda8ac2 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,10 +15,10 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t - val eval_rv_address: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t - val eval_lv: Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t - val convert_offset: Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t @@ -26,7 +26,7 @@ sig val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t - val eval_rv_lval_refine: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t + val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t val id_meet_down: old:ID.t -> c:ID.t -> ID.t val fd_meet_down: old:FD.t -> c:FD.t -> FD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx a gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv a gs st lval in + let addr = eval_lv ~ctx a gs st lval in if (AD.is_top addr) then st else let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,13 +92,13 @@ struct else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set a gs st (eval_lv ~ctx a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var a gs st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset a gs st o in + let offs = convert_offset ~ctx a gs st o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st @@ -111,7 +111,7 @@ struct | Var _, _ | Mem _, _ -> (* For accesses via pointers, not yet *) - let old_val = eval_rv_lval_refine a gs st exp x in + let old_val = eval_rv_lval_refine ~ctx a gs st exp x in let old_val = map_oldval old_val (Cilfacade.typeOfLval x) in let v = apply_invariant ~old_val ~new_val:c' in if is_some_bot v then contra st @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address a gs st (Lval x) with + match eval_rv_address ~ctx a gs st (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv a gs st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx a gs st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv a gs st (Lval x) with + (match eval_rv ~ctx a gs st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv a gs st e in + let eval e st = eval_rv ~ctx a gs st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From d4ef5c04e29a87a28b66471769b1ce4589a2aa68 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:16:13 +0200 Subject: [PATCH 15/71] Remove ask and gs from eval_rv signature --- src/analyses/base.ml | 96 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 12 ++--- 2 files changed, 52 insertions(+), 56 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7d78e91302..5cdf12d02e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -679,14 +679,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let rec eval_rv ~(ctx: _ ctx) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx a gs st exp + eval_rv_ask_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -724,7 +724,7 @@ struct and eval_rv_back_up ~ctx a gs st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv ~ctx a gs st exp + eval_rv ~ctx exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then @@ -962,8 +962,8 @@ struct (** Evaluate BinOp using MustBeEqual query as fallback. *) and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let a1 = eval_rv ~ctx a gs st e1 in - let a2 = eval_rv ~ctx a gs st e2 in + let a1 = eval_rv ~ctx e1 in + let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base a st op t1 a1 t2 a2 t in @@ -1008,11 +1008,11 @@ struct | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = - match (eval_rv ~ctx a gs st exp) with + match eval_rv ~ctx exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" and eval_int ~ctx a gs st exp = - match eval_rv ~ctx a gs st exp with + match eval_rv ~ctx exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of @@ -1075,9 +1075,9 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let eval_rv ~ctx (st: store) (exp:exp): value = try - let r = eval_rv ~ctx a gs st exp in + let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> @@ -1127,7 +1127,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match (eval_rv ~ctx (ask Queries.Set.empty) gs st exp) with + match eval_rv ~ctx st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1150,7 +1150,7 @@ struct VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx ask gs st e + eval_rv ~ctx st e (* interpreter end *) @@ -1266,7 +1266,7 @@ struct query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv ~ctx ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end @@ -1286,7 +1286,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + eval_rv ~ctx ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) @@ -1329,7 +1329,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let v = eval_rv ~ctx ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1660,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx a gs st exp lval = eval_rv ~ctx a gs st (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1720,7 +1720,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in + let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1754,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1776,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let valu = eval_rv ~ctx ctx.local exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1849,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1865,8 +1865,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in + let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1927,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st) args in + let vals = List.map (eval_rv ~ctx st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) + eval_rv ~ctx st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st n with + begin match eval_rv ~ctx st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s1 in + let s1_v = eval_rv ~ctx st s1 in let s1_a = address_from_value s1_v in let s1_typ = AD.type_of s1_a in - let s2_v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s2 in + let s2_v = eval_rv ~ctx st s2 in let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ch in + let eval_ch = eval_rv ~ctx st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s in + let v = eval_rv ~ctx st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2386,7 +2386,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st mtyp with + match eval_rv ~ctx st mtyp with | Int x -> begin match ID.to_int x with @@ -2405,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in - let eval_y = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st y in + let eval_x = eval_rv ~ctx st x in + let eval_y = eval_rv ~ctx st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2480,10 +2480,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match (eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ret_var) with + match eval_rv ~ctx st ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st id with + begin match eval_rv ~ctx st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in @@ -2553,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ~ctx ask gs st p in + let p_rv = eval_rv ~ctx st p in let p_addr = match p_rv with | Address a -> a @@ -2588,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ~ctx ask gs st env with + let st' = match eval_rv ~ctx st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2602,7 +2602,6 @@ struct | None -> st' end | Longjmp {env; value}, _ -> - let ask = Analyses.ask_of_ctx ctx in let ensure_not_zero (rv:value) = match rv with | Int i -> begin match ID.to_bool i with @@ -2619,7 +2618,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx ask ctx.global ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> @@ -2848,14 +2847,11 @@ struct module V = V module G = G - let oa = Analyses.ask_of_ctx octx - let ost = octx.local - (* all evals happen in octx with non-top values *) - let eval_rv ~ctx a gs st e = eval_rv ~ctx oa gs ost e - let eval_rv_address ~ctx a gs st e = eval_rv_address ~ctx oa gs ost e - let eval_lv ~ctx a gs st lv = eval_lv ~ctx oa gs ost lv - let convert_offset ~ctx a gs st o = convert_offset ~ctx oa gs ost o + let eval_rv ~ctx e = eval_rv ~ctx:octx e + let eval_rv_address ~ctx e = eval_rv_address ~ctx:octx e + let eval_lv ~ctx lv = eval_lv ~ctx:octx lv + let convert_offset ~ctx o = convert_offset ~ctx:octx o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2865,9 +2861,9 @@ struct let refine_entire_var = false let map_oldval oldval t_lval = if VD.is_bot oldval then VD.top_value t_lval else oldval - let eval_rv_lval_refine ~ctx a gs st exp lv = + let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 174cda8ac2..734d526391 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,7 +15,7 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -26,7 +26,7 @@ sig val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t - val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t + val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> lval -> VD.t val id_meet_down: old:ID.t -> c:ID.t -> ID.t val fd_meet_down: old:FD.t -> c:FD.t -> FD.t @@ -111,7 +111,7 @@ struct | Var _, _ | Mem _, _ -> (* For accesses via pointers, not yet *) - let old_val = eval_rv_lval_refine ~ctx a gs st exp x in + let old_val = eval_rv_lval_refine ~ctx st exp x in let old_val = map_oldval old_val (Cilfacade.typeOfLval x) in let v = apply_invariant ~old_val ~new_val:c' in if is_some_bot v then contra st @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx a gs st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx a gs st (Lval x) with + (match eval_rv ~ctx st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx a gs st e in + let eval e st = eval_rv ~ctx st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From 77c6f208d5a7f9ba6e66b03e7ac4eb25db59678b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:28:15 +0200 Subject: [PATCH 16/71] Remove st from eval_rv signature --- src/analyses/base.ml | 62 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 8 ++--- 2 files changed, 35 insertions(+), 35 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 5cdf12d02e..012ff60ee3 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1075,7 +1075,7 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (st: store) (exp:exp): value = + let eval_rv ~ctx (exp:exp): value = try let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; @@ -1127,7 +1127,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx st exp with + match eval_rv ~ctx exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1150,7 +1150,7 @@ struct VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx st e + eval_rv ~ctx e (* interpreter end *) @@ -1266,7 +1266,7 @@ struct query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx ctx.local e with + match eval_rv ~ctx e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end @@ -1286,7 +1286,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx ctx.local e + eval_rv ~ctx e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) @@ -1329,7 +1329,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx ctx.local e in + let v = eval_rv ~ctx e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1660,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1720,7 +1720,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx ctx.local rval in + let rval_val = eval_rv ~ctx rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1776,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx ctx.local exp in + let valu = eval_rv ~ctx exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1849,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx ctx.local exp in + let rv = eval_rv ~ctx exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1865,8 +1865,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in + let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1927,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx st) args in + let vals = List.map (eval_rv ~ctx) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx st (Lval src_cast_lval) + eval_rv ~ctx (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx st n with + begin match eval_rv ~ctx n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx st s1 in + let s1_v = eval_rv ~ctx s1 in let s1_a = address_from_value s1_v in let s1_typ = AD.type_of s1_a in - let s2_v = eval_rv ~ctx st s2 in + let s2_v = eval_rv ~ctx s2 in let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx st ch in + let eval_ch = eval_rv ~ctx ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx st s in + let v = eval_rv ~ctx s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx ctx.local exp in + let rv = eval_rv ~ctx exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2386,7 +2386,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv ~ctx st mtyp with + match eval_rv ~ctx mtyp with | Int x -> begin match ID.to_int x with @@ -2405,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx st x in + let eval_x = eval_rv ~ctx x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx st x in - let eval_y = eval_rv ~ctx st y in + let eval_x = eval_rv ~ctx x in + let eval_y = eval_rv ~ctx y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx st x in + let eval_x = eval_rv ~ctx x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2480,10 +2480,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match eval_rv ~ctx st ret_var with + match eval_rv ~ctx ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx st id with + begin match eval_rv ~ctx id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in @@ -2553,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ~ctx st p in + let p_rv = eval_rv ~ctx p in let p_addr = match p_rv with | Address a -> a @@ -2588,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ~ctx st env with + let st' = match eval_rv ~ctx env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2618,7 +2618,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 734d526391..5dba02bb65 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,7 +15,7 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx st (Lval x) with + (match eval_rv ~ctx (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx st e in + let eval e st = eval_rv ~ctx e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From c0c8de3d475559515d64d58dc7f9a009a5d80f8e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:32:32 +0200 Subject: [PATCH 17/71] Remove ask, gs and st from eval_rv_address signature --- src/analyses/base.ml | 20 ++++++++++---------- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 012ff60ee3..6285c64cbd 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1143,7 +1143,7 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ~ctx ask gs st e = + let eval_rv_address ~ctx e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) @@ -1242,7 +1242,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + begin match eval_rv_address ~ctx e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1271,7 +1271,7 @@ struct | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1288,7 +1288,7 @@ struct | Q.EvalValue e -> eval_rv ~ctx e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let p = eval_rv_address ~ctx e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1322,7 +1322,7 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i @@ -1337,7 +1337,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1357,7 +1357,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1367,7 +1367,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1885,7 +1885,7 @@ struct if deep then collect_funargs ~ctx ask ~warn gs st exps else ( - let mpt e = match eval_rv_address ~ctx ask gs st e with + let mpt e = match eval_rv_address ~ctx e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -2071,7 +2071,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with + match eval_rv_address ~ctx ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 5dba02bb65..d2e535403d 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -16,7 +16,7 @@ sig module G: Lattice.S val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address ~ctx a gs st (Lval x) with + match eval_rv_address ~ctx (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> From 7ae6bdda4a0e4e222d0de877a96ce4febb642c5a Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:40:17 +0200 Subject: [PATCH 18/71] Remove ask, gs and st from eval_rv_back_up signature --- src/analyses/base.ml | 44 ++++++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6285c64cbd..67f25dec8d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -686,7 +686,7 @@ struct if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp + eval_rv_ask_evalint ~ctx exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -695,14 +695,15 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint ~ctx a gs st exp = - let eval_next () = eval_rv_no_ask_evalint ~ctx a gs st exp in + and eval_rv_ask_evalint ~ctx exp = + let ask = Analyses.ask_of_ctx ctx in + let eval_next () = eval_rv_no_ask_evalint ~ctx exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with | typ when Cil.isIntegralType typ && not (Cil.isConstant exp) -> (* don't EvalInt integer constants, base can do them precisely itself *) if M.tracing then M.traceli "evalint" "base ask EvalInt %a\n" d_exp exp; - let a = a.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) + let a = ask.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) if M.tracing then M.traceu "evalint" "base ask EvalInt %a -> %a\n" d_exp exp Queries.ID.pretty a; begin match a with | `Bot -> eval_next () (* Base EvalInt returns bot on incorrect type (e.g. pthread_t); ignore and continue. *) @@ -719,10 +720,10 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint ~ctx a gs st exp = - eval_rv_base ~ctx a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx exp = + eval_rv_base ~ctx exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up ~ctx a gs st exp = + and eval_rv_back_up ~ctx exp = if get_bool "ana.base.eval.deep-query" then eval_rv ~ctx exp else ( @@ -730,13 +731,16 @@ struct if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base ~ctx a gs st exp (* bypass all queries *) + eval_rv_base ~ctx exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + and eval_rv_base ~ctx (exp:exp): value = + let a = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -758,7 +762,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv ~ctx a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -778,8 +782,8 @@ struct (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv ~ctx a gs st e1 in - let a2 = eval_rv ~ctx a gs st e2 in + let a1 = eval_rv ~ctx e1 in + let a2 = eval_rv ~ctx e2 in let extra_is_safe = match evalbinop_base a st op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -821,8 +825,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv ~ctx a gs st e in (* value of common exp *) - let vs = List.map (eval_rv ~ctx a gs st) es in (* values of other sides *) + let v = eval_rv ~ctx e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -870,7 +874,7 @@ struct evalbinop ~ctx a gs st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv ~ctx a gs st arg1 in + let a1 = eval_rv ~ctx arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) @@ -880,9 +884,9 @@ struct let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in Address (AD.map array_start (eval_lv ~ctx a gs st lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx a gs st (Const (CStr (x,e))) (* TODO safe? *) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv ~ctx a gs st exp in + let v = eval_rv ~ctx exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -1025,7 +1029,7 @@ struct | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) | Index (exp, ofs) -> - match eval_rv ~ctx a gs st exp with + match eval_rv ~ctx exp with | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) @@ -1043,7 +1047,7 @@ struct * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match (eval_rv ~ctx a gs st n) with + match eval_rv ~ctx n with | Address adr -> ( if AD.is_null adr then ( @@ -1085,7 +1089,7 @@ struct let query_evalint ~ctx ask gs st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ~ctx ask gs st e with + let r = match eval_rv_no_ask_evalint ~ctx e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) From 7b6005ea9af720f0d0b739ded266a37e8406045c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:51:33 +0200 Subject: [PATCH 19/71] Remove ask, gs and st from eval_lv signature --- src/analyses/base.ml | 62 ++++++++++++++++++----------------- src/analyses/baseInvariant.ml | 6 ++-- 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 67f25dec8d..3338c4f3f6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -877,13 +877,13 @@ struct let a1 = eval_rv ~ctx arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) + | AddrOf lval -> Address (eval_lv ~ctx lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv ~ctx a gs st lval)) + Address (AD.map array_start (eval_lv ~ctx lval)) | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> let v = eval_rv ~ctx exp in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv ~ctx a gs st (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -917,7 +917,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv ~ctx a gs st b in (* abstract base addresses *) + let p = eval_lv ~ctx b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -1008,7 +1008,7 @@ struct * address, e.g. when calling functions. *) and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv ~ctx a gs st lval + | Lval lval -> eval_lv ~ctx lval | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = @@ -1036,7 +1036,10 @@ struct | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv ~ctx (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = + and eval_lv ~ctx (lval:lval): AD.t = + let a = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just @@ -1726,7 +1729,7 @@ struct char_array_hack (); let rval_val = eval_rv ~ctx rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let lval_val = eval_lv ~ctx lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1868,7 +1871,7 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in + let lval = eval_lv ~ctx (Var v, NoOffset) in let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value @@ -2159,7 +2162,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let addr = eval_lv ~ctx lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2186,7 +2189,7 @@ struct in let dest_a, dest_typ = addr_type_of_exp dst in let src_lval = mkMem ~addr:(Cil.stripCasts src) ~off:NoOffset in - let src_typ = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st src_lval + let src_typ = eval_lv ~ctx src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then @@ -2238,7 +2241,7 @@ struct begin match lv, op_addr with | Some lv_val, Some f -> (* when whished types coincide, compute result of operation op_addr, otherwise use top *) - let lv_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_a = eval_lv ~ctx lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) set ~ctx st lv_a lv_typ (f s1_a s2_a) @@ -2254,7 +2257,7 @@ struct (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2322,7 +2325,7 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in + let dest_a = eval_lv ~ctx lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in let v = eval_rv ~ctx s in let a = address_from_value v in @@ -2350,8 +2353,8 @@ struct string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with | CArrays.IsNotSubstr -> Address (AD.null_ptr) - | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2384,12 +2387,12 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lval in + let address = eval_lv ~ctx lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in + let dest_a = eval_lv ~ctx dst_lval in match eval_rv ~ctx mtyp with | Int x -> begin @@ -2474,7 +2477,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2508,7 +2511,7 @@ struct let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2521,7 +2524,7 @@ struct in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2538,7 +2541,7 @@ struct if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2546,7 +2549,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2577,7 +2580,7 @@ struct else heap_addr in - let lv_addr = eval_lv ~ctx ask gs st lv in + let lv_addr = eval_lv ~ctx lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2591,7 +2594,6 @@ struct st | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> - let ask = Analyses.ask_of_ctx ctx in let st' = match eval_rv ~ctx env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in @@ -2602,7 +2604,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ~ctx ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2629,7 +2631,7 @@ struct begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2649,12 +2651,12 @@ struct let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = let ask = (Analyses.ask_of_ctx ctx) in - AD.fold (fun addr st -> + AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ~ctx ask ctx.global st lval in + let address = eval_lv ~ctx lval in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with @@ -2753,7 +2755,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2928,7 +2930,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index d2e535403d..ef72e6d961 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -17,7 +17,7 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx a gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv ~ctx a gs st lval in + let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,7 +92,7 @@ struct else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv ~ctx a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set a gs st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) From b11d327082ba2dab91cfa899182d487f101d18f2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:57:17 +0200 Subject: [PATCH 20/71] Remove ask, gs and st from convert_offset signature --- src/analyses/base.ml | 25 +++++++++++-------------- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3338c4f3f6..7f0afb3168 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -955,7 +955,7 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx a gs st ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1021,31 +1021,28 @@ struct | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset ~ctx a (gs:glob_fun) (st: store) (ofs: offset) = + and convert_offset ~ctx (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx a gs st ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) + `Index (IdxDom.top (), convert_offset ~ctx ofs) | Index (exp, ofs) -> match eval_rv ~ctx exp with - | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) - | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) - | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) and eval_lv ~ctx (lval:lval): AD.t = - let a = Analyses.ask_of_ctx ctx in - let gs = ctx.global in - let st = ctx.local in let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset ~ctx a gs st ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) @@ -1063,14 +1060,14 @@ struct ); (* Warn if any of the addresses contains a non-local and non-global variable *) if AD.exists (function - | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global a v) + | AD.Addr.Addr (v, _) -> not (CPA.mem v ctx.local.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset ~ctx a gs st ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index ef72e6d961..71e0977813 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -18,7 +18,7 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t - val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t @@ -98,7 +98,7 @@ struct (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var a gs st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset ~ctx a gs st o in + let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st From 5f18ee7f2100f0ce8557c50662b18b9416ef7154 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:01:25 +0200 Subject: [PATCH 21/71] Remove unused parameter st from evalbinop_base signature --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7f0afb3168..c6a8a4af5b 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -249,7 +249,7 @@ struct | _ -> false (* Evaluate binop for two abstract values: *) - let evalbinop_base (a: Q.ask) (st: store) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = + let evalbinop_base (a: Q.ask) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = if M.tracing then M.tracel "eval" "evalbinop %a %a %a\n" d_binop op VD.pretty a1 VD.pretty a2; (* We define a conversion function for the easy cases when we can just use * the integer domain operations. *) @@ -785,7 +785,7 @@ struct let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let extra_is_safe = - match evalbinop_base a st op t1 a1 t2 a2 typ with + match evalbinop_base a op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -970,7 +970,7 @@ struct let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base a st op t1 a1 t2 a2 t in + let r = evalbinop_base a op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) From 292bd8de21d21b49465ea8ab5f23a56d043e3a9b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:06:30 +0200 Subject: [PATCH 22/71] Remove ask, gs and st from evalbinop signature --- src/analyses/base.ml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c6a8a4af5b..714a4fdd3d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -792,7 +792,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop ~ctx a gs st op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -868,10 +868,10 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop ~ctx a gs st LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop ~ctx a gs st op ~e1 ~e2 typ + evalbinop ~ctx op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> let a1 = eval_rv ~ctx arg1 in @@ -960,24 +960,25 @@ struct in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal ~ctx a gs st op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) + let ask = Analyses.ask_of_ctx ctx in let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base a op t1 a1 t2 a2 t in + let r = evalbinop_base ask op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) | _ -> (* Fallback to MustBeEqual query, could get extra precision from exprelation/var_eq. *) let must_be_equal () = - let r = Q.must_be_equal a e1 e2 in + let r = Q.must_be_equal ask e1 e2 in if M.tracing then M.tracel "query" "MustBeEqual (%a, %a) = %b\n" d_exp e1 d_exp e2 r; r in From 4bd149386ad4885f5b5ce7b435307e0022b0d79b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:10:06 +0200 Subject: [PATCH 23/71] Remove ask, gs and st from eval_fv, eval_tv and eval_int signatures --- src/analyses/base.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 714a4fdd3d..59efc68d09 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1007,16 +1007,16 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + and eval_fv ~ctx (exp:exp): AD.t = match exp with | Lval lval -> eval_lv ~ctx lval - | _ -> eval_tv ~ctx a gs st exp + | _ -> eval_tv ~ctx exp (* Used also for thread creation: *) - and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + and eval_tv ~ctx (exp:exp): AD.t = match eval_rv ~ctx exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int ~ctx a gs st exp = + and eval_int ~ctx exp = match eval_rv ~ctx exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) @@ -1137,7 +1137,7 @@ struct | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in + let fp = eval_fv ~ctx fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -2009,7 +2009,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in + let start_addr = eval_tv ~ctx start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2508,7 +2508,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2521,7 +2521,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2534,8 +2534,8 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size in - let countval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st n in + let sizeval = eval_int ~ctx size in + let countval = eval_int ~ctx n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); @@ -2569,7 +2569,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ~ctx ask gs st size in + let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = From ac2839aac0321c8be6273da824d4ffeb3ff26ac1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:18:50 +0200 Subject: [PATCH 24/71] Remove unused parameters ask and gs from set_savetop signature --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 59efc68d09..475c1378b8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1678,7 +1678,7 @@ struct let invariant = Invariant.invariant - let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = + let set_savetop ~ctx ?lval_raw ?rval_raw st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with | Top -> set ~ctx st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw @@ -1769,15 +1769,15 @@ struct let iv = VD.bot_value ~varAttr:v.vattr t in (* correct bottom value for top level variable *) if M.tracing then M.tracel "set" "init bot value: %a\n" VD.pretty iv; let nv = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) iv offs rval_val (Some (Lval lval)) lval t in (* do desired update to value *) - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (AD.of_var v) lval_t nv ~lval_raw:lval ~rval_raw:rval (* set top-level variable to updated value *) + set_savetop ~ctx ctx.local (AD.of_var v) lval_t nv ~lval_raw:lval ~rval_raw:rval (* set top-level variable to updated value *) | None -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval let branch ctx (exp:exp) (tv:bool) : store = @@ -2666,7 +2666,7 @@ struct | _, _ -> begin let new_val = get ask ctx.global fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; - let st' = set_savetop ~ctx ask ctx.global st address lval_type new_val in + let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in match partDep with | None -> st' @@ -2753,7 +2753,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after From f68cfa7247f32ef360799539a58c9b0b8f679af4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:32:32 +0200 Subject: [PATCH 25/71] Repetitive usages of (Analyses.ask_of_ctx ctx) to one variable --- src/analyses/base.ml | 66 ++++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 475c1378b8..6a45bc1422 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1243,6 +1243,7 @@ struct Invariant.none let query ctx (type a) (q: a Q.t): a Q.result = + let ask = Analyses.ask_of_ctx ctx in match q with | Q.EvalFunvar e -> eval_funvar ctx e @@ -1251,7 +1252,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~top:(VD.bot ()) (Analyses.ask_of_ctx ctx) ctx.global ctx.local jmp_buf None with + begin match get ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1268,7 +1269,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + query_evalint ~ctx ask ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx e with @@ -1312,12 +1313,12 @@ struct else a in - let r = get ~full:true (Analyses.ask_of_ctx ctx) ctx.global ctx.local a None in + let r = get ~full:true ask ctx.global ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> (* unroll into array for Calloc calls *) - (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -1347,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars (Analyses.ask_of_ctx ctx) [a'] ctx.global ctx.local in + let addrs = reachable_vars ask [a'] ctx.global ctx.local in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1783,14 +1784,15 @@ struct let branch ctx (exp:exp) (tv:bool) : store = let valu = eval_rv ~ctx exp in let refine () = - let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in + let ask = Analyses.ask_of_ctx ctx in + let res = invariant ctx ask ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx (Analyses.ask_of_ctx ctx) ctx.global res e tv + invariant ctx ask ctx.global res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -1835,6 +1837,7 @@ struct let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then M.warn ~category:(Behavior (Undefined Other)) "Function declared 'noreturn' could return"; + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in match fundec.svar.vname with | "__goblint_dummy_init" -> @@ -1842,11 +1845,11 @@ struct publish_all ctx `Init; (* otherfun uses __goblint_dummy_init, where we can properly side effect global initialization *) (* TODO: move into sync `Init *) - Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | _ -> let locals = List.filter (fun v -> not (WeakUpdates.mem v st.weak)) (fundec.sformals @ fundec.slocals) in - let nst_part = rem_many_partitioning (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) ctx.local locals in - let nst: store = rem_many (Analyses.ask_of_ctx ctx) nst_part locals in + let nst_part = rem_many_partitioning (Queries.to_value_domain_ask ask) ctx.local locals in + let nst: store = rem_many ask nst_part locals in match exp with | None -> nst | Some exp -> @@ -1856,13 +1859,13 @@ struct in let rv = eval_rv ~ctx exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in - match ThreadId.get_current (Analyses.ask_of_ctx ctx) with - | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> + match ThreadId.get_current ask with + | `Lifted tid when ThreadReturn.is_current ask -> (* Evaluate exp and cast the resulting value to the void-pointer-type. Casting to the right type here avoids precision loss on joins. *) let rv = VD.cast ~torg:(Cilfacade.typeOf exp) Cil.voidPtrType rv in ctx.sideg (V.thread tid) (G.create_thread rv); - Priv.thread_return (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st' + Priv.thread_return ask (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st' | _ -> st' let vdecl ctx (v:varinfo) = @@ -1930,6 +1933,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in (* Evaluate the arguments. *) let vals = List.map (eval_rv ~ctx) args in @@ -1942,12 +1946,12 @@ struct Otherwise thread is analyzed with no global inits, reading globals gives bot, which turns into top, which might get published... sync `Thread doesn't help us here, it's not specific to entering multithreaded mode. EnterMultithreaded events only execute after threadenter and threadspawn. *) - if not (ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx)) then - ignore (Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st); - Priv.threadenter (Analyses.ask_of_ctx ctx) st + if not (ThreadFlag.has_ever_been_multi ask) then + ignore (Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st); + Priv.threadenter ask st ) else (* use is_global to account for values that became globals because they were saved into global variables *) - let globals = CPA.filter (fun k v -> is_global (Analyses.ask_of_ctx ctx) k) st.cpa in + let globals = CPA.filter (fun k v -> is_global ask k) st.cpa in (* let new_cpa = if !earlyglobs || ThreadFlag.is_multi ctx.ask then CPA.filter (fun k v -> is_private ctx.ask ctx.local k) globals else globals in *) let new_cpa = globals in {st with cpa = new_cpa} @@ -1957,13 +1961,13 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars (Analyses.ask_of_ctx ctx) (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ask (get_ptrs vals) ctx.global st) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in (* Projection to Precision of the Callee *) let p = PU.int_precision_from_fundec fundec in - let new_cpa = project (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (Some p) new_cpa fundec in + let new_cpa = project (Queries.to_value_domain_ask ask) (Some p) new_cpa fundec in (* Identify locals of this fundec for which an outer copy (from a call down the callstack) is reachable *) let reachable_other_copies = List.filter (fun v -> match Cilfacade.find_scope_fundec v with Some scope -> CilType.Fundec.equal scope fundec | None -> false) reachable in @@ -2375,9 +2379,10 @@ struct (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) publish_all ctx `Return; (* like normal return *) - match ThreadId.get_current (Analyses.ask_of_ctx ctx) with - | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> - ignore @@ Priv.thread_return (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st + let ask = Analyses.ask_of_ctx ctx in + match ThreadId.get_current ask with + | `Lifted tid when ThreadReturn.is_current ask -> + ignore @@ Priv.thread_return ask (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st | _ -> ()) | _ -> () end; @@ -2648,7 +2653,7 @@ struct if get_bool "sem.noreturn.dead_code" && Cil.hasAttribute "noreturn" f.vattr then raise Deadcode else st let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = - let ask = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> @@ -2691,7 +2696,7 @@ struct let add_globals (st: store) (fun_st: store) = (* Remove the return value as this is dealt with separately. *) let cpa_noreturn = CPA.remove (return_varinfo ()) fun_st.cpa in - let ask = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in let tainted = f_ask.f Q.MayBeTainted in if M.tracing then M.trace "taintPC" "combine for %s in base: tainted: %a\n" f.svar.vname AD.pretty tainted; if M.tracing then M.trace "taintPC" "combine base:\ncaller: %a\ncallee: %a\n" CPA.pretty st.cpa CPA.pretty fun_st.cpa; @@ -2911,21 +2916,22 @@ struct D.join ctx.local e_d' let event ctx e octx = + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in match e with - | Events.Lock (addr, _) when ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) -> (* TODO: is this condition sound? *) + | Events.Lock (addr, _) when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) if M.tracing then M.tracel "priv" "LOCK EVENT %a\n" LockDomain.Addr.pretty addr; - Priv.lock (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) st addr - | Events.Unlock addr when ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) -> (* TODO: is this condition sound? *) + Priv.lock ask (priv_getg ctx.global) st addr + | Events.Unlock addr when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) if addr = UnknownPtr then M.info ~category:Unsound "Unknown mutex unlocked, base privatization unsound"; (* TODO: something more sound *) WideningTokens.with_local_side_tokens (fun () -> - Priv.unlock (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st addr + Priv.unlock ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st addr ) | Events.Escape escaped -> - Priv.escape (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st escaped + Priv.escape ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st escaped | Events.EnterMultiThreaded -> - Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) From dd1b75386f72a4c56950941b40d07cd32f11aa1f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:36:26 +0200 Subject: [PATCH 26/71] Remove ask, gs and st from collect_funargs and collect_invalidate signatures --- src/analyses/base.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6a45bc1422..c630cc7e96 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1882,16 +1882,19 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_funargs ~ctx ?(warn=false) (exps: exp list) = + let ask = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let do_exp e = let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps - let collect_invalidate ~deep ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_invalidate ~deep ~ctx ?(warn=false) (exps: exp list) = if deep then - collect_funargs ~ctx ask ~warn gs st exps + collect_funargs ~ctx ~warn exps else ( let mpt e = match eval_rv_address ~ctx e with | Address a -> AD.remove NullPtr a @@ -1916,7 +1919,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~ctx ~warn:true ask gs st exps in + let args = collect_invalidate ~deep ~ctx ~warn:true exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -2030,8 +2033,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in - let deep_flist = collect_invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; From c065fa4599095f76f8c2464ffeded52c9a82ef8f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:43:21 +0200 Subject: [PATCH 27/71] Fix some commented out code --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c630cc7e96..42df030c22 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -905,7 +905,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) - (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) + (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) let rec contains_vla (t:typ) = match t with @@ -2515,7 +2515,7 @@ struct match lv with | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in - (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) + (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st @@ -2528,7 +2528,7 @@ struct then AD.join (AD.of_var (heap_var false ctx)) AD.null_ptr else AD.of_var (heap_var false ctx) in - (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) + (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st From 50afde7439d17071b4daadf15ccfae0d67f14bcd Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:04:20 +0200 Subject: [PATCH 28/71] Add ctx as parameter to reachable_vars --- src/analyses/base.ml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 42df030c22..9d5520baf7 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -512,7 +512,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = + let rec reachable_from_value ~ctx (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -524,12 +524,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ask gs st e t description + | Union (f,e) -> reachable_from_value ~ctx ask gs st e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ask gs st e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ask gs st v t description) acc) s empty + | Array a -> reachable_from_value ~ctx ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ~ctx ask gs st e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx ask gs st v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -540,9 +540,9 @@ struct (* Get the list of addresses accessable immediately from a given address, thus * all pointers within a structure should be considered, but we don't follow * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address (ask: Q.ask) (gs:glob_fun) st (adr: address): address = + let reachable_from_address ~ctx (ask: Q.ask) (gs:glob_fun) st (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -550,7 +550,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = + let reachable_vars ~ctx (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -563,7 +563,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ask gs st var) acc in + AD.union (reachable_from_address ~ctx ask gs st var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -572,7 +572,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ask args gs st = Timing.wrap "reachability" (reachable_vars ask args gs) st + let reachable_vars ~ctx ask args gs st = Timing.wrap "reachability" (reachable_vars ~ctx ask args gs) st let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else @@ -1348,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ask [a'] ctx.global ctx.local in + let addrs = reachable_vars ~ctx ask [a'] ctx.global ctx.local in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1887,8 +1887,8 @@ struct let gs = ctx.global in let st = ctx.local in let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ask [immediately_reachable] gs st + let immediately_reachable = reachable_from_value ~ctx ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + reachable_vars ~ctx ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1964,7 +1964,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ask (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx ask (get_ptrs vals) ctx.global st) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From 1b617af98034f72e4f9356833bc02066ee684941 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:12:29 +0200 Subject: [PATCH 29/71] Remove ask, gs and st from reachable_vars signatures --- src/analyses/base.ml | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 9d5520baf7..e075072807 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -512,7 +512,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value ~ctx (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = + let rec reachable_from_value ~ctx (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -524,12 +524,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ~ctx ask gs st e t description + | Union (f,e) -> reachable_from_value ~ctx e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ~ctx ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ~ctx ask gs st e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx ask gs st v t description) acc) s empty + | Array a -> reachable_from_value ~ctx (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ~ctx e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -540,9 +540,9 @@ struct (* Get the list of addresses accessable immediately from a given address, thus * all pointers within a structure should be considered, but we don't follow * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address ~ctx (ask: Q.ask) (gs:glob_fun) st (adr: address): address = + let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -550,7 +550,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars ~ctx (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = + let reachable_vars ~ctx (args: address list): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -563,7 +563,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ~ctx ask gs st var) acc in + AD.union (reachable_from_address ~ctx var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -572,7 +572,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ~ctx ask args gs st = Timing.wrap "reachability" (reachable_vars ~ctx ask args gs) st + let reachable_vars ~ctx args = Timing.wrap "reachability" (reachable_vars ~ctx) args let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else @@ -1348,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ~ctx ask [a'] ctx.global ctx.local in + let addrs = reachable_vars ~ctx [a'] in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1883,12 +1883,9 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (exps: exp list) = - let ask = Analyses.ask_of_ctx ctx in - let gs = ctx.global in - let st = ctx.local in let do_exp e = - let immediately_reachable = reachable_from_value ~ctx ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ~ctx ask [immediately_reachable] gs st + let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps @@ -1964,7 +1961,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx ask (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx (get_ptrs vals)) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From dc6527cbd32174f08a48a660b0e75c5354df14f4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:14:49 +0200 Subject: [PATCH 30/71] Remove the unused parameters ask, gs and st from query_evalint --- src/analyses/base.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index e075072807..0f77fef495 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1088,7 +1088,7 @@ struct with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ~ctx ask gs st e = + let query_evalint ~ctx e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; let r = match eval_rv_no_ask_evalint ~ctx e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) @@ -1110,12 +1110,10 @@ struct if Queries.Set.mem anyq asked then Queries.Result.top q (* query cycle *) else ( - let asked' = Queries.Set.add anyq asked in match q with - | EvalInt e -> query_evalint ~ctx (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) - and ask asked = { Queries.f = fun (type a) (q: a Queries.t) -> query asked q } (* our version of ask *) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) and ctx = { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) @@ -1269,7 +1267,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx ask ctx.global ctx.local e + query_evalint ~ctx e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx e with From 6d2e52df09b1d3fb51ad0521d4579ef48e4efa26 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:05:08 +0200 Subject: [PATCH 31/71] Add ctx as parameter to get --- src/analyses/base.ml | 34 +++++++++++++++++----------------- src/analyses/baseInvariant.ml | 6 +++--- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0f77fef495..f27ba9e5a6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -455,7 +455,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -464,7 +464,7 @@ struct let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) let var = get_var a gs st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +542,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +659,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) + reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +949,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1250,7 +1250,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1311,7 @@ struct else a in - let r = get ~full:true ask ctx.global ctx.local a None in + let r = get ~ctx ~full:true ask ctx.global ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1659,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get a gs st addrs exp = get a gs st addrs exp + let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1907,7 +1907,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2259,7 +2259,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with + begin match (get ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in @@ -2336,7 +2336,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get (Analyses.ask_of_ctx ctx) gs st a None with + begin match get ~ctx (Analyses.ask_of_ctx ctx) gs st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in @@ -2571,7 +2571,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2667,7 +2667,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ask ctx.global fun_st address None in + let new_val = get ~ctx ask ctx.global fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2742,7 +2742,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None + then get ~ctx (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None else VD.top () in @@ -2862,7 +2862,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get a gs st addrs exp = get a gs st addrs exp + let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 71e0977813..5e82644caf 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -21,7 +21,7 @@ sig val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t - val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get a gs state_with_excluded addr None in + let value = get ~ctx a gs state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) From 985e746e4da0a7592e09c91bf345d2f5cff27b67 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:07:57 +0200 Subject: [PATCH 32/71] Add ctx as parameter to get_var --- src/analyses/base.ml | 6 +++--- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f27ba9e5a6..214d5d7446 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,7 +443,7 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = + let get_var ~ctx (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then Priv.read_global a (priv_getg gs) st x else begin @@ -463,7 +463,7 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var a gs st x in + let var = get_var ~ctx a gs st x in let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with @@ -1172,7 +1172,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ask ctx.global ctx.local v + let find v = get_var ~ctx ask ctx.global ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 5e82644caf..8d91afbaae 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,7 +20,7 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var a gs st var in + let old_val = get_var ~ctx a gs st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From 8f8273c2801e781c93c88eeab9755ce1a2a1b0e3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:13:11 +0200 Subject: [PATCH 33/71] Remove gs from get and get_var signatures --- src/analyses/base.ml | 44 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 10 ++++---- 2 files changed, 26 insertions(+), 28 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 214d5d7446..b11ce2428e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,9 +443,9 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var ~ctx (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = + let get_var ~ctx (a: Q.ask) (st: store) (x: varinfo): value = if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then - Priv.read_global a (priv_getg gs) st x + Priv.read_global a (priv_getg ctx.global) st x else begin if M.tracing then M.tracec "get" "Singlethreaded mode.\n"; CPA.find x st.cpa @@ -455,7 +455,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -463,8 +463,8 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var ~ctx a gs st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let var = get_var ~ctx a st x in + let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +542,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +659,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) + reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx a st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +949,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~ctx ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) a st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1172,7 +1172,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ~ctx ask ctx.global ctx.local v + let find v = get_var ~ctx ask ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in @@ -1250,7 +1250,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~ctx ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ask ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1311,7 @@ struct else a in - let r = get ~ctx ~full:true ask ctx.global ctx.local a None in + let r = get ~ctx ~full:true ask ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1659,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp + let get ~ctx a st addrs exp = get ~ctx a st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1903,11 +1903,10 @@ struct if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) - let gs = ctx.global in let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ~ctx ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx ask st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2169,7 +2168,6 @@ struct if M.tracing then if not (List.is_empty forks) then M.tracel "spawn" "Base.special %s: spawning functions %a\n" f.vname (d_list "," CilType.Varinfo.pretty) (List.map BatTuple.Tuple3.second forks); List.iter (BatTuple.Tuple3.uncurry (ctx.spawn ~multiple)) forks; let st: store = ctx.local in - let gs = ctx.global in let desc = LF.find f in let memory_copying dst src n = let dest_size = get_size_of_ptr_target ctx dst in @@ -2259,7 +2257,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match (get ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) gs st s2_a None with + begin match (get ~ctx (Analyses.ask_of_ctx ctx) st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in @@ -2336,7 +2334,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get ~ctx (Analyses.ask_of_ctx ctx) gs st a None with + begin match get ~ctx (Analyses.ask_of_ctx ctx) st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in @@ -2571,7 +2569,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ~ctx ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx ask st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2667,7 +2665,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ~ctx ask ctx.global fun_st address None in + let new_val = get ~ctx ask fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2742,7 +2740,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get ~ctx (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None + then get ~ctx (Analyses.ask_of_ctx ctx) fun_st return_var None else VD.top () in @@ -2862,7 +2860,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp + let get ~ctx a st addrs exp = get ~ctx a st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 8d91afbaae..abdb701510 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,8 +20,8 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t - val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> varinfo -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get ~ctx a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx a st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get ~ctx a gs state_with_excluded addr None in + let value = get ~ctx a state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var ~ctx a gs st var in + let old_val = get_var ~ctx a st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From b9be6a5add38c1eae9326f10974f87d44e0e893d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:18:30 +0200 Subject: [PATCH 34/71] Remove ask from get and get_var signatures --- src/analyses/base.ml | 47 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 10 ++++---- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index b11ce2428e..6923b01430 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,9 +443,10 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var ~ctx (a: Q.ask) (st: store) (x: varinfo): value = - if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then - Priv.read_global a (priv_getg ctx.global) st x + let get_var ~ctx (st: store) (x: varinfo): value = + let ask = Analyses.ask_of_ctx ctx in + if (!earlyglobs || ThreadFlag.has_ever_been_multi ask) && is_global ask x then + Priv.read_global ask (priv_getg ctx.global) st x else begin if M.tracing then M.tracec "get" "Singlethreaded mode.\n"; CPA.find x st.cpa @@ -455,7 +456,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -463,8 +464,8 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var ~ctx a st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let var = get_var ~ctx st x in + let v = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +543,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +660,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) + reachable_from_value (get ~ctx ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +905,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx a st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +950,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~ctx ~top:(VD.top_value t) a st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1172,7 +1173,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ~ctx ask ctx.local v + let find v = get_var ~ctx ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in @@ -1250,7 +1251,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~ctx ~top:(VD.bot ()) ask ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1312,7 @@ struct else a in - let r = get ~ctx ~full:true ask ctx.local a None in + let r = get ~ctx ~full:true ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1660,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get ~ctx a st addrs exp = get ~ctx a st addrs exp + let get ~ctx st addrs exp = get ~ctx st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1906,7 +1907,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ~ctx ask st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2257,7 +2258,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match (get ~ctx (Analyses.ask_of_ctx ctx) st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) st s2_a None with + begin match (get ~ctx st s1_a None), get ~ctx st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in @@ -2334,7 +2335,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get ~ctx (Analyses.ask_of_ctx ctx) st a None with + begin match get ~ctx st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in @@ -2558,7 +2559,6 @@ struct check_invalid_mem_dealloc ctx f p; begin match lv with | Some lv -> - let ask = Analyses.ask_of_ctx ctx in let p_rv = eval_rv ~ctx p in let p_addr = match p_rv with @@ -2569,7 +2569,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ~ctx ask st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2649,7 +2649,6 @@ struct if get_bool "sem.noreturn.dead_code" && Cil.hasAttribute "noreturn" f.vattr then raise Deadcode else st let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = - let ask = Analyses.ask_of_ctx ctx in AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> @@ -2665,7 +2664,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ~ctx ask fun_st address None in + let new_val = get ~ctx fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2740,7 +2739,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get ~ctx (Analyses.ask_of_ctx ctx) fun_st return_var None + then get ~ctx fun_st return_var None else VD.top () in @@ -2860,7 +2859,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get ~ctx a st addrs exp = get ~ctx a st addrs exp + let get ~ctx st addrs exp = get ~ctx st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index abdb701510..51e71333f4 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,8 +20,8 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> varinfo -> VD.t - val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> AD.t -> exp option -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get ~ctx a st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get ~ctx a state_with_excluded addr None in + let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var ~ctx a st var in + let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From 33875aa4aa121073f2bbb20726fd5bf1ba3d7134 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:27:45 +0200 Subject: [PATCH 35/71] Simplify `ask.f` -> `ctx.ask` --- src/analyses/base.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6923b01430..5c7c540b52 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -697,14 +697,13 @@ struct This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) and eval_rv_ask_evalint ~ctx exp = - let ask = Analyses.ask_of_ctx ctx in let eval_next () = eval_rv_no_ask_evalint ~ctx exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with | typ when Cil.isIntegralType typ && not (Cil.isConstant exp) -> (* don't EvalInt integer constants, base can do them precisely itself *) if M.tracing then M.traceli "evalint" "base ask EvalInt %a\n" d_exp exp; - let a = ask.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) + let a = ctx.ask (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) if M.tracing then M.traceu "evalint" "base ask EvalInt %a -> %a\n" d_exp exp Queries.ID.pretty a; begin match a with | `Bot -> eval_next () (* Base EvalInt returns bot on incorrect type (e.g. pthread_t); ignore and continue. *) @@ -1455,7 +1454,7 @@ struct let t = match t_override with | Some t -> t | None -> - if ask.f (Q.IsAllocVar x) then + if ctx.ask (Q.IsAllocVar x) then (* the vtype of heap vars will be TVoid, so we need to trust the pointer we got to this to be of the right type *) (* i.e. use the static type of the pointer here *) lval_type @@ -1501,7 +1500,7 @@ struct (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) - let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ask.f (IsAllocVar x)) && offs = `NoOffset then begin + let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ctx.ask (IsAllocVar x)) && offs = `NoOffset then begin VD.bot_value ~varAttr:x.vattr lval_type end else Priv.read_global ask priv_getg st x From 6c16cdcf4f1d577fb0814626640ef58ba8b93189 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:29:41 +0200 Subject: [PATCH 36/71] Remove gs from eval_rv_base_lval signature --- src/analyses/base.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 5c7c540b52..721f67c244 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -739,7 +739,6 @@ struct Subexpressions delegate to [eval_rv], which may use queries on them. *) and eval_rv_base ~ctx (exp:exp): value = let a = Analyses.ask_of_ctx ctx in - let gs = ctx.global in let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; @@ -778,7 +777,7 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> @@ -902,7 +901,7 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) @@ -2866,7 +2865,7 @@ struct if VD.is_bot oldval then VD.top_value t_lval else oldval let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st exp lv + eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c From 05feaddb4009b4eeb5b97cbb5f44eb522cdb12f8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:32:02 +0200 Subject: [PATCH 37/71] Remove ask from eval_rv_base_lval signature --- src/analyses/base.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 721f67c244..8098814c37 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -777,7 +777,7 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv ~ctx a st exp lv + eval_rv_base_lval ~eval_lv ~ctx st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> @@ -901,7 +901,7 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) @@ -954,7 +954,7 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -2865,7 +2865,7 @@ struct if VD.is_bot oldval then VD.top_value t_lval else oldval let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) st exp lv + eval_rv_base_lval ~eval_lv ~ctx st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c From 8dd333287f6434a5717575927a2c9c4ddeec34e9 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:37:55 +0200 Subject: [PATCH 38/71] Inline ask variables with only one usage --- src/analyses/base.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 8098814c37..6448494305 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -738,7 +738,6 @@ struct This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) and eval_rv_base ~ctx (exp:exp): value = - let a = Analyses.ask_of_ctx ctx in let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; @@ -784,7 +783,7 @@ struct let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let extra_is_safe = - match evalbinop_base a op t1 a1 t2 a2 typ with + match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -1240,7 +1239,6 @@ struct Invariant.none let query ctx (type a) (q: a Q.t): a Q.result = - let ask = Analyses.ask_of_ctx ctx in match q with | Q.EvalFunvar e -> eval_funvar ctx e @@ -1315,7 +1313,7 @@ struct (match r with | Array a -> (* unroll into array for Calloc calls *) - (match ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -1902,11 +1900,10 @@ struct if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) - let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in let v = get ~ctx st a None in (* None here is ok, just causes us to be a bit less precise *) - let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in + let nv = VD.invalidate_value (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) t v in (a, t, nv) in (* We define the function that invalidates all the values that an address From b073b7189359a803d69a1f27b685ab5c4d5b8665 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:42:28 +0200 Subject: [PATCH 39/71] Remove gs from invariant, invariant_fallback and refine_lv signatures --- src/analyses/base.ml | 8 ++++---- src/analyses/baseInvariant.ml | 14 +++++++------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6448494305..3e22f2bfef 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1780,14 +1780,14 @@ struct let valu = eval_rv ~ctx exp in let refine () = let ask = Analyses.ask_of_ctx ctx in - let res = invariant ctx ask ctx.global ctx.local exp tv in + let res = invariant ctx ask ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx ask ctx.global res e tv + invariant ctx ask res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -2034,7 +2034,7 @@ struct let assert_fn ctx e refine = (* make the state meet the assertion in the rest of the code *) if not refine then ctx.local else begin - let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in + let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true in (* if check_assert e newst <> `Lifted true then M.warn ~category:Assert ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst @@ -2873,7 +2873,7 @@ struct in let module Unassume = BaseInvariant.Make (UnassumeEval) in try - Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true + Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true with Deadcode -> (* contradiction in unassume *) D.bot () in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 51e71333f4..bd5bd7c6ed 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -91,8 +91,8 @@ struct then set a gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) - let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let refine_lv ctx a st c x c' pretty exp = + let set' lval v st = set a ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) @@ -120,7 +120,7 @@ struct set' x v st ) - let invariant_fallback ctx a (gs:V.t -> G.t) st exp tv = + let invariant_fallback ctx a st exp tv = (* We use a recursive helper function so that x != 0 is false can be handled * as x == 0 is true etc *) let rec helper (op: binop) (lval: lval) (value: VD.t) (tv: bool): (lval * VD.t) option = @@ -240,16 +240,16 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx a gs st lval value tv + refine_lv_fallback ctx a ctx.global st lval value tv | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; st - let invariant ctx a gs st exp tv: D.t = + let invariant ctx a st exp tv: D.t = let fallback reason st = if M.tracing then M.tracel "inv" "Can't handle %a.\n%t\n" d_plainexp exp reason; - invariant_fallback ctx a gs st exp tv + invariant_fallback ctx a st exp tv in (* inverse values for binary operation a `op` b == c *) (* ikind is the type of a for limiting ranges of the operands a, b. The only binops which can have different types for a, b are Shiftlt, Shiftrt (not handled below; don't use ikind to limit b there). *) @@ -696,7 +696,7 @@ struct | Float c -> invert_binary_op c FD.pretty (fun ik -> FD.to_int ik c) (fun fk -> FD.cast_to fk c) | _ -> failwith "unreachable") | Lval x, (Int _ | Float _ | Address _) -> (* meet x with c *) - let update_lval c x c' pretty = refine_lv ctx a gs st c x c' pretty exp in + let update_lval c x c' pretty = refine_lv ctx a st c x c' pretty exp in let t = Cil.unrollType (Cilfacade.typeOfLval x) in (* unroll type to deal with TNamed *) if M.tracing then M.trace "invSpecial" "invariant with Lval %a, c_typed %a, type %a\n" d_lval x VD.pretty c_typed d_type t; begin match c_typed with From cc0285b18bfb0110426d4d777ff9d2bbeba32368 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:48:43 +0200 Subject: [PATCH 40/71] Remove ask from invariant, invariant_fallback, refine_lv and refine_lv_fallbask signatures --- src/analyses/base.ml | 9 ++++----- src/analyses/baseInvariant.ml | 25 +++++++++++++------------ 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3e22f2bfef..72dfc4af68 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1779,15 +1779,14 @@ struct let branch ctx (exp:exp) (tv:bool) : store = let valu = eval_rv ~ctx exp in let refine () = - let ask = Analyses.ask_of_ctx ctx in - let res = invariant ctx ask ctx.local exp tv in + let res = invariant ctx ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx ask res e tv + invariant ctx res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -2034,7 +2033,7 @@ struct let assert_fn ctx e refine = (* make the state meet the assertion in the rest of the code *) if not refine then ctx.local else begin - let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true in + let newst = invariant ctx ctx.local e true in (* if check_assert e newst <> `Lifted true then M.warn ~category:Assert ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst @@ -2873,7 +2872,7 @@ struct in let module Unassume = BaseInvariant.Make (UnassumeEval) in try - Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true + Unassume.invariant ctx ctx.local e true with Deadcode -> (* contradiction in unassume *) D.bot () in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index bd5bd7c6ed..e4074af59e 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -62,7 +62,7 @@ struct VD.meet old_val new_val with Lattice.Uncomparable -> old_val - let refine_lv_fallback ctx a gs st lval value tv = + let refine_lv_fallback ctx gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st @@ -78,7 +78,8 @@ struct else old_val in - let state_with_excluded = set a gs st addr t_lval value ~ctx in + let ask = Analyses.ask_of_ctx ctx in + let state_with_excluded = set ask gs st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -88,18 +89,18 @@ struct contra st ) else if VD.is_bot new_val - then set a gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set ask gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set ask gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) - let refine_lv ctx a st c x c' pretty exp = - let set' lval v st = set a ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let refine_lv ctx st c x c' pretty exp = + let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in - let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in + let new_val = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st else ( @@ -120,7 +121,7 @@ struct set' x v st ) - let invariant_fallback ctx a st exp tv = + let invariant_fallback ctx st exp tv = (* We use a recursive helper function so that x != 0 is false can be handled * as x == 0 is true etc *) let rec helper (op: binop) (lval: lval) (value: VD.t) (tv: bool): (lval * VD.t) option = @@ -240,16 +241,16 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx a ctx.global st lval value tv + refine_lv_fallback ctx ctx.global st lval value tv | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; st - let invariant ctx a st exp tv: D.t = + let invariant ctx st exp tv: D.t = let fallback reason st = if M.tracing then M.tracel "inv" "Can't handle %a.\n%t\n" d_plainexp exp reason; - invariant_fallback ctx a st exp tv + invariant_fallback ctx st exp tv in (* inverse values for binary operation a `op` b == c *) (* ikind is the type of a for limiting ranges of the operands a, b. The only binops which can have different types for a, b are Shiftlt, Shiftrt (not handled below; don't use ikind to limit b there). *) @@ -696,7 +697,7 @@ struct | Float c -> invert_binary_op c FD.pretty (fun ik -> FD.to_int ik c) (fun fk -> FD.cast_to fk c) | _ -> failwith "unreachable") | Lval x, (Int _ | Float _ | Address _) -> (* meet x with c *) - let update_lval c x c' pretty = refine_lv ctx a st c x c' pretty exp in + let update_lval c x c' pretty = refine_lv ctx st c x c' pretty exp in let t = Cil.unrollType (Cilfacade.typeOfLval x) in (* unroll type to deal with TNamed *) if M.tracing then M.trace "invSpecial" "invariant with Lval %a, c_typed %a, type %a\n" d_lval x VD.pretty c_typed d_type t; begin match c_typed with From 3d2dc96e535061c11c1b5b81c62bf566298bd40f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:50:55 +0200 Subject: [PATCH 41/71] Remove gs from refine_lv_fallback signature --- src/analyses/baseInvariant.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index e4074af59e..6a37c06279 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -62,7 +62,7 @@ struct VD.meet old_val new_val with Lattice.Uncomparable -> old_val - let refine_lv_fallback ctx gs st lval value tv = + let refine_lv_fallback ctx st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st @@ -79,7 +79,7 @@ struct old_val in let ask = Analyses.ask_of_ctx ctx in - let state_with_excluded = set ask gs st addr t_lval value ~ctx in + let state_with_excluded = set ask ctx.global st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -89,8 +89,8 @@ struct contra st ) else if VD.is_bot new_val - then set ask gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set ask gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set ask ctx.global st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set ask ctx.global st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in @@ -241,7 +241,7 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx ctx.global st lval value tv + refine_lv_fallback ctx st lval value tv | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; From f4da507d8d69c3d4b6f959aa6154e5695b3c2231 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:39:42 +0200 Subject: [PATCH 42/71] Fix get in comment --- src/analyses/base.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 72dfc4af68..ca30a745d8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -903,7 +903,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) - (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) + (* | Lval (Mem e, ofs) -> get ~ctx st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) let rec contains_vla (t:typ) = match t with From 8ce2825757d79ef8799c9f438482dc2ba2b826ae Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:45:27 +0200 Subject: [PATCH 43/71] Remove ask and gs from set signature --- src/analyses/base.ml | 4 ++-- src/analyses/baseInvariant.ml | 11 +++++------ 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index ca30a745d8..d23d53b1b4 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1657,7 +1657,7 @@ struct let get_var = get_var let get ~ctx st addrs exp = get ~ctx st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value + let set ~ctx st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -2854,7 +2854,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get ~ctx st addrs exp = get ~ctx st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set ~ctx st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 6a37c06279..df93be5896 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -22,7 +22,7 @@ sig val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t - val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t + val set: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t @@ -78,8 +78,7 @@ struct else old_val in - let ask = Analyses.ask_of_ctx ctx in - let state_with_excluded = set ask ctx.global st addr t_lval value ~ctx in + let state_with_excluded = set st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -89,11 +88,11 @@ struct contra st ) else if VD.is_bot new_val - then set ask ctx.global st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set ask ctx.global st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = - let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) From e6752d5d08e966286a804f356b7866398f49314f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:51:13 +0200 Subject: [PATCH 44/71] Replace redundant eval_lv call with AD.singleton --- src/analyses/base.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d23d53b1b4..b77ee3d2fc 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2647,8 +2647,7 @@ struct match addr with | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then - let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ~ctx lval in + let address = AD.singleton addr in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with From 06a2d5488c4e64d2890e6336b4085ece6cd32b93 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 14:42:33 +0200 Subject: [PATCH 45/71] Simplify matches in combine_st --- src/analyses/base.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index b77ee3d2fc..430a1394db 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2645,23 +2645,23 @@ struct let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = AD.fold (fun addr (st: store) -> match addr with - | Addr.Addr (v,o) -> - if CPA.mem v fun_st.cpa then - let address = AD.singleton addr in + | Addr.Addr (v,o) when CPA.mem v fun_st.cpa -> + begin let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; - match (CPA.find_opt v (fun_st.cpa)), lval_type with - | None, _ -> st + match CPA.find_opt v (fun_st.cpa) with + | None -> st (* partitioned arrays cannot be copied by individual lvalues, so if tainted just copy the whole callee value for the array variable *) - | Some (Array a), _ when (CArrays.domain_of_t a) = PartitionedDomain -> {st with cpa = CPA.add v (Array a) st.cpa} + | Some (Array a) when CArrays.domain_of_t a = PartitionedDomain -> {st with cpa = CPA.add v (Array a) st.cpa} (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) - | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} - | _, _ -> begin + | Some voidVal when Addr.type_of addr = voidType -> {st with cpa = CPA.add v voidVal st.cpa} + | _ -> + begin + let address = AD.singleton addr in let new_val = get ~ctx fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in - let partDep = Dep.find_opt v fun_st.deps in - match partDep with + match Dep.find_opt v fun_st.deps with | None -> st' (* if a var partitions an array, all cpa-info for arrays it may partition are added from callee to caller *) | Some deps -> {st' with cpa = (Dep.VarSet.fold (fun v accCPA -> let val_opt = CPA.find_opt v fun_st.cpa in @@ -2669,7 +2669,7 @@ struct | None -> accCPA | Some new_val -> CPA.add v new_val accCPA ) deps st'.cpa)} end - else st + end | _ -> st ) tainted_lvs local_st From b23dea350b53733c6fc4d7b60f4c9f1cb9f6adc7 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 3 Jan 2024 20:16:08 +0200 Subject: [PATCH 46/71] Revert "Remove st from eval_rv signature" This reverts commit 77c6f208d5a7f9ba6e66b03e7ac4eb25db59678b. --- src/analyses/base.ml | 94 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 12 ++--- 2 files changed, 53 insertions(+), 53 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 430a1394db..86d45720e4 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1078,7 +1078,7 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (exp:exp): value = + let eval_rv ~ctx (st: store) (exp:exp): value = try let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; @@ -1128,7 +1128,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx exp with + match eval_rv ~ctx st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1144,14 +1144,14 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ~ctx e = + let eval_rv_address ~ctx st e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx e + eval_rv ~ctx st e (* interpreter end *) @@ -1243,7 +1243,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address ~ctx e with + begin match eval_rv_address ~ctx ctx.local e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1267,12 +1267,12 @@ struct query_evalint ~ctx e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx e with + match eval_rv ~ctx ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1287,9 +1287,9 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx e + eval_rv ~ctx ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address ~ctx e in + let p = eval_rv_address ~ctx ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1323,14 +1323,14 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx e in + let v = eval_rv ~ctx ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1338,7 +1338,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1358,7 +1358,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1368,7 +1368,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1661,7 +1661,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1721,7 +1721,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx rval in + let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1777,7 +1777,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx exp in + let valu = eval_rv ~ctx ctx.local exp in let refine () = let res = invariant ctx ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1851,7 +1851,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx exp in + let rv = eval_rv ~ctx ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current ask with | `Lifted tid when ThreadReturn.is_current ask -> @@ -1867,8 +1867,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Var v, NoOffset) in - let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in + let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,18 +1876,18 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ~ctx ?(warn=false) (exps: exp list) = + let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps - let collect_invalidate ~deep ~ctx ?(warn=false) (exps: exp list) = + let collect_invalidate ~deep ~ctx ?(warn=false) (st:store) (exps: exp list) = if deep then - collect_funargs ~ctx ~warn exps + collect_funargs ~ctx ~warn st exps else ( - let mpt e = match eval_rv_address ~ctx e with + let mpt e = match eval_rv_address ~ctx st e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -1908,7 +1908,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~ctx ~warn:true exps in + let args = collect_invalidate ~deep ~ctx ~warn:true st exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -1928,7 +1928,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx) args in + let vals = List.map (eval_rv ~ctx st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2022,8 +2022,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false ~ctx shallow_args in - let deep_flist = collect_invalidate ~deep:true ~ctx deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx ctx.local shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx ctx.local deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; @@ -2072,7 +2072,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address ~ctx ptr with + match eval_rv_address ~ctx ctx.local ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx (Lval src_cast_lval) + eval_rv ~ctx st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx n with + begin match eval_rv ~ctx st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx s1 in + let s1_v = eval_rv ~ctx st s1 in let s1_a = address_from_value s1_v in let s1_typ = AD.type_of s1_a in - let s2_v = eval_rv ~ctx s2 in + let s2_v = eval_rv ~ctx st s2 in let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx ch in + let eval_ch = eval_rv ~ctx st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx s in + let v = eval_rv ~ctx st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx exp in + let rv = eval_rv ~ctx ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2387,7 +2387,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx dst_lval in - match eval_rv ~ctx mtyp with + match eval_rv ~ctx st mtyp with | Int x -> begin match ID.to_int x with @@ -2406,22 +2406,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx x in - let eval_y = eval_rv ~ctx y in + let eval_x = eval_rv ~ctx st x in + let eval_y = eval_rv ~ctx st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2481,10 +2481,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match eval_rv ~ctx ret_var with + match eval_rv ~ctx st ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx id with + begin match eval_rv ~ctx st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in @@ -2553,7 +2553,7 @@ struct check_invalid_mem_dealloc ctx f p; begin match lv with | Some lv -> - let p_rv = eval_rv ~ctx p in + let p_rv = eval_rv ~ctx st p in let p_addr = match p_rv with | Address a -> a @@ -2587,7 +2587,7 @@ struct st | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> - let st' = match eval_rv ~ctx env with + let st' = match eval_rv ~ctx st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2617,7 +2617,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx value in + let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index df93be5896..4d51895683 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,8 +15,8 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address ~ctx (Lval x) with + match eval_rv_address ~ctx st (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx (Lval x) with + (match eval_rv ~ctx st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx e in + let eval e st = eval_rv ~ctx st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From 7c50968b1487c8c72037eaf11b598388790cbf50 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 13:39:44 +0200 Subject: [PATCH 47/71] Add st back everywhere (as for now) --- src/analyses/base.ml | 181 +++++++++++++++++----------------- src/analyses/baseInvariant.ml | 10 +- 2 files changed, 96 insertions(+), 95 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 86d45720e4..63f516c82c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -680,14 +680,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv ~(ctx: _ ctx) (exp:exp): value = + let rec eval_rv ~(ctx: _ ctx) (st: store) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx exp + eval_rv_ask_evalint ~ctx st exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -696,8 +696,8 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint ~ctx exp = - let eval_next () = eval_rv_no_ask_evalint ~ctx exp in + and eval_rv_ask_evalint ~ctx st exp = + let eval_next () = eval_rv_no_ask_evalint ~ctx st exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with @@ -720,25 +720,24 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint ~ctx exp = - eval_rv_base ~ctx exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx st exp = + eval_rv_base ~ctx st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up ~ctx exp = + and eval_rv_back_up ~ctx st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv ~ctx exp + eval_rv ~ctx st exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base ~ctx exp (* bypass all queries *) + eval_rv_base ~ctx st exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base ~ctx (exp:exp): value = - let st = ctx.local in + and eval_rv_base ~ctx (st: store) (exp:exp): value = let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -760,7 +759,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv ~ctx (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -780,8 +779,8 @@ struct (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv ~ctx e1 in - let a2 = eval_rv ~ctx e2 in + let a1 = eval_rv ~ctx st e1 in + let a2 = eval_rv ~ctx st e2 in let extra_is_safe = match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -790,7 +789,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop ~ctx op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx st op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -823,8 +822,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv ~ctx e in (* value of common exp *) - let vs = List.map (eval_rv ~ctx) es in (* values of other sides *) + let v = eval_rv ~ctx st e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx st) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -866,25 +865,25 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop ~ctx LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx st LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop ~ctx op ~e1 ~e2 typ + evalbinop ~ctx st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv ~ctx arg1 in + let a1 = eval_rv ~ctx st arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv ~ctx lval) + | AddrOf lval -> Address (eval_lv ~ctx st lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv ~ctx lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) + Address (AD.map array_start (eval_lv ~ctx st lval)) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv ~ctx exp in + let v = eval_rv ~ctx st exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -902,7 +901,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx st (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get ~ctx st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -915,7 +914,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv ~ctx b in (* abstract base addresses *) + let p = eval_lv ~ctx st b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -953,20 +952,20 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx st ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal ~ctx op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx st op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) let ask = Analyses.ask_of_ctx ctx in - let a1 = eval_rv ~ctx e1 in - let a2 = eval_rv ~ctx e2 in + let a1 = eval_rv ~ctx st e1 in + let a2 = eval_rv ~ctx st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base ask op t1 a1 t2 a2 t in @@ -1005,48 +1004,48 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv ~ctx (exp:exp): AD.t = + and eval_fv ~ctx st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv ~ctx lval - | _ -> eval_tv ~ctx exp + | Lval lval -> eval_lv ~ctx st lval + | _ -> eval_tv ~ctx st exp (* Used also for thread creation: *) - and eval_tv ~ctx (exp:exp): AD.t = - match eval_rv ~ctx exp with + and eval_tv ~ctx st (exp:exp): AD.t = + match eval_rv ~ctx st exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int ~ctx exp = - match eval_rv ~ctx exp with + and eval_int ~ctx st exp = + match eval_rv ~ctx st exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset ~ctx (ofs: offset) = + and convert_offset ~ctx (st: store) (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx st ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset ~ctx ofs) + `Index (IdxDom.top (), convert_offset ~ctx st ofs) | Index (exp, ofs) -> - match eval_rv ~ctx exp with - | Int i -> `Index (iDtoIdx i, convert_offset ~ctx ofs) - | Address add -> `Index (AD.to_int add, convert_offset ~ctx ofs) - | Top -> `Index (IdxDom.top (), convert_offset ~ctx ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx ofs) + match eval_rv ~ctx st exp with + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx st ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx st ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx st ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv ~ctx (lval:lval): AD.t = + and eval_lv ~ctx st (lval:lval): AD.t = let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset ~ctx ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx st ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match eval_rv ~ctx n with + match eval_rv ~ctx st n with | Address adr -> ( if AD.is_null adr then ( @@ -1059,14 +1058,14 @@ struct ); (* Warn if any of the addresses contains a non-local and non-global variable *) if AD.exists (function - | AD.Addr.Addr (v, _) -> not (CPA.mem v ctx.local.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) + | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset ~ctx ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx st ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr @@ -1080,15 +1079,15 @@ struct (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) let eval_rv ~ctx (st: store) (exp:exp): value = try - let r = eval_rv ~ctx exp in + let r = eval_rv ~ctx st exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ~ctx e = + let query_evalint ~ctx st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ~ctx e with + let r = match eval_rv_no_ask_evalint ~ctx st e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) @@ -1109,7 +1108,7 @@ struct Queries.Result.top q (* query cycle *) else ( match q with - | EvalInt e -> query_evalint ~ctx e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) @@ -1133,7 +1132,7 @@ struct | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv ~ctx fval in + let fp = eval_fv ~ctx ctx.local fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -1264,7 +1263,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx e + query_evalint ~ctx ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx ctx.local e with @@ -1723,7 +1722,7 @@ struct char_array_hack (); let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv ~ctx lval in + let lval_val = eval_lv ~ctx ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1755,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot ~ctx (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx ctx.local (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1866,7 +1865,7 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv ~ctx (Var v, NoOffset) in + let lval = eval_lv ~ctx ctx.local (Var v, NoOffset) in let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value @@ -2005,7 +2004,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv ~ctx start in + let start_addr = eval_tv ~ctx ctx.local start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2156,7 +2155,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv ~ctx lval in + let addr = eval_lv ~ctx ctx.local lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2182,7 +2181,7 @@ struct in let dest_a, dest_typ = addr_type_of_exp dst in let src_lval = mkMem ~addr:(Cil.stripCasts src) ~off:NoOffset in - let src_typ = eval_lv ~ctx src_lval + let src_typ = eval_lv ~ctx ctx.local src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then @@ -2234,7 +2233,7 @@ struct begin match lv, op_addr with | Some lv_val, Some f -> (* when whished types coincide, compute result of operation op_addr, otherwise use top *) - let lv_a = eval_lv ~ctx lv_val in + let lv_a = eval_lv ~ctx st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) set ~ctx st lv_a lv_typ (f s1_a s2_a) @@ -2250,7 +2249,7 @@ struct (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~ctx st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get ~ctx st s1_a None), get ~ctx st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2318,7 +2317,7 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv ~ctx lv_val in + let dest_a = eval_lv ~ctx st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in let v = eval_rv ~ctx st s in let a = address_from_value v in @@ -2346,8 +2345,8 @@ struct string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with | CArrays.IsNotSubstr -> Address (AD.null_ptr) - | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2381,12 +2380,12 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv ~ctx lval in + let address = eval_lv ~ctx st lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv ~ctx dst_lval in + let dest_a = eval_lv ~ctx st dst_lval in match eval_rv ~ctx st mtyp with | Int x -> begin @@ -2471,7 +2470,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv ~ctx lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2504,8 +2503,8 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx st size, true)); + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2517,8 +2516,8 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx st size, true)); + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2530,12 +2529,12 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int ~ctx size in - let countval = eval_int ~ctx n in + let sizeval = eval_int ~ctx st size in + let countval = eval_int ~ctx st n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2543,7 +2542,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2564,7 +2563,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ~ctx st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ~ctx size in + let size_int = eval_int ~ctx st size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = @@ -2573,7 +2572,7 @@ struct else heap_addr in - let lv_addr = eval_lv ~ctx lv in + let lv_addr = eval_lv ~ctx st lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2597,7 +2596,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ~ctx lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2624,7 +2623,7 @@ struct begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv ~ctx x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2746,7 +2745,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx st (eval_lv ~ctx st lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2844,11 +2843,13 @@ struct module V = V module G = G + let ost = octx.local + (* all evals happen in octx with non-top values *) - let eval_rv ~ctx e = eval_rv ~ctx:octx e - let eval_rv_address ~ctx e = eval_rv_address ~ctx:octx e - let eval_lv ~ctx lv = eval_lv ~ctx:octx lv - let convert_offset ~ctx o = convert_offset ~ctx:octx o + let eval_rv ~ctx st e = eval_rv ~ctx:octx ost e + let eval_rv_address ~ctx st e = eval_rv_address ~ctx:octx ost e + let eval_lv ~ctx st lv = eval_lv ~ctx:octx ost lv + let convert_offset ~ctx st o = convert_offset ~ctx:octx ost o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2922,7 +2923,7 @@ struct Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 4d51895683..e66a431ccf 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -17,8 +17,8 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t - val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t - val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> lval -> AD.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> offset -> ID.t Offset.t val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv ~ctx lval in + let addr = eval_lv ~ctx st lval in if (AD.is_top addr) then st else let old_val = get ~ctx st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,13 +92,13 @@ struct else set st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = - let set' lval v st = set st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set st (eval_lv ~ctx st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset ~ctx o in + let offs = convert_offset ~ctx st o in let new_val = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st From 2d4f7f2f450ad1e6d1823ed1aeef1829c23789f3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:08:54 +0200 Subject: [PATCH 48/71] Replace ask in evalbinop_base with ctx for consistency --- src/analyses/base.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 63f516c82c..0081459930 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -249,7 +249,7 @@ struct | _ -> false (* Evaluate binop for two abstract values: *) - let evalbinop_base (a: Q.ask) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = + let evalbinop_base ~ctx (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = if M.tracing then M.tracel "eval" "evalbinop %a %a %a\n" d_binop op VD.pretty a1 VD.pretty a2; (* We define a conversion function for the easy cases when we can just use * the integer domain operations. *) @@ -346,7 +346,7 @@ struct let ax = AD.choose x in let ay = AD.choose y in let handle_address_is_multiple addr = begin match Addr.to_var addr with - | Some v when a.f (Q.IsMultiple v) -> + | Some v when ctx.ask (Q.IsMultiple v) -> if M.tracing then M.tracel "addr" "IsMultiple %a\n" CilType.Varinfo.pretty v; None | _ -> @@ -782,7 +782,7 @@ struct let a1 = eval_rv ~ctx st e1 in let a2 = eval_rv ~ctx st e2 in let extra_is_safe = - match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with + match evalbinop_base ~ctx op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -963,19 +963,18 @@ struct (** Evaluate BinOp using MustBeEqual query as fallback. *) and evalbinop_mustbeequal ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let ask = Analyses.ask_of_ctx ctx in let a1 = eval_rv ~ctx st e1 in let a2 = eval_rv ~ctx st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base ask op t1 a1 t2 a2 t in + let r = evalbinop_base ~ctx op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) | _ -> (* Fallback to MustBeEqual query, could get extra precision from exprelation/var_eq. *) let must_be_equal () = - let r = Q.must_be_equal ask e1 e2 in + let r = Q.must_be_equal (Analyses.ask_of_ctx ctx) e1 e2 in if M.tracing then M.tracel "query" "MustBeEqual (%a, %a) = %b\n" d_exp e1 d_exp e2 r; r in From cd871fca53343e7f9af82a5a96a82cf92e911e38 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:43:42 +0200 Subject: [PATCH 49/71] Replace ctx with ask in reachable_from_value --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0081459930..7a4db866a5 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -513,7 +513,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value ~ctx (value: value) (t: typ) (description: string) = + let rec reachable_from_value ask (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -525,12 +525,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ~ctx e t description + | Union (f,e) -> reachable_from_value ask e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ~ctx (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ~ctx e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx v t description) acc) s empty + | Array a -> reachable_from_value ask (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ask e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ask v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -543,7 +543,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps From 7af5e41b4c081d7940d42a05084ef3d81c636524 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:51:59 +0200 Subject: [PATCH 50/71] Add st back to reachable_vars and reachable_from_address --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7a4db866a5..3794558a45 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -541,9 +541,9 @@ struct (* Get the list of addresses accessable immediately from a given address, thus * all pointers within a structure should be considered, but we don't follow * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address ~ctx (adr: address): address = + let reachable_from_address ~ctx st (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx st adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -551,7 +551,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars ~ctx (args: address list): address list = + let reachable_vars ~ctx (st: store) (args: address list): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -564,7 +564,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ~ctx var) acc in + AD.union (reachable_from_address ~ctx st var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -1341,7 +1341,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ~ctx [a'] in + let addrs = reachable_vars ~ctx ctx.local [a'] in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1877,7 +1877,7 @@ struct let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ~ctx [immediately_reachable] + reachable_vars ~ctx st [immediately_reachable] in List.concat_map do_exp exps @@ -1951,7 +1951,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx (get_ptrs vals)) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx st (get_ptrs vals)) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From c9ccbb6833a31ebe54020e5f0be2ed0f7f625e7b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:56:55 +0200 Subject: [PATCH 51/71] Fix reachable_vars timing --- src/analyses/base.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3794558a45..f7c6b436cb 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -573,7 +573,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ~ctx args = Timing.wrap "reachability" (reachable_vars ~ctx) args + let reachable_vars ~ctx st args = Timing.wrap "reachability" (reachable_vars ~ctx st) args let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else From bd5d65d96aa18c66f0cb14df999335b47c60b32e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 9 Jan 2024 13:45:55 +0200 Subject: [PATCH 52/71] Detect query cycles in eval_exp --- src/analyses/base.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f7c6b436cb..81e4591123 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1107,12 +1107,12 @@ struct Queries.Result.top q (* query cycle *) else ( match q with - | EvalInt e -> query_evalint ~ctx st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx:(ctx' (Queries.Set.add anyq asked)) st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) - and ctx = - { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) + and ctx' asked = + { ask = (fun (type a) (q: a Queries.t) -> query asked q) ; emit = (fun _ -> failwith "Cannot \"emit\" in base eval_exp context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node @@ -1126,7 +1126,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx st exp with + match eval_rv ~ctx:(ctx' Queries.Set.empty) st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None From 76e5d3829c4ba784e5d2459894d8c7c6ce8fcce0 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 9 Jan 2024 13:53:00 +0200 Subject: [PATCH 53/71] Avoid doing Analyses.ask_of_ctx ctx for each exp in a list --- src/analyses/base.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 81e4591123..e77e3ac95c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1875,8 +1875,9 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = + let ask = Analyses.ask_of_ctx ctx in let do_exp e = - let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx st [immediately_reachable] in List.concat_map do_exp exps From 2d1b4204574733c7f081a1c5f2b859b22da04eeb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 12:06:51 +0200 Subject: [PATCH 54/71] Use only tops for arrays in ValueDomain.top_value --- src/cdomains/valueDomain.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 003a65a49e..8fb639deb9 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -199,9 +199,8 @@ struct | TComp ({cstruct=false; _},_) -> Union (Unions.top ()) | TArray (ai, length, _) -> let typAttr = typeAttrs ai in - let can_recover_from_top = ArrayDomain.can_recover_from_top (ArrayDomain.get_domain ~varAttr ~typAttr) in let len = array_length_idx (IndexDomain.top ()) length in - Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else Bot)) + Array (CArrays.make ~varAttr ~typAttr len (top_value ai)) | TNamed ({ttype=t; _}, _) -> top_value ~varAttr t | _ -> Top From 11e89489ee3ffe7b9587d64a6e0d9994cb55cc9f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 12:09:13 +0200 Subject: [PATCH 55/71] Mark fixed TODOs in 03-practical/31-zstd-cctxpool-blobs --- tests/regression/03-practical/31-zstd-cctxpool-blobs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/regression/03-practical/31-zstd-cctxpool-blobs.c b/tests/regression/03-practical/31-zstd-cctxpool-blobs.c index 40e448eb22..c91c141446 100644 --- a/tests/regression/03-practical/31-zstd-cctxpool-blobs.c +++ b/tests/regression/03-practical/31-zstd-cctxpool-blobs.c @@ -22,8 +22,8 @@ int main() { ZSTDMT_CCtxPool* const cctxPool = calloc(1, sizeof(ZSTDMT_CCtxPool)); cctxPool->cctx[0] = malloc(sizeof(ZSTD_CCtx)); if (!cctxPool->cctx[0]) // TODO NOWARN - __goblint_check(1); // TODO reachable + __goblint_check(1); // reachable else - __goblint_check(1); // TODO reachable + __goblint_check(1); // reachable return 0; } From 022a9bcaadc762c2f5d46db7d564c55dec58ba72 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 10:38:40 +0100 Subject: [PATCH 56/71] `affeq`: Fix array OOB in `invariant` --- .../apron/affineEqualityDomain.apron.ml | 2 +- tests/regression/63-affeq/19-witness.c | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) create mode 100644 tests/regression/63-affeq/19-witness.c diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ab24515c28..ce3f2592f4 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -681,7 +681,7 @@ struct let invariant t = let invariant m = let earray = Lincons1.array_make t.env (Matrix.num_rows m) in - for i = 0 to Lincons1.array_length earray do + for i = 0 to (Lincons1.array_length earray -1) do let row = Matrix.get_row m i in let coeff_vars = List.map (fun x -> Coeff.s_of_mpqf @@ Vector.nth row (Environment.dim_of_var t.env x), x) (vars t) in let cst = Coeff.s_of_mpqf @@ Vector.nth row (Vector.length row - 1) in diff --git a/tests/regression/63-affeq/19-witness.c b/tests/regression/63-affeq/19-witness.c new file mode 100644 index 0000000000..1659e01cb6 --- /dev/null +++ b/tests/regression/63-affeq/19-witness.c @@ -0,0 +1,18 @@ +//SKIP PARAM: --set ana.activated[+] affeq --set sem.int.signed_overflow assume_none --set ana.relation.privatization top --enable witness.yaml.enabled +// Identical to Example 63/01; additionally checking that writing out witnesses does not crash the analyzer +#include + +void main(void) { + int i; + int j; + int k; + i = 2; + j = k + 5; + + while (i < 100) { + __goblint_check(3 * i - j + k == 1); + i = i + 1; + j = j + 3; + } + __goblint_check(3 * i - j + k == 1); +} From f99f320118a84ec0c243ca3aeda40737e450e376 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 12:53:45 +0100 Subject: [PATCH 57/71] Simplify --- src/cdomains/apron/affineEqualityDomain.apron.ml | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ce3f2592f4..bc1cfe41cf 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -680,19 +680,15 @@ struct let invariant t = let invariant m = - let earray = Lincons1.array_make t.env (Matrix.num_rows m) in - for i = 0 to (Lincons1.array_length earray -1) do + let one_constraint i = let row = Matrix.get_row m i in let coeff_vars = List.map (fun x -> Coeff.s_of_mpqf @@ Vector.nth row (Environment.dim_of_var t.env x), x) (vars t) in let cst = Coeff.s_of_mpqf @@ Vector.nth row (Vector.length row - 1) in - Lincons1.set_list (Lincons1.array_get earray i) coeff_vars (Some cst) - done; - let {lincons0_array; array_env}: Lincons1.earray = earray in - Array.enum lincons0_array - |> Enum.map (fun (lincons0: Lincons0.t) -> - Lincons1.{lincons0; env = array_env} - ) - |> List.of_enum + let e1 = Linexpr1.make t.env in + Linexpr1.set_list e1 coeff_vars (Some cst); + Lincons1.make e1 EQ + in + List.init (Matrix.num_rows m) (one_constraint) in BatOption.map_default invariant [] t.d From ca18e353f4beba13867628c96daf78fe3ae059bd Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 14:14:28 +0100 Subject: [PATCH 58/71] Remark on issue with fractional coefficients --- tests/regression/63-affeq/19-witness.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/regression/63-affeq/19-witness.c b/tests/regression/63-affeq/19-witness.c index 1659e01cb6..541aceab29 100644 --- a/tests/regression/63-affeq/19-witness.c +++ b/tests/regression/63-affeq/19-witness.c @@ -15,4 +15,20 @@ void main(void) { j = j + 3; } __goblint_check(3 * i - j + k == 1); + + // Represented with fractional coefficients and thus not put into witness yet + + int a = 0; + int b = 0; + int z = 0; + + while(z < 100) { + a++; + b += 2; + z++; + + __goblint_check(2*z - b == 0); + // b == 2*z is put into the witness + } + } From a521bdf24abf6a24c3086fd25be30722f99b8d7b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 17:02:24 +0100 Subject: [PATCH 59/71] Rm spurious parens Co-authored-by: Julian Erhard --- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index bc1cfe41cf..55937a323d 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -688,7 +688,7 @@ struct Linexpr1.set_list e1 coeff_vars (Some cst); Lincons1.make e1 EQ in - List.init (Matrix.num_rows m) (one_constraint) + List.init (Matrix.num_rows m) one_constraint in BatOption.map_default invariant [] t.d From 271cc170734e1c0b645c2114abe76b5047443231 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:19:06 +0200 Subject: [PATCH 60/71] Rename Ptranal wrapper module, add to API docs --- src/analyses/{ptranalEvalFunvar.ml => ptranalAnalysis.ml} | 4 +++- src/goblint_lib.ml | 1 + 2 files changed, 4 insertions(+), 1 deletion(-) rename src/analyses/{ptranalEvalFunvar.ml => ptranalAnalysis.ml} (79%) diff --git a/src/analyses/ptranalEvalFunvar.ml b/src/analyses/ptranalAnalysis.ml similarity index 79% rename from src/analyses/ptranalEvalFunvar.ml rename to src/analyses/ptranalAnalysis.ml index a5d8ca1c9f..d9352448c2 100644 --- a/src/analyses/ptranalEvalFunvar.ml +++ b/src/analyses/ptranalAnalysis.ml @@ -1,4 +1,6 @@ -(** Wrapper analysis to answer EvalFunvar query using Cil's pointer analysis. *) +(** CIL's {!GoblintCil.Ptranal} for function pointer evaluation ([ptranal]). + + Useful for sound analysis of function pointers without base. *) open GoblintCil open Analyses diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 06c51b0c15..4b2eecb632 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -164,6 +164,7 @@ module TaintPartialContexts = TaintPartialContexts module UnassumeAnalysis = UnassumeAnalysis module ExpRelation = ExpRelation module AbortUnless = AbortUnless +module PtranalAnalysis = PtranalAnalysis (** {1 Domains} From 808b5d220fe6ea522e9da6f265369eac697468f3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:20:47 +0200 Subject: [PATCH 61/71] Add TODOs to ptranal --- src/analyses/ptranalAnalysis.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/analyses/ptranalAnalysis.ml b/src/analyses/ptranalAnalysis.ml index d9352448c2..6991b5ea22 100644 --- a/src/analyses/ptranalAnalysis.ml +++ b/src/analyses/ptranalAnalysis.ml @@ -2,6 +2,8 @@ Useful for sound analysis of function pointers without base. *) +(* TODO: fix unsoundness on some bench repo examples: https://github.com/goblint/analyzer/pull/1063 *) + open GoblintCil open Analyses @@ -15,6 +17,7 @@ struct match q with | Queries.EvalFunvar (Lval (Mem e, _)) -> let funs = Ptranal.resolve_exp e in + (* TODO: filter compatible function pointers by type? *) List.fold_left (fun xs f -> Queries.AD.add (Queries.AD.Addr.of_var f) xs) (Queries.AD.empty ()) funs | _ -> Queries.Result.top q From 408fbe119057d7f0450be9d63cc2cd11e59fae9a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:26:25 +0200 Subject: [PATCH 62/71] Remove dynamic function call debug message --- src/framework/constraints.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 9887f6e4fb..f5c024c24f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -728,7 +728,6 @@ struct [v] | _ -> (* Depends on base for query. *) - M.debug ~category:Program "Dynamic function call through %a" d_exp e; let ad = ctx.ask (Queries.EvalFunvar e) in Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) in From 380979e71c0d3e2b47a05b59b3eee67ea5cf7785 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 13:50:39 +0200 Subject: [PATCH 63/71] Copy VMCAI 2024 artifact description from bench repo --- docs/artifact-descriptions/vmcai24.md | 76 +++++++++++++++++++++++++++ mkdocs.yml | 1 + 2 files changed, 77 insertions(+) create mode 100644 docs/artifact-descriptions/vmcai24.md diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md new file mode 100644 index 0000000000..3673937dc6 --- /dev/null +++ b/docs/artifact-descriptions/vmcai24.md @@ -0,0 +1,76 @@ +# Correctness Witness Validation by Abstract Interpretation +## Artifact + +This artifact contains everything mentioned in the evaluation section of the paper: Goblint implementation, scripts, benchmarks, manual witnesses and other tools. + +**Note to artifact reviewers:** in the smoke test phase, try to only run the performance evaluation since it is very quick compared to the precision evaluation. + +## Requirements +* [VirtualBox](https://www.virtualbox.org/). +* 2 CPU cores. +* 8 GB RAM. +* 7 GB disk space. +* ~45min. + +## Layout +* `README.md`/`README.pdf` — this file. +* `LICENSE`. +* `unassume.ova` — VirtualBox virtual machine. + + In `/home/vagrant` contains: + * `goblint/` ­— Goblint with unassume support, including source code. + * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). + * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). + * `results/` — results (initially empty). + +* `results/` — evaluation results tables with data used for the paper. + +## Reproduction +1. Import the virtual machine into VirtualBox. +2. Start the virtual machine and log in with username "vagrant" (not "Ubuntu"!) and password "vagrant". +3. Right click on the desktop and open Applications → Accessories → Terminal Emulator. + +### Precision evaluation +1. Run `./eval-prec/run.sh` in the terminal emulator. This takes ~42min. +2. Run `firefox results/eval-prec/table-generator.table.html` to view the results. + + The HTML table contains the following status columns (cputime, walltime and memory can be ignored): + 1. Goblint w/o witness (true means verified). + 2. Goblint w/ manual witness (true means witness validated). + 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). + 4. Goblint w/ witness from CPAchecker (true means witness validated). + 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). + 6. Goblint w/ witness from UAutomizer (true means witness validated). + + Table 1 in the paper presents these results, except the rows are likely in a different order. + +### Performance evaluation +1. Run `./eval-perf/run.sh` in the terminal emulator. This takes ~30s. +2. Run `firefox results/eval-perf/table-generator.table.html` to view the results. + + The HTML table contains the following relevant columns (others can be ignored): + 1. Goblint w/o witness, evals. + 2. Goblint w/o witness, cputime. + 3. Goblint w/ manual witness, evals. + 4. Goblint w/ manual witness, cputime. + + Table 2 in the paper presents these results, except the rows are likely in a different order. + + +## Goblint implementation +[Goblint](https://github.com/goblint/analyzer) is an open source static analysis framework for C. +Goblint itself is written in OCaml. +Being open source, it allows existing implementations of analyses and abstract domains to be reused and modified. +As a framework, it also allows new ones to be easily added. +For more details, refer to the linked GitHub repository and related documentation. + +Key parts of the code related to this paper are the following: + +1. `src/analyses/unassumeAnalysis.ml`: analysis, which emits unassume operation events to other analyses for YAML-witness–guided verification. +2. `src/analyses/base.ml` lines 2551–2641: propagating unassume for non-relational domains of the `base` analysis. +3. `src/analyses/apron/relationAnalysis.apron.ml` lines 668–693: strengthening-based dual-narrowing unassume for relational Apron domains of the `apron` analysis. +4. `src/cdomains/apron/apronDomain.apron.ml` lines 625–679: strengthening operator used for dual-narrowing of Apron domains. +5. `src/util/wideningTokens.ml`: analysis lifter that adds widening tokens for delaying widenings from unassuming. +6. `src/witness/yamlWitness.ml` lines 398–683: YAML witness validation. diff --git a/mkdocs.yml b/mkdocs.yml index 428e28078d..8064703c12 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -39,3 +39,4 @@ nav: - '📦 Artifact descriptions': - "🇸 SAS '21": artifact-descriptions/sas21.md - "🇪 ESOP '23": artifact-descriptions/esop23.md + - "🇻 VMCAI '24": artifact-descriptions/vmcai24.md From 3625b6719c2e41064809900c9d408667846c932a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 13:51:23 +0200 Subject: [PATCH 64/71] Fix lists in VMACI24 artifact description --- docs/artifact-descriptions/vmcai24.md | 41 ++++++++++++++------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md index 3673937dc6..9f44bd20e4 100644 --- a/docs/artifact-descriptions/vmcai24.md +++ b/docs/artifact-descriptions/vmcai24.md @@ -17,13 +17,14 @@ This artifact contains everything mentioned in the evaluation section of the pap * `LICENSE`. * `unassume.ova` — VirtualBox virtual machine. - In `/home/vagrant` contains: - * `goblint/` ­— Goblint with unassume support, including source code. - * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). - * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). - * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). - * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). - * `results/` — results (initially empty). + In `/home/vagrant` contains: + + * `goblint/` ­— Goblint with unassume support, including source code. + * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). + * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). + * `results/` — results (initially empty). * `results/` — evaluation results tables with data used for the paper. @@ -36,13 +37,14 @@ This artifact contains everything mentioned in the evaluation section of the pap 1. Run `./eval-prec/run.sh` in the terminal emulator. This takes ~42min. 2. Run `firefox results/eval-prec/table-generator.table.html` to view the results. - The HTML table contains the following status columns (cputime, walltime and memory can be ignored): - 1. Goblint w/o witness (true means verified). - 2. Goblint w/ manual witness (true means witness validated). - 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). - 4. Goblint w/ witness from CPAchecker (true means witness validated). - 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). - 6. Goblint w/ witness from UAutomizer (true means witness validated). + The HTML table contains the following status columns (cputime, walltime and memory can be ignored): + + 1. Goblint w/o witness (true means verified). + 2. Goblint w/ manual witness (true means witness validated). + 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). + 4. Goblint w/ witness from CPAchecker (true means witness validated). + 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). + 6. Goblint w/ witness from UAutomizer (true means witness validated). Table 1 in the paper presents these results, except the rows are likely in a different order. @@ -50,11 +52,12 @@ This artifact contains everything mentioned in the evaluation section of the pap 1. Run `./eval-perf/run.sh` in the terminal emulator. This takes ~30s. 2. Run `firefox results/eval-perf/table-generator.table.html` to view the results. - The HTML table contains the following relevant columns (others can be ignored): - 1. Goblint w/o witness, evals. - 2. Goblint w/o witness, cputime. - 3. Goblint w/ manual witness, evals. - 4. Goblint w/ manual witness, cputime. + The HTML table contains the following relevant columns (others can be ignored): + + 1. Goblint w/o witness, evals. + 2. Goblint w/o witness, cputime. + 3. Goblint w/ manual witness, evals. + 4. Goblint w/ manual witness, cputime. Table 2 in the paper presents these results, except the rows are likely in a different order. From d57d3c1193253ce69f36c7be4e618ad94e7be12c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 14:26:16 +0200 Subject: [PATCH 65/71] Rewrite VMCAI24 artifact description intro --- docs/artifact-descriptions/vmcai24.md | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md index 9f44bd20e4..860ef6c9fd 100644 --- a/docs/artifact-descriptions/vmcai24.md +++ b/docs/artifact-descriptions/vmcai24.md @@ -1,9 +1,13 @@ -# Correctness Witness Validation by Abstract Interpretation -## Artifact +# VMCAI '24 Artifact Description +## Correctness Witness Validation by Abstract Interpretation + +This is the artifact description for our [VMCAI '24 paper "Correctness Witness Validation by Abstract Interpretation"](https://doi.org/10.1007/978-3-031-50524-9_4). +The artifact is available on [Zenodo](https://doi.org/10.5281/zenodo.8253000). This artifact contains everything mentioned in the evaluation section of the paper: Goblint implementation, scripts, benchmarks, manual witnesses and other tools. -**Note to artifact reviewers:** in the smoke test phase, try to only run the performance evaluation since it is very quick compared to the precision evaluation. +**The description here is provided for convenience and not maintained.** +The artifact is based on [Goblint at `vmcai24` git tag](https://github.com/goblint/analyzer/releases/tag/vmcai24) and [Goblint benchmarks at `vmcai24` git tag](https://github.com/goblint/bench/releases/tag/vmcai24). ## Requirements * [VirtualBox](https://www.virtualbox.org/). From 5d291caf43da73d24f3093ec36cced018972cc30 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 17:30:15 +0200 Subject: [PATCH 66/71] Use Cilfacade.get_stmtLoc in TerminationPreprocessing --- src/util/terminationPreprocessing.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/util/terminationPreprocessing.ml b/src/util/terminationPreprocessing.ml index 9023a68f8a..95fae95d26 100644 --- a/src/util/terminationPreprocessing.ml +++ b/src/util/terminationPreprocessing.ml @@ -59,8 +59,8 @@ class loopCounterVisitor lc (fd : fundec) = object(self) s.skind <- Block nb; s | Goto (sref, l) -> - let goto_jmp_stmt = sref.contents.skind in - let loc_stmt = Cil.get_stmtLoc goto_jmp_stmt in + let goto_jmp_stmt = sref.contents in + let loc_stmt = Cilfacade.get_stmtLoc goto_jmp_stmt in if CilType.Location.compare l loc_stmt >= 0 then ( (* is pos if first loc is greater -> below the second loc *) (* problem: the program might not terminate! *) From b9e390598e3c9306673a1c3b6a2338f34a641f0f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 17:30:23 +0200 Subject: [PATCH 67/71] Use List.concat_map in EvalAssert --- src/transform/evalAssert.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/transform/evalAssert.ml b/src/transform/evalAssert.ml index 91bdb82ce1..9f8f785817 100644 --- a/src/transform/evalAssert.ml +++ b/src/transform/evalAssert.ml @@ -119,7 +119,7 @@ module EvalAssert = struct s | If (e, b1, b2, l,l2) -> let vars = Basetype.CilExp.get_vars e in - let asserts ~node loc vs = if full then make_assert ~node loc None else List.map (fun x -> make_assert ~node loc (Some (Var x,NoOffset))) vs |> List.concat in + let asserts ~node loc vs = if full then make_assert ~node loc None else List.concat_map (fun x -> make_assert ~node loc (Some (Var x,NoOffset))) vs in let add_asserts block = if block.bstmts <> [] then let with_asserts = From f1daea022fb7d85cf5c02de36768417ee797e326 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:11:08 +0200 Subject: [PATCH 68/71] Remove some empty if branches found by semgrep --- src/analyses/base.ml | 2 +- src/analyses/poisonVariables.ml | 2 -- src/cdomain/value/cdomains/arrayDomain.ml | 1 - src/common/framework/cfgTools.ml | 2 -- src/common/util/cilfacade.ml | 2 -- src/framework/constraints.ml | 2 +- src/solver/generic.ml | 2 +- src/solver/sLR.ml | 4 ++-- src/transform/evalAssert.ml | 2 -- 9 files changed, 5 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index fb2b5af517..c66b53320e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -511,7 +511,7 @@ struct if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with | Top -> - if VD.is_immediate_type t then () else M.info ~category:Unsound "Unknown value in %s could be an escaped pointer address!" description; empty + if not (VD.is_immediate_type t) then M.info ~category:Unsound "Unknown value in %s could be an escaped pointer address!" description; empty | Bot -> (*M.debug ~category:Analyzer "A bottom value when computing reachable addresses!";*) empty | Address adrs when AD.is_top adrs -> M.info ~category:Unsound "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) diff --git a/src/analyses/poisonVariables.ml b/src/analyses/poisonVariables.ml index 865cb928aa..7100534fab 100644 --- a/src/analyses/poisonVariables.ml +++ b/src/analyses/poisonVariables.ml @@ -82,8 +82,6 @@ struct M.info ~category:(Behavior (Undefined Other)) ~loc:(Node longjmp_node) "Since setjmp at %a, potentially all locals were modified! Reading them will yield Undefined Behavior." Node.pretty ctx.prev_node else if not (Queries.VS.is_empty modified_locals) then M.info ~category:(Behavior (Undefined Other)) ~loc:(Node longjmp_node) "Since setjmp at %a, locals %a were modified! Reading them will yield Undefined Behavior." Node.pretty ctx.prev_node Queries.VS.pretty modified_locals - else - () ) longjmp_nodes; D.join modified_locals ctx.local | Access {ad; kind = Read; _} -> diff --git a/src/cdomain/value/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml index d4d5a46e98..ba205fa14f 100644 --- a/src/cdomain/value/cdomains/arrayDomain.ml +++ b/src/cdomain/value/cdomains/arrayDomain.ml @@ -855,7 +855,6 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | _ -> AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown "May access array out of bounds" - else () module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = diff --git a/src/common/framework/cfgTools.ml b/src/common/framework/cfgTools.ml index 78aba17060..d47f1efde0 100644 --- a/src/common/framework/cfgTools.ml +++ b/src/common/framework/cfgTools.ml @@ -695,8 +695,6 @@ let getGlobalInits (file: file) : edges = Hashtbl.add inits (assign lval) () else if not (Hashtbl.mem inits (assign (any_index lval))) then Hashtbl.add inits (assign (any_index lval)) () - else - () | CompoundInit (typ, lst) -> let ntyp = match typ, lst with | TArray(t, None, attr), [] -> TArray(t, Some zero, attr) (* set initializer type to t[0] for flexible array members of structs that are intialized with {} *) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index eff97da404..d80ce49543 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -84,8 +84,6 @@ let do_preprocess ast = let f fd visitor_fun = ignore @@ visitCilFunction (visitor_fun fd) fd in if active_visitors <> [] then iterGlobals ast (function GFun (fd,_) -> List.iter (f fd) active_visitors | _ -> ()) - else - () (** @raise GoblintCil.FrontC.ParseError @raise GoblintCil.Errormsg.Error *) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index f5c024c24f..84d7eff1ed 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1733,7 +1733,7 @@ struct let compare_locals h1 h2 = let eq, le, gr, uk = ref 0, ref 0, ref 0, ref 0 in let f k v1 = - if not (PP.mem h2 k) then () else + if PP.mem h2 k then let v2 = PP.find h2 k in let b1 = D.leq v1 v2 in let b2 = D.leq v2 v1 in diff --git a/src/solver/generic.ml b/src/solver/generic.ml index 636aed8831..1a866546a1 100644 --- a/src/solver/generic.ml +++ b/src/solver/generic.ml @@ -256,7 +256,7 @@ module SoundBoxSolverImpl = H.replace called x (); (* set the new value for [x] *) eval_rhs_event x; - let set_x d = if H.mem called x then set x d else () in + let set_x d = if H.mem called x then set x d in Option.may (fun f -> set_x (f (eval x) side)) (S.system x); (* remove [x] from called *) H.remove called x diff --git a/src/solver/sLR.ml b/src/solver/sLR.ml index d05d87c4f3..8213fe8166 100644 --- a/src/solver/sLR.ml +++ b/src/solver/sLR.ml @@ -327,7 +327,7 @@ module Make0 = let k = X.get_key x in let _ = work := H.insert !work x in let _ = P.rem_item stable x in - if k >= sk then () else + if k < sk then let _ = X.set_value x (D.bot ()) in (* ignore @@ Pretty.printf " also restarting %d: %a\n" k S.Var.pretty_trace x; *) (* flush_all (); *) @@ -348,7 +348,7 @@ module Make0 = let (i,nonfresh) = X.get_index y in let _ = if xi <= i then HM.replace wpoint y () in let _ = if (V.ver>2) && xi <= i then work := H.insert (!work) y in - let _ = if nonfresh then () else solve y in + let _ = if not nonfresh then solve y in let _ = L.add infl y x in X.get_value y diff --git a/src/transform/evalAssert.ml b/src/transform/evalAssert.ml index 9f8f785817..eab06222ef 100644 --- a/src/transform/evalAssert.ml +++ b/src/transform/evalAssert.ml @@ -130,8 +130,6 @@ module EvalAssert = struct [cStmt "{ %I:asserts %S:b }" (fun n t -> makeVarinfo true "unknown" (TVoid [])) b_loc [("asserts", FI b_assert_instr); ("b", FS block.bstmts)]] in block.bstmts <- with_asserts - else - () in if emit_other then (add_asserts b1; add_asserts b2); s From fe4b6b15297363f35f23b6ff3f167a2e220bcbd2 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:11:39 +0200 Subject: [PATCH 69/71] Use String.sub alternatives found by semgrep --- src/cdomain/value/cdomains/addressDomain.ml | 2 +- src/cdomain/value/cdomains/stringDomain.ml | 2 +- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- src/config/gobConfig.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/cdomain/value/cdomains/addressDomain.ml b/src/cdomain/value/cdomains/addressDomain.ml index 55b1aceefc..263c1033bb 100644 --- a/src/cdomain/value/cdomains/addressDomain.ml +++ b/src/cdomain/value/cdomains/addressDomain.ml @@ -277,7 +277,7 @@ struct let compute_substring s1 s2 = try let i = Str.search_forward (Str.regexp_string s2) s1 0 in - Some (String.sub s1 i (String.length s1 - i)) + Some (Str.string_after s1 i) with Not_found -> None in (* if any of the input address sets contains an element that isn't a StrPtr, return top *) diff --git a/src/cdomain/value/cdomains/stringDomain.ml b/src/cdomain/value/cdomains/stringDomain.ml index 0621f37eb6..2b968b0321 100644 --- a/src/cdomain/value/cdomains/stringDomain.ml +++ b/src/cdomain/value/cdomains/stringDomain.ml @@ -62,7 +62,7 @@ let to_n_c_string n x = else if n < 0 then None else - Some (String.sub x 0 n) + Some (Str.first_chars x n) | None -> None let to_string_length x = diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 55937a323d..f6232d95e6 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -282,7 +282,7 @@ struct let res = (String.concat "" @@ Array.to_list @@ Array.map dim_to_str vars) ^ (const_to_str arr.(Array.length arr - 1)) ^ "=0" in if String.starts_with res "+" then - String.sub res 1 (String.length res - 1) + Str.string_after res 1 else res in diff --git a/src/config/gobConfig.ml b/src/config/gobConfig.ml index 24a1701ce6..16b5511717 100644 --- a/src/config/gobConfig.ml +++ b/src/config/gobConfig.ml @@ -140,7 +140,7 @@ struct let rec split' i = if i Date: Wed, 24 Jan 2024 12:11:59 +0200 Subject: [PATCH 70/71] Remove some boolean equality checks found by semgrep --- src/analyses/raceAnalysis.ml | 2 +- src/incremental/compareCFG.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 6b7217147e..7dae319d6f 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -349,7 +349,7 @@ struct | ts when Queries.TS.is_top ts -> includes_uk := true | ts -> - if Queries.TS.is_empty ts = false then + if not (Queries.TS.is_empty ts) then includes_uk := true; let f = function | TComp (ci, _) -> diff --git a/src/incremental/compareCFG.ml b/src/incremental/compareCFG.ml index 55b3fa8fc5..84b120b8e3 100644 --- a/src/incremental/compareCFG.ml +++ b/src/incremental/compareCFG.ml @@ -97,7 +97,7 @@ let compareCfgs (module CfgOld : CfgForward) (module CfgNew : CfgForward) fun1 f * case the edge is directly added to the diff set to avoid undetected ambiguities during the recursive * call. *) let testFalseEdge edge = match edge with - | Test (p,b) -> p = Cil.one && b = false + | Test (p,false) -> p = Cil.one | _ -> false in let posAmbigEdge edgeList = let findTestFalseEdge (ll,_) = testFalseEdge (snd (List.hd ll)) in let numDuplicates l = List.length (List.find_all findTestFalseEdge l) in From 96a57a23900f11dca735786e38aaa65644d97534 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:12:11 +0200 Subject: [PATCH 71/71] Use incr in CilCfg.countLoopsVisitor --- src/util/cilCfg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/cilCfg.ml b/src/util/cilCfg.ml index 923cf7600b..df766d5bdd 100644 --- a/src/util/cilCfg.ml +++ b/src/util/cilCfg.ml @@ -29,7 +29,7 @@ class countLoopsVisitor(count) = object inherit nopCilVisitor method! vstmt stmt = match stmt.skind with - | Loop _ -> count := !count + 1; DoChildren + | Loop _ -> incr count; DoChildren | _ -> DoChildren end